Add simple API key feature to Dragons.dev

Still need to add this to the CLI, and there should be other features like
delete and so on, but this works for now.

4 files changed, 159 insertions, 49 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 26bf120..2eaf840 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -318,6 +318,8 @@ detectImports (Namespace _ Namespace.Hs) contentLines = do
   pure <| pkgs <> transitivePkgs
 detectImports _ _ = Exit.die "can only detectImports for Haskell"
 
+-- | TODO: globally cache analyses, so I'm not re-analyzing modules all the
+-- time. This is important as it would speed up building by a lot.
 analyze :: FilePath -> IO (Maybe Target)
 analyze path = do
   content <-
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
diff --git a/Biz/Dragons/Analysis.hs b/Biz/Dragons/Analysis.hs
index f1c1bbd..cfdbf2c 100644
--- a/Biz/Dragons/Analysis.hs
+++ b/Biz/Dragons/Analysis.hs
@@ -77,6 +77,8 @@ newtype Commit = Sha Text
 
 instance Aeson.ToJSON Commit
 
+instance Aeson.FromJSON Commit
+
 -- | The result of analyzing a git repo.
 data Analysis = Analysis
   { -- | Where the repo is stored on the local disk.
@@ -105,6 +107,8 @@ data Analysis = Analysis
 
 instance Aeson.ToJSON Analysis
 
+instance Aeson.FromJSON Analysis
+
 run :: [Text] -> FilePath -> IO Analysis
 run activeAuthors bareRepo = do
   commit <- git bareRepo ["rev-parse", "HEAD"] /> Text.pack /> chomp /> Sha
diff --git a/Biz/Log.hs b/Biz/Log.hs
index c74d297..c206dc9 100644
--- a/Biz/Log.hs
+++ b/Biz/Log.hs
@@ -8,14 +8,18 @@ module Biz.Log
     info,
     warn,
     fail,
-    -- Debugging
+
+    -- * Debugging
     mark,
-    -- Operators
+
+    -- * Operators
     (~&),
     (~?),
-    -- Wai Middleware
+
+    -- * Wai Middleware
     wai,
-    -- | Low-level
+
+    -- * Low-level
     msg,
     br,
   )