diff options
| -rw-r--r-- | Alpha.hs | 4 | ||||
| -rw-r--r-- | Biz/Bild.hs | 2 | ||||
| -rw-r--r-- | Biz/Devalloc.hs | 240 | ||||
| -rw-r--r-- | Biz/Id.hs | 7 | ||||
| -rw-r--r-- | Biz/Look.hs | 5 | ||||
| -rw-r--r-- | Biz/Test.hs | 45 |
6 files changed, 239 insertions, 64 deletions
@@ -45,6 +45,7 @@ module Alpha don't, -- * Text + tshow, chomp, lchomp, joinWith, @@ -189,3 +190,6 @@ wrap lim = Text.words .> wrap_ 0 .> Text.unwords | otherwise = w : wrap_ (pos + lw + 1) ws where lw = Text.length w + +tshow :: Show a => a -> Text +tshow = show diff --git a/Biz/Bild.hs b/Biz/Bild.hs index ab6f5bb..ed34009 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -149,7 +149,7 @@ main = Cli.main <| Cli.Plan help move test where test = Test.group "Biz.Bild" [Test.unit "id" <| 1 @=? (1 :: Integer)] move args = - IO.hSetBuffering stdout IO.NoBuffering + IO.hSetBuffering stdout IO.LineBuffering >> mapM getNamespace (Cli.getAllArgs args (Cli.argument "target")) /> catMaybes /> filter isBuildableNs diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 3836ef7..835d97b 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} @@ -55,16 +56,19 @@ 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 import Clay (em, pct, px, rem, sec, (?)) import qualified Clay +import qualified Clay.Font +import qualified Clay.Render as Clay import qualified Control.Exception as Exception import Crypto.JOSE.JWK (JWK) import Data.Acid (makeAcidic) import qualified Data.Acid as Acid +import qualified Data.Acid.Advanced as Acid import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as LBS import Data.Data (Data, Typeable) @@ -75,7 +79,8 @@ import Data.SafeCopy (base, deriveSafeCopy) import qualified Data.String as String import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding -import qualified Data.Time.Clock as Clock +import qualified Data.Time.Calendar as Time +import qualified Data.Time.Clock as Time import qualified Data.Time.Format as Time import Data.Vector (Vector) import qualified Data.Vector as Vector @@ -102,7 +107,10 @@ import qualified Web.FormUrlEncoded -- * persistent data --- this must go first because of template haskell splicing +-- This must go first because of template haskell splicing. +-- +-- When changing a persisted type T, first make `T0 == T`, then make the +-- `SafeCopy.Migrate T` class compile, then make changes to `T`. newtype UserEmail = UserEmail {unUserEmail :: Text} deriving (Eq, Ord, Data, Typeable, Generic, Show) @@ -132,12 +140,27 @@ instance Auth.FromJWT GitHubId $(deriveSafeCopy 0 'base ''GitHubId) +data Subscription = Free | Invoice + deriving (Eq, Data, Typeable, Ord, Generic, Show) + +instance Aeson.ToJSON Subscription + +instance Aeson.FromJSON Subscription + +instance Auth.ToJWT Subscription + +instance Auth.FromJWT Subscription + +$(deriveSafeCopy 0 'base ''Subscription) + -- | The main representation of a user. data User = User { userEmail :: UserEmail, userGitHubId :: GitHubId, -- | So we can make GitHub API calls on their behalf. - userGitHubToken :: Text + userGitHubToken :: Text, + userSubscription :: Subscription, + userId :: Id.Id User } deriving (Eq, Data, Typeable, Ord, Generic, Show) @@ -154,18 +177,27 @@ $(deriveSafeCopy 0 'base ''User) instance Indexable User where empty = ixSet - [ ixFun <| \u -> [userEmail u], - ixFun <| \u -> [userGitHubId u] + [ ixFun <| \User {..} -> [userEmail], + ixFun <| \User {..} -> [userGitHubId], + ixFun <| \User {..} -> [userSubscription] ] newtype Commit = Sha Text deriving (Eq, Data, Typeable, Ord, Generic, Show) +instance Lucid.ToHtml Commit where + toHtmlRaw = Lucid.toHtml + toHtml (Sha txt) = Lucid.toHtml txt + $(deriveSafeCopy 0 'base ''Commit) newtype URL = URL Text deriving (Eq, Data, Typeable, Ord, Generic, Show) +instance Lucid.ToHtml URL where + toHtmlRaw = Lucid.toHtml + toHtml (URL txt) = Lucid.toHtml txt + $(deriveSafeCopy 0 'base ''URL) -- | The result of analyzing a git repo. @@ -192,7 +224,7 @@ data Analysis = Analysis -- | Which commit this analysis was run against. commit :: Commit, -- | Who asked for this analysis - askedBy :: User + askedBy :: Id.Id User } deriving (Eq, Ord, Generic, Show, Data, Typeable) @@ -211,6 +243,7 @@ instance Indexable Analysis where -- | The database. data Keep = Keep { users :: IxSet User, + nextUserId :: Id.Id User, analyses :: IxSet Analysis, nextAnalysisId :: Id.Id Analysis } @@ -221,13 +254,18 @@ $(deriveSafeCopy 0 'base ''Keep) createUser :: User -> Acid.Update Keep User createUser u = do keep <- get - put <| keep {users = IxSet.insert u (users keep)} - return u + let newUser = u {userId = nextUserId keep} + put + <| keep + { users = IxSet.insert newUser (users keep), + nextUserId = succ <| nextUserId keep + } + return newUser updateUser :: User -> Acid.Update Keep User -updateUser u = do +updateUser u@User {..} = do keep <- get - put <| keep {users = IxSet.updateIx (userGitHubId u) u (users keep)} + put <| keep {users = IxSet.updateIx userGitHubId u (users keep)} return u getUserByEmail :: UserEmail -> Acid.Query Keep (Maybe User) @@ -235,22 +273,31 @@ getUserByEmail email = do Keep {..} <- ask return <| IxSet.getOne <| users @= email +getUsers :: Acid.Query Keep [User] +getUsers = do + Keep {..} <- ask + return <| IxSet.toList users + createAnalysis :: Analysis -> Acid.Update Keep Analysis createAnalysis a = do keep@Keep {..} <- get + let newAnalysis = a {analysisId = nextAnalysisId} put <| keep - { analyses = IxSet.insert a analyses, - nextAnalysisId = - succ - nextAnalysisId + { analyses = IxSet.insert newAnalysis analyses, + nextAnalysisId = succ nextAnalysisId } - return a + return newAnalysis + +getAnalyses :: Acid.Query Keep [Analysis] +getAnalyses = do + Keep {..} <- ask + return <| IxSet.toList analyses getAnalysesByAsker :: User -> Acid.Query Keep [Analysis] getAnalysesByAsker user = do Keep {..} <- ask - return <| IxSet.toList <| analyses @= user + return <| IxSet.toList <| analyses @= userId user getAnalysisByUrlAndCommit :: URL -> Commit -> Acid.Query Keep (Maybe Analysis) getAnalysisByUrlAndCommit url sha = do @@ -261,8 +308,10 @@ $( makeAcidic ''Keep [ 'createUser, 'updateUser, + 'getUsers, 'getUserByEmail, 'createAnalysis, + 'getAnalyses, 'getAnalysesByAsker, 'getAnalysisByUrlAndCommit ] @@ -270,7 +319,6 @@ $( makeAcidic upsertGitHubUser :: Acid.AcidState Keep -> ByteString -> GitHub.User -> IO User upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of - -- Nothing -> throwError err502 { errBody = "No user email" } Nothing -> panic "No user email" Just email -> Acid.query keep (GetUserByEmail <| UserEmail email) >>= \case @@ -283,13 +331,49 @@ upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of User { userEmail = UserEmail email, userGitHubId = GitHubId <. GitHub.untagId <| GitHub.userId ghUser, - userGitHubToken = Encoding.decodeUtf8 tok + userGitHubToken = Encoding.decodeUtf8 tok, + userSubscription = Free, + userId = mempty } +test_upsertGitHubUser :: IO (Config, Application, Acid.AcidState Keep) -> Test.Tree +test_upsertGitHubUser load = + Test.group + "upsertUser" + [ Test.unit "userId is not mempty" <| do + (_, _, k) <- load + User {..} <- upsertGitHubUser k "token" ghUser + userId @?!= mempty + ] + where + ghUser = + GitHub.User + { GitHub.userId = GitHub.mkId (Proxy :: Proxy GitHub.User) 123, + GitHub.userEmail = Just "user@example.com", + GitHub.userLogin = "example", + GitHub.userName = Nothing, + GitHub.userType = GitHub.OwnerUser, + GitHub.userCreatedAt = + Time.UTCTime (Time.ModifiedJulianDay 1) (Time.secondsToDiffTime 100), + GitHub.userPublicGists = 123, + GitHub.userAvatarUrl = GitHub.URL "http://example.com", + GitHub.userFollowers = 0, + GitHub.userFollowing = 0, + GitHub.userHireable = Nothing, + GitHub.userBlog = Nothing, + GitHub.userBio = Nothing, + GitHub.userPublicRepos = 0, + GitHub.userLocation = Nothing, + GitHub.userCompany = Nothing, + GitHub.userUrl = GitHub.URL "http://example.com", + GitHub.userHtmlUrl = GitHub.URL "http://example.com" + } + init :: Keep init = Keep { nextAnalysisId = Id.mk (Proxy :: Proxy Analysis) 1, + nextUserId = Id.mk (Proxy :: Proxy User) 1, users = IxSet.empty, analyses = IxSet.empty } @@ -311,29 +395,32 @@ Usage: move :: Cli.Arguments -> IO () move _ = Exception.bracket startup shutdown run - where - startup = do - cfg <- Envy.decodeWithDefaults Envy.defConfig - oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig - kp <- Acid.openLocalStateFrom (keep cfg) init :: IO (Acid.AcidState Keep) - jwk <- Auth.generateKey - putText "@" - putText "devalloc" - putText <| "area: " <> (show <| area cfg) - putText <| "port: " <> (show <| port cfg) - putText <| "depo: " <> (Text.pack <| depo cfg) - putText <| "keep: " <> (Text.pack <| keep cfg) - let jwtCfg = Auth.defaultJWTSettings jwk - let cooks = case area cfg of - Test -> testCookieSettings - Live -> liveCookieSettings - let ctx = cooks :. jwtCfg :. EmptyContext - let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs) - return (cfg, app, kp) - shutdown :: (Config, Application, Acid.AcidState Keep) -> IO () - shutdown (_, _, kp) = Acid.closeAcidState kp - run :: (Config, Wai.Application, Acid.AcidState Keep) -> IO () - run (cfg, app, _) = Warp.run (port cfg) (logStdout app) + +startup :: IO (Config, Application, Acid.AcidState Keep) +startup = do + cfg <- Envy.decodeWithDefaults Envy.defConfig + oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig + kp <- Acid.openLocalStateFrom (keep cfg) init :: IO (Acid.AcidState Keep) + jwk <- Auth.generateKey + putText "@" + putText "devalloc" + putText <| "area: " <> (show <| area cfg) + putText <| "port: " <> (show <| port cfg) + putText <| "depo: " <> (Text.pack <| depo cfg) + putText <| "keep: " <> (Text.pack <| keep cfg) + let jwtCfg = Auth.defaultJWTSettings jwk + let cooks = case area cfg of + Test -> testCookieSettings + Live -> liveCookieSettings + let ctx = cooks :. jwtCfg :. EmptyContext + let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs) + return (cfg, app, kp) + +shutdown :: (Config, Application, Acid.AcidState Keep) -> IO () +shutdown (_, _, kp) = Acid.closeAcidState kp + +run :: (Config, Wai.Application, Acid.AcidState Keep) -> IO () +run (cfg, app, _) = Warp.run (port cfg) (logStdout app) liveCookieSettings :: Auth.CookieSettings liveCookieSettings = @@ -354,7 +441,8 @@ test :: Test.Tree test = Test.group "Biz.Devalloc" - [ test_calculateScore + [ test_calculateScore, + Test.with startup shutdown test_upsertGitHubUser ] -- * app configurations @@ -511,16 +599,18 @@ htmlApp cooks kp cfg jwk oAuthArgs = 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 -> pure <| HtmlApp <| UserHome user, + Auth.Authenticated user@User {..} -> do + analyses <- Acid.query' kp <| GetAnalysesByAsker user + pure <| HtmlApp <| UserHome user analyses, selectRepo = \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 -> do + Auth.Authenticated user@User {..} -> do erepos <- liftIO <| GitHub.github - (GitHub.OAuth <. Encoding.encodeUtf8 <| userGitHubToken user) + (GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken) (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) case erepos of Left err -> throwError err502 {errBody = show err} @@ -529,7 +619,7 @@ htmlApp cooks kp cfg jwk oAuthArgs = Auth.NoSuchUser -> panic "No such user" Auth.BadPassword -> panic "Bad password" Auth.Indefinite -> panic "Incorrect authentication method" - Auth.Authenticated user -> \owner repo -> + Auth.Authenticated user@User {..} -> \owner repo -> liftIO <| analyzeGitHub kp @@ -605,7 +695,7 @@ htmlApp cooks kp cfg jwk oAuthArgs = Clay.textAlign Clay.center "h1" ? do Clay.fontSize (Clay.rem 3) - "h1, h2" ? do + "h1" <> "h2" ? do Clay.textAlign Clay.center "section" ? do Clay.padding (rem 3) 0 (rem 3) 0 @@ -690,21 +780,46 @@ instance Lucid.ToHtml Home where h1 = Lucid.h1_ h2 = Lucid.h2_ <. markdown -newtype UserHome = UserHome User +data UserHome = UserHome User [Analysis] + +instance Lucid.ToHtml Subscription where + toHtmlRaw = Lucid.toHtml + toHtml Free = "Free" + toHtml Invoice = "Invoice me" instance Lucid.ToHtml UserHome where toHtmlRaw = Lucid.toHtml - toHtml (UserHome user) = do + toHtml (UserHome user@User {..} analyses) = 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." + 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 - UserEmail email = userEmail user + -- href aid = Lucid.linkHref_ "/" <| fieldLink analysis analysisId + UserEmail email = userEmail + +style :: Clay.Css -> Lucid.Attribute +style = Lucid.style_ <. toStrict <. Clay.renderWith Clay.htmlInline [] -- | A type for parsing JSON auth responses, used in 'getAccessToken' below. -- Should be moved to Biz.Auth with others. @@ -732,9 +847,11 @@ 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" - Just applyCookies -> return <. applyCookies <. HtmlApp <| UserHome user + -- I think this should redirect to instead of rendering UserHome + Just applyCookies -> return <. applyCookies <. HtmlApp <| UserHome user analyses -- | POST to GitHub's oAuth service and return the user's oAuth token. -- TODO: I can also get access scope etc from this response @@ -873,12 +990,11 @@ instance Lucid.ToHtml Analysis where Lucid.ul_ <| do forM_ stale <| \(path, days) -> Lucid.li_ <| Lucid.toHtml <| path <> " (" <> show days <> " days)" - slen = Text.pack <. show <. length - tshow = Text.pack <. show + slen = tshow <. length -- | Takes a list of active authors and a path to a bare git repo and runs a -- regular analysis -analyze :: Acid.AcidState Keep -> User -> [Text] -> URL -> FilePath -> IO Analysis +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 @@ -919,7 +1035,7 @@ analyze keep askedBy activeAuthors url bareRepo = do Acid.update keep <| CreateAnalysis <| Analysis - { analysisId = Id.Id 0, -- make this mempty? + { analysisId = mempty, stale = [ (path, days) | (path, days) <- stalenessMap, @@ -964,7 +1080,7 @@ test_calculateScore = lastTouched :: FilePath -> FilePath -> IO (FilePath, Int) lastTouched bareRepo path = do - now <- Clock.getCurrentTime + now <- Time.getCurrentTime timestamp <- Process.readProcess "git" @@ -980,7 +1096,7 @@ lastTouched bareRepo path = do /> filter (/= '\n') -- TODO: this fails if time is empty? /> Time.parseTimeOrError True Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%z" - let days = round <| Clock.diffUTCTime now timestamp / Clock.nominalDay + let days = round <| Time.diffUTCTime now timestamp / Time.nominalDay return (path, days) -- | Given a git dir and a path inside the git repo, return a list of tuples @@ -1026,8 +1142,8 @@ analyzeGitHub :: -- | GitHub repo Text -> IO Analysis -analyzeGitHub keep user cfg o r = do - let githubAuth = GitHub.OAuth <. Encoding.encodeUtf8 <| userGitHubToken user +analyzeGitHub keep User {..} cfg o r = do + let githubAuth = GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken -- I currently have no way of getting active users... getting a list of -- collaborators on a repo requires authentication for some reason. -- @@ -1054,9 +1170,9 @@ analyzeGitHub keep user cfg o r = do case eRepo of Left err -> throwIO <| toException err Right repo -> do - let GitHub.URL url = GitHub.repoUrl repo + let GitHub.URL url = GitHub.repoHtmlUrl repo bareRepo <- fetchBareRepo cfg <. GitHub.getUrl <| GitHub.repoHtmlUrl repo - analyze keep user activeAuthors (URL url) bareRepo + analyze keep userId activeAuthors (URL url) bareRepo where ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r @@ -40,3 +40,10 @@ instance FromJSON (Id entity) where instance ToJSON (Id entity) where toJSON = toJSON <. untag + +-- this is just provided to satisfy Monoid, no reason to actually use it +instance Semigroup (Id entity) where + a <> b = mk (Proxy :: Proxy entity) <| untag a + untag b + +instance Monoid (Id entity) where + mempty = mk (Proxy :: Proxy entity) 0 diff --git a/Biz/Look.hs b/Biz/Look.hs index 27bc8c5..a6bb626 100644 --- a/Biz/Look.hs +++ b/Biz/Look.hs @@ -20,6 +20,8 @@ module Biz.Look textDecorationWidth, -- | Elements hoverButton, + -- | Geometry + marginAll, ) where @@ -120,3 +122,6 @@ textDecorationThickness = Clay.key "text-decoration-thickness" textDecorationWidth :: Size LengthUnit -> Css textDecorationWidth = Clay.key "text-decoration-width" + +marginAll :: Size a -> Css +marginAll x = Clay.margin x x x x diff --git a/Biz/Test.hs b/Biz/Test.hs index 7f6da61..7571008 100644 --- a/Biz/Test.hs +++ b/Biz/Test.hs @@ -8,12 +8,16 @@ module Biz.Test group, unit, prop, + with, (@=?), + (@?=), + (@?!=), ) where +import Alpha hiding (group) import qualified Test.Tasty as Tasty -import Test.Tasty.HUnit ((@=?)) +import Test.Tasty.HUnit ((@=?), (@?=)) import qualified Test.Tasty.HUnit as HUnit import qualified Test.Tasty.QuickCheck as QuickCheck @@ -27,3 +31,42 @@ unit = HUnit.testCase prop :: QuickCheck.Testable a => Tasty.TestName -> a -> Tasty.TestTree prop = QuickCheck.testProperty + +with :: + -- | Startup + IO a -> + -- | Shutdown + (a -> IO ()) -> + -- | A test group where the first argument is a function that gets the resource + (IO a -> Tree) -> + Tree +with = Tasty.withResource + +-- | How is this not part of HUnit?? +assertNotEqual :: + (Eq a, Show a, HasCallStack) => + -- | The message prefix + String -> + -- | The not-expected value + a -> + -- | The actual value + a -> + HUnit.Assertion +assertNotEqual preface notexpected actual = + unless (actual /= notexpected) (HUnit.assertFailure msg) + where + msg = + (if null preface then "" else preface ++ "\n") + ++ "expected not: " + ++ show notexpected + ++ "\n but got: " + ++ show actual + +(@?!=) :: + (Eq a, Show a, HasCallStack) => + -- | The not-expected value + a -> + -- | The actual value + a -> + HUnit.Assertion +expected @?!= actual = assertNotEqual "" expected actual |