diff options
Diffstat (limited to 'Biz/Devalloc.hs')
| -rw-r--r-- | Biz/Devalloc.hs | 176 |
1 files changed, 122 insertions, 54 deletions
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 |