diff options
| -rw-r--r-- | Alpha.hs | 27 | ||||
| -rw-r--r-- | Biz/Devalloc.hs | 176 | ||||
| -rw-r--r-- | Biz/Id.hs | 7 | ||||
| -rw-r--r-- | Biz/Lint.hs | 2 | ||||
| -rw-r--r-- | Biz/Que/Host.hs | 10 | ||||
| -rw-r--r-- | Biz/Que/Site.hs | 10 | ||||
| -rw-r--r-- | Biz/Test.hs | 11 | ||||
| -rw-r--r-- | Hero/Node.hs | 3 |
8 files changed, 175 insertions, 71 deletions
@@ -41,6 +41,10 @@ module Alpha (</), (<//), + -- * Shoving / binding + bind, + (>>=), + -- * Bool don't, @@ -73,7 +77,8 @@ import Data.String import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText -import Protolude as X hiding (list, ($), (&), (.)) +import Protolude as X hiding (list, ($), (&), (.), (>>=)) +import qualified Prelude -- | Create a list. This should be @Data.List.singleton@ but that doesn't exist. list :: a -> [a] @@ -93,7 +98,7 @@ compose f g x = g (f x) (.>) :: (a -> b) -> (b -> c) -> (a -> c) f .> g = compose f g -infixl 9 .> +-- infixl 0 .> -- | Left-composition operator -- @@ -101,7 +106,7 @@ infixl 9 .> (<.) :: (b -> c) -> (a -> b) -> (a -> c) g <. f = compose f g -infixr 9 <. +-- infixr 0 <. -- | Alias for map, fmap, <$> -- @@ -109,6 +114,8 @@ infixr 9 <. (</) :: Functor f => (a -> b) -> f a -> f b f </ g = fmap f g +-- infixr 1 </ + -- | Double fmap. A function on the left goes "into" two functors -- (i.e. it goes "two levels deep"), applies the function to the inner -- values, then returns the result wrapped in the two functors. @@ -117,6 +124,8 @@ f </ g = fmap f g (<//) :: (Functor f0, Functor f1) => (a -> b) -> f0 (f1 a) -> f0 (f1 b) (<//) = fmap .> fmap +-- infixr 1 <// + -- | Normal function application. Do the right side, then pass the -- return value to the function on the left side. -- @@ -124,7 +133,7 @@ f </ g = fmap f g (<|) :: (a -> b) -> a -> b f <| g = f g -infixr 0 <| +infixr 1 <| -- | Reverse function application. Do the left side, then pass the -- return value to the function on the right side. @@ -143,6 +152,16 @@ infixl 1 |> (/>) :: Functor f => f a -> (a -> b) -> f b f /> g = fmap g f +infixl 1 /> + +bind :: Monad m => m a -> (a -> m b) -> m b +bind a f = a Prelude.>>= f + +(>>=) :: Monad m => m a -> (a -> m b) -> m b +a >>= b = a Prelude.>>= b + +infixl 1 >>= + -- | Removes newlines from text. chomp :: Text -> Text chomp = Text.filter (/= '\n') diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 835d97b..5713db0 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -29,6 +29,7 @@ -- : dep docopt -- : dep envy -- : dep github +-- : dep http-api-data -- : dep ixset -- : dep lucid -- : dep protolude @@ -56,7 +57,7 @@ import Biz.App (CSS (..), HtmlApp (..)) import qualified Biz.Cli as Cli import qualified Biz.Id as Id import qualified Biz.Look -import Biz.Test ((@=?), (@?!=)) +import Biz.Test ((@?!=), (@=?)) import qualified Biz.Test as Test import qualified CMark as Cmark import qualified CMark.Lucid as Cmark @@ -103,7 +104,7 @@ import qualified System.Directory as Directory import qualified System.Envy as Envy import System.FilePath ((<.>), (</>)) import qualified System.Process as Process -import qualified Web.FormUrlEncoded +import qualified Web.FormUrlEncoded as Web -- * persistent data @@ -143,6 +144,12 @@ $(deriveSafeCopy 0 'base ''GitHubId) data Subscription = Free | Invoice deriving (Eq, Data, Typeable, Ord, Generic, Show) +instance Web.FromForm Subscription where + fromForm f = case Web.parseUnique "user-subscription" f of + Right "Free" -> Right Free + Right x -> Left <| "could not parse form value: " <> x + Left x -> Left <| "could not parse form value: " <> x + instance Aeson.ToJSON Subscription instance Aeson.FromJSON Subscription @@ -289,8 +296,13 @@ createAnalysis a = do } return newAnalysis -getAnalyses :: Acid.Query Keep [Analysis] -getAnalyses = do +getAnalysisById :: Id.Id Analysis -> Acid.Query Keep (Maybe Analysis) +getAnalysisById id = do + Keep {..} <- ask + return <| IxSet.getOne <| analyses @= id + +getAllAnalyses :: Acid.Query Keep [Analysis] +getAllAnalyses = do Keep {..} <- ask return <| IxSet.toList analyses @@ -302,7 +314,7 @@ getAnalysesByAsker user = do getAnalysisByUrlAndCommit :: URL -> Commit -> Acid.Query Keep (Maybe Analysis) getAnalysisByUrlAndCommit url sha = do Keep {..} <- ask - return <| IxSet.getOne <| (analyses @= url &&& analyses @= sha) + return <| IxSet.getOne <| analyses @= url &&& analyses @= sha $( makeAcidic ''Keep @@ -311,7 +323,8 @@ $( makeAcidic 'getUsers, 'getUserByEmail, 'createAnalysis, - 'getAnalyses, + 'getAnalysisById, + 'getAllAnalyses, 'getAnalysesByAsker, 'getAnalysisByUrlAndCommit ] @@ -547,17 +560,34 @@ data Paths path = Paths :> "github" :> "callback" :> QueryParam "code" Text - :> Get '[Lucid.HTML] (SetCookies (HtmlApp UserHome)), - account :: + :> Get '[Lucid.HTML] (SetCookies (HtmlApp UserAccount)), + getAccount :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "account" + :> Get '[Lucid.HTML] (HtmlApp UserAccount), + postAccount :: path :- Auth.Auth '[Auth.Cookie] User :> "account" - :> Get '[Lucid.HTML] (HtmlApp UserHome), + :> ReqBody '[FormUrlEncoded] Subscription + :> Post '[Lucid.HTML] (HtmlApp UserAccount), selectRepo :: path :- Auth.Auth '[Auth.Cookie] User :> "select-repo" :> Get '[Lucid.HTML] (HtmlApp SelectRepo), + getAnalyses :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "analysis" + :> Get '[Lucid.HTML] (HtmlApp Analyses), + getAnalysis :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "analysis" + :> Capture "analysisId" (Id.Id Analysis) + :> Get '[Lucid.HTML] (HtmlApp AnalysisDisplay), githubAnalysis :: path :- Auth.Auth '[Auth.Cookie] User @@ -595,13 +625,19 @@ htmlApp cooks kp cfg jwk oAuthArgs = login = pure <| addHeader (githubLoginUrl oAuthArgs) NoContent, githubAuth = auth kp cooks jwk oAuthArgs, - account = \case + getAccount = \case Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} Auth.BadPassword -> throwError err401 {errBody = "Bad password"} Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"} Auth.Authenticated user@User {..} -> do - analyses <- Acid.query' kp <| GetAnalysesByAsker user - pure <| HtmlApp <| UserHome user analyses, + pure <| HtmlApp <| UserAccount user, + postAccount = \case + Auth.NoSuchUser -> \_ -> throwError err401 {errBody = "No such user"} + Auth.BadPassword -> \_ -> throwError err401 {errBody = "Bad password"} + Auth.Indefinite -> \_ -> throwError err401 {errBody = "Incorrect authentication method"} + Auth.Authenticated user@User {..} -> \subscription -> do + newuser <- Acid.update' kp <| UpdateUser user {userSubscription = subscription} + pure <| HtmlApp <| UserAccount newuser, selectRepo = \case Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} Auth.BadPassword -> throwError err401 {errBody = "Bad password"} @@ -615,18 +651,32 @@ htmlApp cooks kp cfg jwk oAuthArgs = case erepos of Left err -> throwError err502 {errBody = show err} Right repos -> pure <. HtmlApp <| SelectRepo user repos, + getAnalyses = \case + Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} + Auth.BadPassword -> throwError err401 {errBody = "Bad password"} + Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"} + Auth.Authenticated user@User {..} -> do + analyses <- Acid.query' kp <| GetAnalysesByAsker user + pure <| HtmlApp <| Analyses user analyses, + getAnalysis = \case + Auth.NoSuchUser -> \_ -> throwError err401 {errBody = "No such user"} + Auth.BadPassword -> \_ -> throwError err401 {errBody = "Bad password"} + Auth.Indefinite -> \_ -> throwError err401 {errBody = "Incorrect authentication method"} + Auth.Authenticated user -> \analysisId -> + do + -- Acid.query' kp ( GetAnalysisById analysisId) >>= \case + GetAnalysisById analysisId + |> Acid.query' kp + >>= \case + Nothing -> panic "404" + Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis, githubAnalysis = \case - Auth.NoSuchUser -> panic "No such user" - Auth.BadPassword -> panic "Bad password" - Auth.Indefinite -> panic "Incorrect authentication method" + Auth.NoSuchUser -> \_ _ -> throwError err401 {errBody = "No such user"} + Auth.BadPassword -> \_ _ -> throwError err401 {errBody = "Bad password"} + Auth.Indefinite -> \_ _ -> throwError err401 {errBody = "Incorrect authentication method"} Auth.Authenticated user@User {..} -> \owner repo -> - liftIO - <| analyzeGitHub - kp - user - cfg - owner - repo + analyzeGitHub kp user cfg owner repo + |> liftIO >>= AnalysisDisplay user .> HtmlApp .> pure, @@ -780,42 +830,58 @@ instance Lucid.ToHtml Home where h1 = Lucid.h1_ h2 = Lucid.h2_ <. markdown -data UserHome = UserHome User [Analysis] +data Analyses = Analyses User [Analysis] + +instance Lucid.ToHtml Analyses where + toHtmlRaw = Lucid.toHtml + toHtml (Analyses user@User {..} analyses) = do + header <| Just user + Lucid.main_ <| do + Lucid.section_ <| do + Lucid.h2_ "Your Analyses" + Lucid.p_ + <| Lucid.a_ + [Lucid.linkHref_ "/" <| fieldLink selectRepo] + "Analyze one of your repos" + Lucid.div_ <| do + forM_ analyses <| \Analysis {..} -> + Lucid.a_ [href analysisId, style <| Biz.Look.marginAll (em 1)] <| do + Lucid.div_ <| Lucid.toHtml url + Lucid.div_ [style <| Clay.fontSizeCustom Clay.Font.small] + <| Lucid.toHtml commit + footer + where + href aid = Lucid.linkHref_ "/" <| fieldLink getAnalysis aid + +newtype UserAccount = UserAccount User instance Lucid.ToHtml Subscription where toHtmlRaw = Lucid.toHtml toHtml Free = "Free" toHtml Invoice = "Invoice me" -instance Lucid.ToHtml UserHome where +linkAction_ :: ToHttpApiData a => Text -> a -> Lucid.Attribute +linkAction_ baseUrl = Lucid.action_ <. (baseUrl <>) <. Servant.toUrlPiece + +instance Lucid.ToHtml UserAccount where toHtmlRaw = Lucid.toHtml - toHtml (UserHome user@User {..} analyses) = do + toHtml (UserAccount user@User {..}) = do header <| Just user Lucid.main_ <| do Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!" Lucid.section_ <| do Lucid.h2_ "Subscription" - Lucid.p_ <| do - "You are currently on the " - Lucid.strong_ <| Lucid.toHtml userSubscription - " plan." + let action = linkAction_ "/" <| fieldLink postAccount + Lucid.form_ [action, Lucid.method_ "post"] <| do + let name = "user-subscription" + Lucid.label_ [Lucid.for_ name] "Your plan:" + Lucid.select_ [Lucid.name_ name] <| do + Lucid.option_ [Lucid.value_ "Free"] <| Lucid.toHtml userSubscription + Lucid.input_ [Lucid.type_ "submit", Lucid.value_ "Save"] when (userSubscription == Invoice) <| do Lucid.p_ "You will received an invoice by email next month." - Lucid.section_ <| do - Lucid.h2_ "Your Analyses" - Lucid.div_ <| do - forM_ analyses <| \Analysis {..} -> - Lucid.a_ [{- href analysisId, -} style <| Biz.Look.marginAll (em 1)] <| do - Lucid.div_ <| Lucid.toHtml url - Lucid.div_ [style <| Clay.fontSizeCustom Clay.Font.small] - <| Lucid.toHtml commit - Lucid.p_ - <| Lucid.a_ - [Lucid.linkHref_ "/" <| fieldLink selectRepo] - "Analyze one of your repos" footer where - -- href aid = Lucid.linkHref_ "/" <| fieldLink analysis analysisId UserEmail email = userEmail style :: Clay.Css -> Lucid.Attribute @@ -837,7 +903,7 @@ auth :: JWK -> OAuthArgs -> Maybe Text -> - Handler (SetCookies (HtmlApp UserHome)) + Handler (SetCookies (HtmlApp UserAccount)) auth _ _ _ _ Nothing = panic "no code from github api" auth keep cooks jwt oAuthArgs (Just code) = do token <- liftIO <| getAccessToken oAuthArgs code @@ -847,11 +913,10 @@ auth keep cooks jwt oAuthArgs (Just code) = do Right user -> return user user <- liftIO <| upsertGitHubUser keep token ghUser mApplyCookies <- liftIO <| Auth.acceptLogin cooks (Auth.defaultJWTSettings jwt) user - analyses <- Acid.query' keep <| GetAnalysesByAsker user case mApplyCookies of Nothing -> panic "login didn't work" - -- I think this should redirect to instead of rendering UserHome - Just applyCookies -> return <. applyCookies <. HtmlApp <| UserHome user analyses + -- I think this should redirect to instead of rendering UserAccount + Just applyCookies -> return <. applyCookies <. HtmlApp <| UserAccount user -- | POST to GitHub's oAuth service and return the user's oAuth token. -- TODO: I can also get access scope etc from this response @@ -861,13 +926,14 @@ getAccessToken :: -- | This should be GitHub.Token but GitHub.Auth doesn't export Token. IO ByteString getAccessToken OAuthArgs {..} code = - accessTokenRequest - >>= Req.responseBody - /> access_token - /> Encoding.encodeUtf8 - /> return - |> Req.runReq Req.defaultHttpConfig + Req.runReq Req.defaultHttpConfig <| do + x <- accessTokenRequest + Req.responseBody x + |> access_token + |> Encoding.encodeUtf8 + |> return where + accessTokenRequest :: Req.Req (Req.JsonResponse OAuthResponse) accessTokenRequest = Req.req Req.POST @@ -922,7 +988,7 @@ encodeParams :: [(Text, Text)] -> Text encodeParams = Encoding.decodeUtf8 <. LBS.toStrict - <. Web.FormUrlEncoded.urlEncodeParams + <. Web.urlEncodeParams -- | Login button for GitHub. tryButton :: OAuthArgs -> Lucid.Html () @@ -945,7 +1011,9 @@ header muser = li "Login" <| fieldLink login li "Pricing" <| fieldLink home Just _ -> - Lucid.ul_ <. li "My Account" <| fieldLink account + Lucid.ul_ <| do + li "Analyses" <| fieldLink getAnalyses + li "Account" <| fieldLink getAccount where a txt href = Lucid.a_ [Lucid.linkHref_ "/" href] txt @@ -14,6 +14,7 @@ import Alpha import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Binary (Binary) import Data.Data (Data) +import Servant (FromHttpApiData (..), ToHttpApiData (..)) newtype Id entity = Id Int deriving (Eq, Ord, Show, Generic, Typeable, Data) @@ -47,3 +48,9 @@ instance Semigroup (Id entity) where instance Monoid (Id entity) where mempty = mk (Proxy :: Proxy entity) 0 + +instance FromHttpApiData (Id entity) where + parseUrlPiece p = mk (Proxy :: Proxy entity) </ parseUrlPiece p + +instance ToHttpApiData (Id entity) where + toUrlPiece p = untag p |> tshow diff --git a/Biz/Lint.hs b/Biz/Lint.hs index 8689308..66c7900 100644 --- a/Biz/Lint.hs +++ b/Biz/Lint.hs @@ -32,7 +32,7 @@ move args = case Cli.getAllArgs args (Cli.argument "file") of files -> files |> filter notcab - /> filterM Directory.doesFileExist + |> filterM Directory.doesFileExist >>= run >>= exit diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs index d50993c..cbf4bfd 100644 --- a/Biz/Que/Host.hs +++ b/Biz/Que/Host.hs @@ -166,10 +166,12 @@ routes cfg = do authkey <- fromMaybe "" </ Scotty.header "Authorization" (ns, qp) <- extract -- Only allow my IP or localhost to publish to '_' namespace - when ("_" == ns && authkey /= (Text.Lazy.strip <| queSkey cfg)) - <| Scotty.status Http.methodNotAllowed405 - >> Scotty.text "not allowed: _ is a reserved namespace" - >> Scotty.finish + when + ("_" == ns && authkey /= (Text.Lazy.strip <| queSkey cfg)) + ( Scotty.status Http.methodNotAllowed405 + >> Scotty.text "not allowed: _ is a reserved namespace" + >> Scotty.finish + ) guardNs ns ["pub", "_"] -- passed all auth checks app <. modify <| upsertNamespace ns diff --git a/Biz/Que/Site.hs b/Biz/Que/Site.hs index c2245d6..3e456da 100644 --- a/Biz/Que/Site.hs +++ b/Biz/Que/Site.hs @@ -111,11 +111,11 @@ run key ns Sources {..} = Async.runConcurrently actions |> void actions = traverse Async.Concurrently - [ forever <| toHtml index >>= serve key ns "index", - forever <| toHtml quescripts >>= serve key ns "quescripts", - forever <| BS.readFile client >>= serve key ns "client", - forever <| toHtml tutorial >>= serve key ns "tutorial", - forever <| toHtml apidocs >>= serve key ns "apidocs" + [ toHtml index >>= serve key ns "index" |> forever, + toHtml quescripts >>= serve key ns "quescripts" |> forever, + BS.readFile client >>= serve key ns "client" |> forever, + toHtml tutorial >>= serve key ns "tutorial" |> forever, + toHtml apidocs >>= serve key ns "apidocs" |> forever ] toHtml :: FilePath -> IO ByteString toHtml md = diff --git a/Biz/Test.hs b/Biz/Test.hs index db71831..85c405f 100644 --- a/Biz/Test.hs +++ b/Biz/Test.hs @@ -18,7 +18,6 @@ where import Alpha hiding (group) import qualified Test.Tasty as Tasty -import Test.Tasty.HUnit ((@=?), (@?=)) import qualified Test.Tasty.HUnit as HUnit import qualified Test.Tasty.QuickCheck as QuickCheck @@ -74,3 +73,13 @@ assertNotEqual preface notexpected actual = a -> HUnit.Assertion expected @?!= actual = assertNotEqual "" expected actual + +infixl 2 @?!= + +(@=?) :: (Eq a, Show a) => a -> a -> HUnit.Assertion +a @=? b = a HUnit.@=? b +infixl 2 @=? + +(@?=) :: (Eq a, Show a) => a -> a -> HUnit.Assertion +a @?= b = a HUnit.@?= b +infixr 2 @?= diff --git a/Hero/Node.hs b/Hero/Node.hs index 38f540d..e7eb687 100644 --- a/Hero/Node.hs +++ b/Hero/Node.hs @@ -53,7 +53,6 @@ import qualified Miso.FFI.Document as Document import qualified Miso.FFI.Fullscreen as Fullscreen import Miso.String import qualified Network.RemoteData as Network -import Protolude -- | Entry point for a miso application main :: IO () @@ -143,7 +142,7 @@ move (ToggleInLibrary c) form = form {user = newUser} <# pure NoOp newUser = (user form) {userLibrary = newLib} newLib | c `elem` (userLibrary <| user form) = - Protolude.filter (/= c) <| userLibrary <| user form + Alpha.filter (/= c) <| userLibrary <| user form | otherwise = c : (userLibrary <| user form) move (HandleURI u) form = form {uri = u} <# pure NoOp move (ChangeURI u) form = |