diff options
Diffstat (limited to 'Biz')
| -rw-r--r-- | Biz/Bild.hs | 8 | ||||
| -rw-r--r-- | Biz/Cli.hs | 6 | ||||
| -rw-r--r-- | Biz/Devalloc.hs | 156 | ||||
| -rw-r--r-- | Biz/Lint.hs | 12 | ||||
| -rw-r--r-- | Biz/Namespace.hs | 4 | ||||
| -rw-r--r-- | Biz/Pie.hs | 12 | ||||
| -rw-r--r-- | Biz/Que/Host.hs | 8 | ||||
| -rw-r--r-- | Biz/Que/Site.hs | 16 | ||||
| -rw-r--r-- | Biz/Test.hs | 2 |
9 files changed, 116 insertions, 108 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 8a7de48..b621797 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -151,7 +151,7 @@ main = Cli.main <| Cli.Plan help move test "Biz.Bild" [ Test.unit "can bild bild" <| do let ns = Namespace ["Biz", "Bild"] Namespace.Hs - analyze ns >>= build False False >>= \case + analyze ns +> build False False +> \case Exit.ExitFailure _ -> Test.assertFailure "can't bild bild" _ -> pure () ] @@ -162,13 +162,13 @@ move args = >> mapM getNamespace (Cli.getAllArgs args (Cli.argument "target")) /> catMaybes /> filter isBuildableNs - >>= mapM analyze - >>= mapM + +> mapM analyze + +> mapM ( build (args `Cli.has` Cli.longOption "test") (args `Cli.has` Cli.longOption "loud") ) - >>= exitSummary + +> exitSummary help :: Cli.Docopt help = @@ -33,8 +33,8 @@ data Plan = Plan main :: Plan -> IO () main Plan {..} = Environment.getArgs - >>= Docopt.parseArgsOrExit help - >>= \args -> + +> Docopt.parseArgsOrExit help + +> \args -> if args `has` Docopt.command "test" then runTests test else @@ -49,7 +49,7 @@ runTests tree = do Nothing -> do hPutStrLn stderr <| Text.pack "no ingredients agreed to run" exitFailure - Just act -> act >>= \ok -> if ok then exitSuccess else exitFailure + Just act -> act +> \ok -> if ok then exitSuccess else exitFailure has :: Docopt.Arguments -> Docopt.Option -> Bool has = Docopt.isPresent 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"] diff --git a/Biz/Lint.hs b/Biz/Lint.hs index 66c7900..bd71835 100644 --- a/Biz/Lint.hs +++ b/Biz/Lint.hs @@ -28,13 +28,13 @@ main = Cli.main <| Cli.Plan help move test move :: Cli.Arguments -> IO () move args = case Cli.getAllArgs args (Cli.argument "file") of - [] -> changedFiles >>= run >>= exit + [] -> changedFiles +> run +> exit files -> files |> filter notcab |> filterM Directory.doesFileExist - >>= run - >>= exit + +> run + +> exit test :: Test.Tree test = @@ -83,7 +83,7 @@ printResult r@(NoOp path_) = >> pure r changedFiles :: IO [FilePath] -changedFiles = mergeBase >>= changed +changedFiles = mergeBase +> changed where git args = Process.readProcess "git" args "" mergeBase = git ["merge-base", "HEAD", "origin/master"] /> filter (/= '\n') @@ -109,7 +109,7 @@ run paths = do concat </ mapM (runOne root cwd) paths runOne :: FilePath -> FilePath -> FilePath -> IO [Result] -runOne root cwd path_ = results >>= mapM_ printResult >> results +runOne root cwd path_ = results +> mapM_ printResult >> results where results = sequence <| case Namespace.fromPath root (cwd </> path_) of @@ -128,7 +128,7 @@ runOne root cwd path_ = results >>= mapM_ printResult >> results lint :: Linter -> [String] -> FilePath -> IO Result lint bin args path_ = - Process.readProcessWithExitCode (Text.unpack bin) (args ++ [path_]) "" >>= \case + Process.readProcessWithExitCode (Text.unpack bin) (args ++ [path_]) "" +> \case (Exit.ExitSuccess, _, _) -> pure <| Ok path_ bin Good (Exit.ExitFailure _, msg, _) -> pure <| Ok path_ bin <| Bad msg diff --git a/Biz/Namespace.hs b/Biz/Namespace.hs index d3835c8..398841e 100644 --- a/Biz/Namespace.hs +++ b/Biz/Namespace.hs @@ -44,8 +44,8 @@ match = Regex.match <| Namespace </ path <* Regex.sym '.' <*> ext fromPath :: String -> String -> Maybe Namespace fromPath bizRoot absPath = List.stripPrefix bizRoot absPath - >>= List.stripPrefix "/" - >>= match + +> List.stripPrefix "/" + +> match toHaskellModule :: Namespace -> String toHaskellModule (Namespace parts Hs) = joinWith "." parts @@ -95,12 +95,12 @@ formFile ns = ns ++ ".pie" loadForm :: String -> IO Form loadForm ns = - Directory.doesFileExist file >>= \case - False -> return mempty + Directory.doesFileExist file +> \case + False -> pure mempty True -> - Aeson.decodeFileStrict file >>= \case + Aeson.decodeFileStrict file +> \case Nothing -> panic <| Text.pack <| "could not decode: " ++ file - Just x -> return x + Just x -> pure x where file = formFile ns @@ -126,10 +126,10 @@ fromArgs args move :: Cli.Arguments -> IO () move args = case fromArgs args of New -> do - week <- Time.getCurrentTime >>= return <. Time.formatTime Time.defaultTimeLocale "%V" + week <- Time.getCurrentTime +> pure <. Time.formatTime Time.defaultTimeLocale "%V" let branch = "sprint-" <> week proc <- Process.spawnProcess "git" ["show-ref", branch] - Process.waitForProcess proc >>= \case + Process.waitForProcess proc +> \case Exit.ExitSuccess -> Process.callProcess "git" ["switch", branch] Exit.ExitFailure _ -> diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs index cbf4bfd..e40b2e0 100644 --- a/Biz/Que/Host.hs +++ b/Biz/Que/Host.hs @@ -63,7 +63,7 @@ move :: Cli.Arguments -> IO () move _ = Exception.bracket startup shutdown <| uncurry Warp.run where startup = - Envy.decodeWithDefaults Envy.defConfig >>= \c -> do + Envy.decodeWithDefaults Envy.defConfig +> \c -> do sync <- STM.newTVarIO initialAppState let runActionToIO m = runReaderT (runApp m) sync waiapp <- Scotty.scottyAppT runActionToIO <| routes c @@ -207,7 +207,7 @@ streamQue q write _ = loop q where loop c = Go.read c - >>= (write <. Builder.byteStringInsert) + +> (write <. Builder.byteStringInsert) >> loop c -- | Gets the thing from the Hashmap. Call's 'error' if key doesn't exist. @@ -241,11 +241,11 @@ app = lift -- | Get something from the app state gets :: (AppState -> b) -> App b -gets f = ask >>= liftIO <. STM.readTVarIO >>= return </ f +gets f = ask +> liftIO <. STM.readTVarIO +> return </ f -- | Apply a function to the app state modify :: (AppState -> AppState) -> App () -modify f = ask >>= liftIO <. atomically <. flip STM.modifyTVar' f +modify f = ask +> liftIO <. atomically <. flip STM.modifyTVar' f -- | housing for a set of que paths type Namespace = Text.Lazy.Text diff --git a/Biz/Que/Site.hs b/Biz/Que/Site.hs index 3e456da..0d89400 100644 --- a/Biz/Que/Site.hs +++ b/Biz/Que/Site.hs @@ -83,7 +83,7 @@ getKey ns = do auth ns |> Config.parseIniFile conf |> either errorParsingConf identity - |> return + |> pure errorParsingConf :: error errorParsingConf = panic "could not parse ~/.config/que.conf" @@ -111,11 +111,11 @@ run key ns Sources {..} = Async.runConcurrently actions |> void actions = traverse Async.Concurrently - [ 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 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 = @@ -143,7 +143,7 @@ serve Nothing "pub" path content = (ReqBodyBs content) ignoreResponse mempty - liftIO <| return () + liftIO <| pure () serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p serve (Just key) ns path content = runReq defaultHttpConfig <| do @@ -156,4 +156,4 @@ serve (Just key) ns path content = (ReqBodyBs content) ignoreResponse options - liftIO <| return () + liftIO <| pure () diff --git a/Biz/Test.hs b/Biz/Test.hs index 85c405f..fdd89f8 100644 --- a/Biz/Test.hs +++ b/Biz/Test.hs @@ -78,8 +78,10 @@ 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 @?= |