diff options
Diffstat (limited to 'Biz/Devalloc.hs')
| -rw-r--r-- | Biz/Devalloc.hs | 156 |
1 files changed, 81 insertions, 75 deletions
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 245d94d..701e95a 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -66,6 +66,7 @@ import qualified Clay import qualified Clay.Font import qualified Clay.Render as Clay import qualified Control.Exception as Exception +import Control.Monad ((>=>)) import Crypto.JOSE.JWK (JWK) import Data.Acid (makeAcidic) import qualified Data.Acid as Acid @@ -267,23 +268,23 @@ createUser u = do { users = IxSet.insert newUser (users keep), nextUserId = succ <| nextUserId keep } - return newUser + pure newUser updateUser :: User -> Acid.Update Keep User updateUser u@User {..} = do keep <- get put <| keep {users = IxSet.updateIx userGitHubId u (users keep)} - return u + pure u getUserByEmail :: UserEmail -> Acid.Query Keep (Maybe User) getUserByEmail email = do Keep {..} <- ask - return <| IxSet.getOne <| users @= email + pure <| IxSet.getOne <| users @= email getUsers :: Acid.Query Keep [User] getUsers = do Keep {..} <- ask - return <| IxSet.toList users + pure <| IxSet.toList users createAnalysis :: Analysis -> Acid.Update Keep Analysis createAnalysis a = do @@ -294,27 +295,27 @@ createAnalysis a = do { analyses = IxSet.insert newAnalysis analyses, nextAnalysisId = succ nextAnalysisId } - return newAnalysis + pure newAnalysis getAnalysisById :: Id.Id Analysis -> Acid.Query Keep (Maybe Analysis) getAnalysisById id = do Keep {..} <- ask - return <| IxSet.getOne <| analyses @= id + pure <| IxSet.getOne <| analyses @= id getAllAnalyses :: Acid.Query Keep [Analysis] getAllAnalyses = do Keep {..} <- ask - return <| IxSet.toList analyses + pure <| IxSet.toList analyses getAnalysesByAsker :: User -> Acid.Query Keep [Analysis] getAnalysesByAsker user = do Keep {..} <- ask - return <| IxSet.toList <| analyses @= userId user + pure <| IxSet.toList <| analyses @= userId user getAnalysisByUrlAndCommit :: URL -> Commit -> Acid.Query Keep (Maybe Analysis) getAnalysisByUrlAndCommit url sha = do Keep {..} <- ask - return <| IxSet.getOne <| analyses @= url &&& analyses @= sha + pure <| IxSet.getOne <| analyses @= url &&& analyses @= sha $( makeAcidic ''Keep @@ -334,7 +335,7 @@ upsertGitHubUser :: Acid.AcidState Keep -> ByteString -> GitHub.User -> IO User upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of Nothing -> panic "No user email" Just email -> - Acid.query keep (GetUserByEmail <| UserEmail email) >>= \case + Acid.query keep (GetUserByEmail <| UserEmail email) +> \case Just user -> -- need to refresh the token Acid.update keep <| UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok} @@ -427,7 +428,7 @@ startup = do Live -> liveCookieSettings let ctx = cooks :. jwtCfg :. EmptyContext let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs) - return (cfg, app, kp) + pure (cfg, app, kp) shutdown :: (Config, Application, Acid.AcidState Keep) -> IO () shutdown (_, _, kp) = Acid.closeAcidState kp @@ -641,60 +642,65 @@ htmlApp cooks kp cfg jwk oAuthArgs = user <- GitHub.github (GitHub.OAuth token) GitHub.userInfoCurrentR |> liftIO - >>= \case + +> \case Left err -> throwError err502 {errBody = show err} Right ghUser -> liftIO <| upsertGitHubUser kp token ghUser Auth.acceptLogin cooks (Auth.defaultJWTSettings jwk) user |> liftIO - >>= \case + +> \case Nothing -> panic "login didn't work" -- I think this should redirect to instead of rendering UserAccount Just applyCookies -> UserAccount user |> HtmlApp |> applyCookies - |> return, - getAccount = \u -> - guardAuth u >>= UserAccount .> HtmlApp .> pure, + |> pure, + getAccount = + guardAuth >=> UserAccount .> HtmlApp .> pure, postAccount = \a subscription -> - guardAuth a >>= \user -> - UpdateUser user {userSubscription = subscription} - |> Acid.update' kp - >>= UserAccount - .> HtmlApp - .> pure, - selectRepo = \u -> - guardAuth u >>= \user@User {..} -> - GitHub.github - (GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken) - (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) - |> liftIO - >>= \case - Left err -> throwError err502 {errBody = show err} - Right repos -> pure <. HtmlApp <| SelectRepo user repos, - getAnalyses = \u -> - guardAuth u >>= \user@User {..} -> do - GetAnalysesByAsker user - |> Acid.query' kp - >>= Analyses user - .> HtmlApp - .> pure, + guardAuth a + +> \user -> + UpdateUser user {userSubscription = subscription} + |> Acid.update' kp + +> UserAccount + .> HtmlApp + .> pure, + selectRepo = + guardAuth + >=> \user@User {..} -> + GitHub.github + (GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken) + (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) + |> liftIO + +> \case + Left err -> throwError err502 {errBody = show err} + Right repos -> pure <. HtmlApp <| SelectRepo user repos, + getAnalyses = + guardAuth + >=> \user@User {..} -> + GetAnalysesByAsker user + |> Acid.query' kp + +> Analyses user + .> HtmlApp + .> pure, getAnalysis = \a analysisId -> - guardAuth a >>= \user -> - GetAnalysisById analysisId - |> Acid.query' kp - >>= \case - Nothing -> throwError err404 - Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis, + guardAuth a + +> \user -> + GetAnalysisById analysisId + |> Acid.query' kp + +> \case + Nothing -> throwError err404 + Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis, githubAnalysis = \a owner repo -> - guardAuth a >>= \user -> - analyzeGitHub kp user cfg owner repo - |> liftIO - >>= AnalysisDisplay user - .> HtmlApp - .> pure, + guardAuth a + +> \user -> + analyzeGitHub kp user cfg owner repo + |> liftIO + +> AnalysisDisplay user + .> HtmlApp + .> pure, css = - return <. toStrict <. Clay.render <| do + pure <. toStrict <. Clay.render <| do let yellow = "#ffe000" let black = "#1d2d35" -- really a dark blue Biz.Look.fuckingStyle @@ -909,7 +915,7 @@ data OAuthResponse = OAuthResponse } deriving (Generic, Aeson.FromJSON) --- | POST to GitHub's oAuth service and return the user's oAuth token. +-- | POST to GitHub's oAuth service and pure the user's oAuth token. -- TODO: I can also get access scope etc from this response getAccessToken :: OAuthArgs -> @@ -922,7 +928,7 @@ getAccessToken OAuthArgs {..} code = Req.responseBody x |> access_token |> Encoding.encodeUtf8 - |> return + |> pure where accessTokenRequest :: Req.Req (Req.JsonResponse OAuthResponse) accessTokenRequest = @@ -1056,8 +1062,8 @@ instance Lucid.ToHtml Analysis where analyze :: Acid.AcidState Keep -> Id.Id User -> [Text] -> URL -> FilePath -> IO Analysis analyze keep askedBy activeAuthors url bareRepo = do commit <- Sha </ Text.strip </ Text.pack </ git ["log", "-n1", "--format=%H"] - Acid.query keep (GetAnalysisByUrlAndCommit url commit) >>= \case - Just analysis -> return analysis + Acid.query keep (GetAnalysisByUrlAndCommit url commit) +> \case + Just analysis -> pure analysis Nothing -> do tree <- git @@ -1091,19 +1097,19 @@ analyze keep askedBy activeAuthors url bareRepo = do let numBlackholes = realToFrac <| length blackholes let numLiabilities = realToFrac <| length liabilities let numTotal = realToFrac <| length tree - Acid.update keep - <| CreateAnalysis - <| Analysis - { analysisId = mempty, - stale = - [ (path, days) - | (path, days) <- stalenessMap, - days > 180 - ], - score = calculateScore numTotal numBlackholes numLiabilities, - totalFiles = toInteger <| length tree, - .. - } + Analysis + { analysisId = mempty, + stale = + [ (path, days) + | (path, days) <- stalenessMap, + days > 180 + ], + score = calculateScore numTotal numBlackholes numLiabilities, + totalFiles = toInteger <| length tree, + .. + } + |> CreateAnalysis + |> Acid.update keep where third :: (a, b, c) -> c third (_, _, a) = a @@ -1156,14 +1162,14 @@ lastTouched bareRepo path = do -- TODO: this fails if time is empty? /> Time.parseTimeOrError True Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%z" let days = round <| Time.diffUTCTime now timestamp / Time.nominalDay - return (path, days) + pure (path, days) --- | Given a git dir and a path inside the git repo, return a list of tuples +-- | Given a git dir and a path inside the git repo, pure a list of tuples -- with number of commits and author. authorsFor :: FilePath -> FilePath -> - -- | Returns (number of commits, author name, author email) + -- | pures (number of commits, author name, author email) IO [(Text, Text, Text)] authorsFor gitDir path = Process.readProcess @@ -1207,7 +1213,7 @@ analyzeGitHub keep User {..} cfg o r = do -- collaborators on a repo requires authentication for some reason. -- -- If the owner is an organization, then we can just use org members, which is - -- public too. And if the auth'ed user is a member of the org, then it returns + -- public too. And if the auth'ed user is a member of the org, then it pures -- all of the members, not just public ones, so that will work just fine. -- -- In the meantime, what do? Maybe get the number of commits, and consider @@ -1237,12 +1243,12 @@ analyzeGitHub keep User {..} cfg o r = do ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r -- | Clone the repo to @<Config.depo>/<url>@. If repo already exists, just do a --- @git fetch@. Returns the full path to the local repo. +-- @git fetch@. pures the full path to the local repo. fetchBareRepo :: Config -> Text -> IO FilePath fetchBareRepo Config {depo} url = Directory.doesPathExist worktree - >>= fetchOrClone - >> return worktree + +> fetchOrClone + >> pure worktree where fetchOrClone True = Process.callProcess "git" ["--git-dir", worktree, "fetch", "origin"] |