diff options
Diffstat (limited to 'Biz/Dragons.hs')
| -rw-r--r-- | Biz/Dragons.hs | 190 |
1 files changed, 145 insertions, 45 deletions
diff --git a/Biz/Dragons.hs b/Biz/Dragons.hs index e6b5368..8a2ad3f 100644 --- a/Biz/Dragons.hs +++ b/Biz/Dragons.hs @@ -20,7 +20,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- Developer allocation +-- Dragons.dev website and service -- -- : out dragons -- : sys cmark @@ -49,7 +49,6 @@ import qualified Clay.Font import qualified Clay.Render as Clay import qualified Control.Concurrent.Async as Async 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 @@ -70,7 +69,6 @@ import qualified Data.Time.Calendar as Time import qualified Data.Time.Clock as Time import Data.Vector (Vector) import qualified Data.Vector as Vector --- import qualified Data.Vector.Algorithms.Intro as Vector import qualified GitHub import qualified Lucid import qualified Lucid.Base as Lucid @@ -99,8 +97,9 @@ import qualified Web.FormUrlEncoded as Web -- don't, there will be a runtime exception when you try to start the new -- service. I'm not sure how to guard against this, except maybe run a test -- deployment by copying a database backup locally, or something: +-- -- rm -rf _/var/dragons --- rsync -avz /var/dragons/ _/var +-- rsync -avz /var/dragons _/var newtype UserEmail = UserEmail {unUserEmail :: Maybe Text} deriving (Eq, Ord, Data, Typeable, Generic, Show) @@ -164,9 +163,40 @@ instance Auth.FromJWT Subscription $(deriveSafeCopy 0 'base ''Subscription) +newtype Password = NotHashed ByteString -- not secure, yet + deriving (Data, Ord, Eq, Typeable, Generic, Show) + +instance Aeson.ToJSON Password where + toJSON (NotHashed bs) = Aeson.toJSON (str bs :: Text) + +-- toJSON (NotHashed bs) = str bs + +instance Aeson.FromJSON Password where + parseJSON = Aeson.withText "String" (str .> NotHashed .> pure) + +instance Lucid.ToHtml Password where + toHtmlRaw = Lucid.toHtml + toHtml (NotHashed txt) = Lucid.toHtml txt + +$(deriveSafeCopy 0 'base ''Password) + +data APIKey = APIKey + { -- | JWT token created with 'Servant.Auth.Server.makeJWT' + token :: Password, + created :: Time.UTCTime + } + deriving (Data, Ord, Eq, Typeable, Generic, Show) + +instance Aeson.ToJSON APIKey + +instance Aeson.FromJSON APIKey + +$(deriveSafeCopy 0 'base ''APIKey) + data User0 = User0 { userEmail :: UserEmail, userGitHubId :: GitHubId, + userGitHubHandle :: GitHubHandle, -- | So we can make GitHub API calls on their behalf. userGitHubToken :: Text, userSubscription :: Subscription, @@ -185,9 +215,10 @@ data User = User -- | So we can make GitHub API calls on their behalf. userGitHubToken :: Text, userSubscription :: Subscription, - userId :: Id.Id User + userId :: Id.Id User, + userKeys :: [APIKey] } - deriving (Eq, Data, Typeable, Ord, Generic, Show) + deriving (Data, Ord, Eq, Typeable, Generic, Show) instance Aeson.ToJSON User @@ -202,7 +233,7 @@ instance SafeCopy.Migrate User where migrate User0 {..} = User { userId = Id.mk (Proxy :: Proxy User) <| Id.untag userId, - userGitHubHandle = GitHubHandle "unknown", + userKeys = mempty, .. } @@ -222,18 +253,26 @@ instance Lucid.ToHtml Commit where $(deriveSafeCopy 0 'base ''Commit) -newtype URL = URL Text +data Source + = -- | We got this from a code forge like GitHub or GitLab + ForgeURL Text + | -- | We got this from a dragons-cli upload + CLISubmission deriving (Eq, Data, Typeable, Ord, Generic, Show) -instance Envy.Var URL where - toVar (URL txt) = str txt - fromVar = Just <. URL <. str +instance Envy.Var Source where + toVar (ForgeURL txt) = str txt + toVar CLISubmission = "dragons-cli upload" -instance Lucid.ToHtml URL where + -- NOTE: this assumes forge URL! + fromVar = Just <. ForgeURL <. str + +instance Lucid.ToHtml Source where toHtmlRaw = Lucid.toHtml - toHtml (URL txt) = Lucid.toHtml txt + toHtml (ForgeURL txt) = Lucid.toHtml txt + toHtml CLISubmission = Lucid.toHtml ("dragons-cli upload" :: Text) -$(deriveSafeCopy 0 'base ''URL) +$(deriveSafeCopy 0 'base ''Source) data Visibility = Public | Private deriving (Eq, Ord, Generic, Show, Data, Typeable) @@ -305,7 +344,7 @@ instance Lucid.ToHtml AnalysisAction where Lucid.div_ [Lucid.id_ "analysis"] <| do let Analysis {..} = analysis Lucid.p_ [Lucid.class_ "analysisFor"] <| do - "Analysis for " <> Lucid.toHtml url + "Analysis for " <> Lucid.toHtml source score_ <| do title_ "Total Score" @@ -468,7 +507,7 @@ data AnalysisAction = AnalysisAction -- | Who asked for this analysis askedBy :: Id.Id User, -- | Where is this coming from? - url :: URL, + source :: Source, -- | Is the URL publically visible? repoVisibility :: Visibility, -- | The actual analaysis @@ -484,7 +523,7 @@ instance Indexable AnalysisAction where ixSet [ ixFun <| \AnalysisAction {..} -> [analysisId], ixFun <| \AnalysisAction {..} -> [askedBy], - ixFun <| \AnalysisAction {..} -> [url], + ixFun <| \AnalysisAction {..} -> [source], ixFun <| \AnalysisAction {..} -> [repoVisibility], ixFun <| \AnalysisAction {..} -> [commit analysis] ] @@ -517,6 +556,13 @@ updateUser u@User {..} = do put <| keep {users = IxSet.updateIx userGitHubId u (users keep)} pure u +createUserAPIKey :: APIKey -> User -> Acid.Update Keep User +createUserAPIKey key u@User {..} = do + keep <- get + let newUser = u {userKeys = key : userKeys} + put <| keep {users = IxSet.updateIx userGitHubId newUser <| users keep} + pure newUser + getUserByEmail :: UserEmail -> Acid.Query Keep (Maybe User) getUserByEmail email = do Keep {..} <- ask @@ -558,15 +604,15 @@ getAnalysesByAsker User {..} = do Keep {..} <- ask pure <| IxSet.toList <| analyses @= userId -getAnalysesByUrl :: URL -> Acid.Query Keep [AnalysisAction] -getAnalysesByUrl url = do +getAnalysesBySource :: Source -> Acid.Query Keep [AnalysisAction] +getAnalysesBySource src = do Keep {..} <- ask - pure <| IxSet.toList <| analyses @= url + pure <| IxSet.toList <| analyses @= src -getAnalysisByUrlAndCommit :: URL -> Commit -> Acid.Query Keep (Maybe AnalysisAction) -getAnalysisByUrlAndCommit url sha = do +getAnalysisBySourceAndCommit :: Source -> Commit -> Acid.Query Keep (Maybe AnalysisAction) +getAnalysisBySourceAndCommit src sha = do Keep {..} <- ask - pure <| IxSet.getOne <| analyses @= url &&& analyses @= sha + pure <| IxSet.getOne <| analyses @= src &&& analyses @= sha $( makeAcidic ''Keep @@ -579,8 +625,9 @@ $( makeAcidic 'getAnalysisById, 'getAllAnalyses, 'getAnalysesByAsker, - 'getAnalysesByUrl, - 'getAnalysisByUrlAndCommit + 'getAnalysesBySource, + 'getAnalysisBySourceAndCommit, + 'createUserAPIKey ] ) @@ -610,7 +657,8 @@ upsertGitHubUser keep tok ghUser = GitHubHandle <| GitHub.untagName <| GitHub.userLogin ghUser, userGitHubToken = Encoding.decodeUtf8 tok, userSubscription = Free, - userId = mempty + userId = mempty, + userKeys = mempty } |> Acid.update keep /> Right @@ -689,8 +737,8 @@ startup quiet = do cfg <- Envy.decodeWithDefaults Envy.defConfig oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig kp <- Acid.openLocalStateFrom (keep cfg) init :: IO (Acid.AcidState Keep) - jwk <- Auth.generateKey - let URL url = homeExample cfg + jwk <- Auth.generateKey -- TODO: store this in a file somewhere + let ForgeURL url = homeExample cfg unless quiet <| do Log.info ["boot", "dragons"] >> Log.br Log.info ["boot", "area", show <| area cfg] >> Log.br @@ -703,7 +751,7 @@ startup quiet = do Test -> testCookieSettings Live -> liveCookieSettings let ctx = cooks :. jwtCfg :. EmptyContext - let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs) + let app = serveWithContext paths ctx (toServant <| htmlApp jwtCfg cooks kp cfg oAuthArgs) unless quiet <| do Log.info ["boot", "ready"] >> Log.br pure (cfg, app, kp) @@ -769,7 +817,7 @@ data Config = Config -- https://docs.github.com/en/github/authenticating-to-github/creating-a-personal-access-token tokn :: Text, -- | The example shown on the homepage - homeExample :: URL + homeExample :: Source } deriving (Generic, Show) @@ -781,7 +829,7 @@ instance Envy.DefConfig Config where keep = "_/var/dragons/keep", area = Test, tokn = mempty, - homeExample = URL "https://github.com/github/training-kit" + homeExample = ForgeURL "https://github.com/github/training-kit" } instance Envy.FromEnv Config @@ -854,6 +902,12 @@ data Paths path = Paths :> "account" :> ReqBody '[FormUrlEncoded] Subscription :> Post '[Lucid.HTML] (App.Html UserAccount), + postAPIKey :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "account" + :> "api-key" + :> Post '[Lucid.HTML] (App.Html UserAccount), selectRepo :: path :- Auth.Auth '[Auth.Cookie] User @@ -876,6 +930,12 @@ data Paths path = Paths :> "analysis" :> ReqBody '[FormUrlEncoded] SubmitAnalysis :> Post '[Lucid.HTML] (App.Html AnalysisDisplay), + putAnalysis :: + path + :- Auth.Auth '[Auth.JWT] User + :> "analysis" + :> ReqBody '[JSON] Analysis + :> Put '[JSON] NoContent, admin :: path :- Auth.Auth '[Auth.Cookie] User @@ -887,6 +947,8 @@ data Paths path = Paths paths :: Proxy (ToServantApi Paths) paths = genericApi (Proxy :: Proxy Paths) +-- | Ensures a user is authenticated, then returns the logged-in user for +-- authorization. guardAuth :: MonadError ServerError m => Auth.AuthResult a -> @@ -924,17 +986,17 @@ guardScope = -- | Main HTML handlers for all paths. htmlApp :: + Auth.JWTSettings -> Auth.CookieSettings -> Acid.AcidState Keep -> Config -> - JWK -> Auth.GitHub -> Paths AsServer -htmlApp cooks kp cfg jwk oAuthArgs = +htmlApp jwtCfg cooks kp cfg oAuthArgs = Paths { home = homeExample cfg - |> GetAnalysesByUrl + |> GetAnalysesBySource |> Acid.query' kp /> head /> Home oAuthArgs @@ -960,7 +1022,7 @@ htmlApp cooks kp cfg jwk oAuthArgs = +> upsertGitHubUser kp (Encoding.encodeUtf8 access_token) .> liftIO +> either warn pure - Auth.acceptLogin cooks (Auth.defaultJWTSettings jwk) user + Auth.acceptLogin cooks jwtCfg user |> liftIO +> \case Nothing -> throwError err502 {errBody = "login didn't work"} @@ -980,6 +1042,18 @@ htmlApp cooks kp cfg jwk oAuthArgs = +> UserAccount .> App.Html .> pure, + postAPIKey = + guardAuth >=> \user -> do + created <- liftIO <| Time.getCurrentTime + token <- + Auth.makeJWT user jwtCfg (Just created) + |> liftIO + +> \case + Left error -> throwError <| err500 {errBody = str <| (show error :: String)} + Right token -> pure <| NotHashed <| LBS.toStrict token + let apiKey = APIKey {..} + newUser <- Acid.update' kp (CreateUserAPIKey apiKey user) + pure <| App.Html <| UserAccount <| newUser, selectRepo = guardAuth >=> \user@User {..} -> @@ -1021,6 +1095,14 @@ htmlApp cooks kp cfg jwk oAuthArgs = +> AnalysisDisplay user .> App.Html .> pure, + putAnalysis = \a analysis -> + guardAuth a + +> \User {..} -> + AnalysisAction {analysisId = mempty, askedBy = userId, source = CLISubmission, repoVisibility = Private, ..} + |> CreateAnalysis + |> Acid.update kp + |> liftIO + >> pure NoContent, admin = guardAdmin >=> \user -> do @@ -1295,7 +1377,7 @@ instance Lucid.ToHtml Analyses where <> Clay.textDecoration Clay.none ] <| do - Lucid.div_ <| Lucid.toHtml url + Lucid.div_ <| Lucid.toHtml source Lucid.div_ [css <| Clay.fontSizeCustom Clay.Font.small] <| Lucid.toHtml (commit analysis) footer @@ -1305,7 +1387,12 @@ instance Lucid.ToHtml Analyses where newtype UserAccount = UserAccount User instance App.HasCss UserAccount where - cssFor (UserAccount _) = mempty + cssFor (UserAccount _) = do + "ul.apikeys" ? do + Clay.listStyleType Clay.none + Biz.Look.paddingAll (em 0) + "li" ? do + Clay.overflowX Clay.scroll instance Lucid.ToHtml Subscription where toHtmlRaw = Lucid.toHtml @@ -1337,6 +1424,16 @@ instance Lucid.ToHtml UserAccount where Lucid.input_ [Lucid.type_ "submit", Lucid.value_ "Save"] when (userSubscription == Invoice) <| do Lucid.p_ "Thanks! You will receive an invoice by email every month." + Lucid.section_ <| do + Lucid.h2_ "API Keys" + case userKeys of + [] -> Lucid.p_ "No keys yet!" + ks -> + Lucid.ul_ [Lucid.class_ "apikeys"] <| forM_ ks <| \APIKey {..} -> + Lucid.li_ <| Lucid.toHtml token + let action = linkAction_ "/" <| fieldLink postAPIKey + Lucid.form_ [action, Lucid.method_ "post"] <| do + Lucid.input_ [Lucid.type_ "submit", Lucid.value_ "Create"] footer where isSelected sel = @@ -1515,10 +1612,10 @@ instance Lucid.ToHtml AnalysisDisplay where footer -- | Run a full analysis on a git repo -analyze :: Acid.AcidState Keep -> Id.Id User -> [Text] -> URL -> FilePath -> Bool -> IO AnalysisAction -analyze keep askedBy activeAuthors url bareRepo repoPrivate = do +analyze :: Acid.AcidState Keep -> Id.Id User -> [Text] -> Source -> FilePath -> Bool -> IO AnalysisAction +analyze keep askedBy activeAuthors src bareRepo repoPrivate = do commit <- Sha </ Text.strip </ Text.pack </ Analysis.git bareRepo ["log", "-n1", "--format=%H"] - Acid.query keep (GetAnalysisByUrlAndCommit url commit) +> \case + Acid.query keep (GetAnalysisBySourceAndCommit src commit) +> \case Just analysis -> pure analysis Nothing -> Analysis.run activeAuthors bareRepo @@ -1527,6 +1624,7 @@ analyze keep askedBy activeAuthors url bareRepo repoPrivate = do { analysisId = mempty, analysis = a, repoVisibility = repoPrivate ?: (Private, Public), + source = src, .. } ) @@ -1555,7 +1653,8 @@ test_spliceCreds = userGitHubId = GitHubId 0, userGitHubToken = "token", userSubscription = Free, - userId = mempty + userId = mempty, + userKeys = mempty } -- | Clones a repo from GitHub and does the analysis. @@ -1589,7 +1688,7 @@ analyzeGitHub keep user@User {userId} ghAuth depo o r = do let cloningUrl = if GitHub.repoPrivate repo then spliceCreds user canonicalUrl else canonicalUrl let worktree = depo </> removeScheme canonicalUrl <.> "git" bareRepo <- fetchBareRepo cloningUrl worktree - analyze keep userId activeAuthors (URL canonicalUrl) bareRepo (GitHub.repoPrivate repo) + analyze keep userId activeAuthors (ForgeURL canonicalUrl) bareRepo (GitHub.repoPrivate repo) where ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r @@ -1636,7 +1735,7 @@ test_analyzeGitHub load = (depo c) "octocat" "hello-world" - url @?= URL "https://github.com/octocat/Hello-World" + source @?= ForgeURL "https://github.com/octocat/Hello-World" -- bareRepo @?= depo c <> "/github.com/octocat/Hello-World.git" let Analysis {..} = analysis length activeAuthors @?= 2 @@ -1658,7 +1757,7 @@ test_analyzeGitHub load = (depo c) "bsima" "biz" - url @?= URL "https://github.com/bsima/biz" + source @?= ForgeURL "https://github.com/bsima/biz" -- bareRepo @?= depo c <> "/github.com/bsima/biz.git" ] where @@ -1669,7 +1768,8 @@ test_analyzeGitHub load = userGitHubId = GitHubId 0, userGitHubToken = tokn c, userSubscription = Free, - userId = mempty + userId = mempty, + userKeys = mempty } -- | Clone the repo to @<Config.depo>/<url>@. If repo already exists, just do a |