Add cookies and store user tokens

Boy that was harder than I thought, but the code is pretty clean now. I still
need to fixup the error handling, and maybe move all the extra args into an app
monad, but I think otherwise I have it in a good place.

2 files changed, 225 insertions, 52 deletions

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index a4bfb8d..5e23e67 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -18,8 +18,6 @@
 -- : out devalloc
 -- : dep acid-state
 -- : dep clay
--- dep cmark
--- sys cmark
 -- : dep envy
 -- : dep github
 -- : dep ixset
@@ -28,6 +26,8 @@
 -- : dep req
 -- : dep safecopy
 -- : dep servant
+-- : dep servant-auth
+-- : dep servant-auth-server
 -- : dep servant-lucid
 -- : dep servant-server
 -- : dep uuid
@@ -44,6 +44,7 @@ import Biz.App (CSS (..), HtmlApp (..))
 import qualified Biz.Look
 import qualified 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.Aeson as Aeson
@@ -71,7 +72,9 @@ import qualified Network.Wai.Handler.Warp as Warp
 import Network.Wai.Middleware.RequestLogger (logStdout)
 import Servant
 import Servant.API.Generic (ToServantApi, genericApi, toServant, (:-))
-import Servant.HTML.Lucid
+import qualified Servant.Auth as Auth
+import qualified Servant.Auth.Server as Auth
+import qualified Servant.HTML.Lucid as Lucid
 import Servant.Server.Generic (AsServer)
 import qualified System.Directory as Directory
 import qualified System.Envy as Envy
@@ -84,22 +87,57 @@ import qualified Web.FormUrlEncoded
 -- this must go first because of template haskell splicing
 
 newtype UserEmail = UserEmail {unUserEmail :: Text}
-  deriving (Eq, Ord, Data, Typeable)
+  deriving (Eq, Ord, Data, Typeable, Generic, Show)
+
+instance Aeson.ToJSON UserEmail
+
+instance Aeson.FromJSON UserEmail
+
+instance Auth.ToJWT UserEmail
+
+instance Auth.FromJWT UserEmail
 
 $(deriveSafeCopy 0 'base ''UserEmail)
 
+-- | In 'GitHub.Data.Definitions' this is '(Id User)', but I don't want the
+-- extra complexity of 'Id', so just store the underlying Int
+newtype GitHubId = GitHubId {unGitHubId :: Int}
+  deriving (Eq, Ord, Data, Typeable, Generic, Show)
+
+instance Aeson.ToJSON GitHubId
+
+instance Aeson.FromJSON GitHubId
+
+instance Auth.ToJWT GitHubId
+
+instance Auth.FromJWT GitHubId
+
+$(deriveSafeCopy 0 'base ''GitHubId)
+
+-- | 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
   }
-  deriving (Eq, Data, Typeable, Ord)
+  deriving (Eq, Data, Typeable, Ord, Generic, Show)
+
+instance Aeson.ToJSON User
+
+instance Aeson.FromJSON User
+
+instance Auth.ToJWT User
+
+instance Auth.FromJWT User
 
 $(deriveSafeCopy 0 'base ''User)
 
 instance Indexable User where
   empty =
     ixSet
-      [ ixFun <| \u -> [userEmail u]
+      [ ixFun <| \u -> [userEmail u],
+        ixFun <| \u -> [userGitHubId u]
       ]
 
 -- | The database.
@@ -120,12 +158,36 @@ newUser u = do
   put <| keep {users = IxSet.insert u (users keep)}
   return u
 
-getUserByEmail :: Text -> Acid.Query Keep (Maybe User)
+updateUser :: User -> Acid.Update Keep User
+updateUser u = do
+  keep <- get
+  put <| keep {users = IxSet.updateIx (userGitHubId u) u (users keep)}
+  return u
+
+getUserByEmail :: UserEmail -> Acid.Query Keep (Maybe User)
 getUserByEmail email = do
   Keep {..} <- ask
   return <| IxSet.getOne <| users @= email
 
-$(makeAcidic ''Keep ['newUser, 'getUserByEmail])
+$(makeAcidic ''Keep ['newUser, 'updateUser, 'getUserByEmail])
+
+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
+      Just user ->
+        -- need to refresh the token
+        Acid.update keep <| UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok}
+      Nothing ->
+        Acid.update keep
+          <| NewUser
+            User
+              { userEmail = UserEmail email,
+                userGitHubId = GitHubId <. GitHub.untagId <| GitHub.userId ghUser,
+                userGitHubToken = Encoding.decodeUtf8 tok
+              }
 
 -- * main and test
 
@@ -136,27 +198,51 @@ main = Exception.bracket startup shutdown run
       cfg <- Envy.decodeWithDefaults Envy.defConfig
       oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig
       kp <- Acid.openLocalStateFrom (keep cfg) mempty :: IO (Acid.AcidState Keep)
+      jwk <- Auth.generateKey
       putText "@"
       putText "devalloc"
       putText <| "port: " <> (show <| port cfg)
       putText <| "depo: " <> (Text.pack <| depo cfg)
       putText <| "keep: " <> (Text.pack <| keep cfg)
-      return (cfg, serve paths (toServant <| htmlApp kp cfg oAuthArgs), kp)
+      let jwtCfg = Auth.defaultJWTSettings jwk
+      let cooks = case area cfg of
+            Test -> devCookieSettings
+            Live -> Auth.defaultCookieSettings
+      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)
 
+devCookieSettings :: Auth.CookieSettings
+devCookieSettings =
+  Auth.defaultCookieSettings
+    { Auth.cookieIsSecure = Auth.NotSecure,
+      Auth.cookieXsrfSetting = Nothing
+    }
+
 test :: IO Analysis
 test = test_analyzeGitHub
 
 -- * app configurations
 
+data Area = Test | Live
+  deriving (Generic, Show)
+
+instance Envy.Var Area where
+  toVar = show
+  fromVar "Test" = Just Test
+  fromVar "Live" = Just Live
+  fromVar _ = Just Test
+
 data Config = Config
   { port :: Warp.Port,
     -- | The repo depo! Depository of repositories!
     depo :: FilePath,
-    keep :: FilePath
+    keep :: FilePath,
+    area :: Area
   }
   deriving (Generic, Show)
 
@@ -165,7 +251,8 @@ instance Envy.DefConfig Config where
     Config
       { port = 8005,
         depo = "_/var/devalloc/depo",
-        keep = "_/var/devalloc/keep"
+        keep = "_/var/devalloc/keep",
+        area = Test
       }
 
 instance Envy.FromEnv Config
@@ -197,6 +284,15 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
   toHtml (HtmlApp x) =
     Lucid.doctypehtml_ <| do
       Lucid.head_ <| do
+        Lucid.title_ "Devalloc.io :: Know your codebase, know your team."
+        Lucid.meta_
+          [ Lucid.name_ "description",
+            Lucid.content_ "Know your codebase, know your team."
+          ]
+        Lucid.meta_
+          [ Lucid.name_ "viewport",
+            Lucid.content_ "width=device-width, initial-scale=1"
+          ]
         Lucid.meta_ [Lucid.charset_ "utf-8"]
         jsRef "//unpkg.com/turbolinks@5.2.0/dist/turbolinks.js"
         cssRef "/css/main.css"
@@ -219,39 +315,89 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
 
 -- | All of the routes in the app.
 data Paths path = Paths
-  { home :: path :- Get '[HTML] (HtmlApp Home),
+  { home ::
+      path
+        :- Get '[Lucid.HTML] (HtmlApp Home),
     githubAuth ::
-      path :- "auth" :> "github" :> "callback"
+      path
+        :- "auth"
+        :> "github"
+        :> "callback"
         :> QueryParam "code" Text
-        :> Get '[HTML] (HtmlApp SelectRepo),
+        :> Get '[Lucid.HTML] (SetCookies (HtmlApp UserHome)),
+    selectRepo ::
+      path
+        :- Auth.Auth '[Auth.Cookie] User
+        :> "select-repo"
+        :> Get '[Lucid.HTML] (HtmlApp SelectRepo),
     githubAnalysis ::
-      path :- "analysis" :> "github"
+      path
+        :- Auth.Auth '[Auth.Cookie] User
+        :> "analysis"
+        :> "github"
         :> Capture "user" Text
         :> Capture "repo" Text
-        :> Get '[HTML] (HtmlApp Analysis),
-    css :: path :- "css" :> "main.css" :> Get '[CSS] Text
+        :> Get '[Lucid.HTML] (HtmlApp Analysis),
+    css ::
+      path
+        :- "css"
+        :> "main.css"
+        :> Get '[CSS] Text
   }
   deriving (Generic)
 
+type SetCookies ret =
+  (Headers '[Header "Set-Cookie" Auth.SetCookie, Header "Set-Cookie" Auth.SetCookie] ret)
+
 paths :: Proxy (ToServantApi Paths)
 paths = genericApi (Proxy :: Proxy Paths)
 
 -- | Main HTML handlers for all paths.
-htmlApp :: Acid.AcidState Keep -> Config -> OAuthArgs -> Paths AsServer
-htmlApp kp cfg oAuthArgs =
+htmlApp ::
+  Auth.CookieSettings ->
+  Acid.AcidState Keep ->
+  Config ->
+  JWK ->
+  OAuthArgs ->
+  Paths AsServer
+htmlApp cooks kp cfg jwk oAuthArgs =
   Paths
-    { home = page (Home oAuthArgs),
-      githubAuth = auth kp oAuthArgs,
-      githubAnalysis = \user repo ->
-        liftIO <| analyzeGitHub cfg user repo >>= HtmlApp .> pure,
-      css = look
+    { home =
+        pure <. HtmlApp <| Home oAuthArgs,
+      githubAuth =
+        auth kp cooks jwk oAuthArgs,
+      -- TODO: guard on (AuthResult)
+      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
+          erepos <-
+            liftIO
+              <| GitHub.github
+                (GitHub.OAuth <. Encoding.encodeUtf8 <| userGitHubToken user)
+                (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll)
+          case erepos of
+            Left err -> throwError err502 {errBody = show err}
+            Right repos -> pure <. HtmlApp <| SelectRepo user repos,
+      githubAnalysis = \case
+        Auth.NoSuchUser -> panic "No such user"
+        Auth.BadPassword -> panic "Bad password"
+        Auth.Indefinite -> panic "Incorrect authentication method"
+        Auth.Authenticated user -> \owner repo ->
+          liftIO
+            <| analyzeGitHub
+              (GitHub.OAuth <. Encoding.encodeUtf8 <| userGitHubToken user)
+              cfg
+              owner
+              repo
+            >>= HtmlApp
+            .> pure,
+      css =
+        return <. toStrict <. Clay.render <| do
+          Biz.Look.fuckingStyle
+          "body" Clay.? Biz.Look.fontStack
     }
-  where
-    page = HtmlApp .> pure
-    look =
-      return <. toStrict <. Clay.render <| do
-        Biz.Look.fuckingStyle
-        "body" Clay.? Biz.Look.fontStack
 
 -- | The front page pitch. Eventually I'd like to load the content from markdown
 -- files or some other store of data so I can A/B test.
@@ -288,6 +434,19 @@ instance Lucid.ToHtml Home where
     Lucid.p_ "(Paid only)"
     Lucid.toHtml <| loginButton oAuthArgs
 
+newtype UserHome = UserHome User
+
+instance Lucid.ToHtml UserHome where
+  toHtmlRaw = Lucid.toHtml
+  toHtml (UserHome user) = do
+    Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!"
+    Lucid.p_
+      <| Lucid.a_
+        [Lucid.linkHref_ "/" <| fieldLink selectRepo]
+        "Analyze one of your repos"
+    where
+      UserEmail email = userEmail user
+
 -- | A type for parsing JSON auth responses, used in 'getAccessToken' below.
 -- Should be moved to Biz.Auth with others.
 data OAuthResponse = OAuthResponse
@@ -300,22 +459,36 @@ data OAuthResponse = OAuthResponse
 -- | Login a user by authenticating with GitHub.
 auth ::
   Acid.AcidState Keep ->
+  Auth.CookieSettings ->
+  JWK ->
   OAuthArgs ->
   Maybe Text ->
-  Handler (HtmlApp SelectRepo)
-auth _ _ Nothing = panic "no code from github api"
-auth _ oAuthArgs (Just code) =
-  liftIO <| getAccessToken oAuthArgs code
-    >>= getRepos
-    >>= \case
-      Left err -> panic <| show err
-      Right repos -> pure <. HtmlApp <| SelectRepo repos
-
-getAccessToken :: OAuthArgs -> Text -> IO Text
+  Handler (SetCookies (HtmlApp UserHome))
+auth _ _ _ _ Nothing = panic "no code from github api"
+auth keep cooks jwt oAuthArgs (Just code) = do
+  token <- liftIO <| getAccessToken oAuthArgs code
+  eghUser <- liftIO <| (GitHub.github (GitHub.OAuth token) GitHub.userInfoCurrentR :: IO (Either GitHub.Error GitHub.User))
+  ghUser <- case eghUser of
+    Left err -> throwError err502 {errBody = show err}
+    Right user -> return user
+  user <- liftIO <| upsertGitHubUser keep token ghUser
+  mApplyCookies <- liftIO <| Auth.acceptLogin cooks (Auth.defaultJWTSettings jwt) user
+  case mApplyCookies of
+    Nothing -> panic "login didn't work"
+    Just applyCookies -> return <. applyCookies <. HtmlApp <| UserHome user
+
+-- | POST to GitHub's oAuth service and return the user's oAuth token.
+-- TODO: I can also get access scope etc from this response
+getAccessToken ::
+  OAuthArgs ->
+  Text ->
+  -- | This should be GitHub.Token but GitHub.Auth doesn't export Token.
+  IO ByteString
 getAccessToken OAuthArgs {..} code =
   accessTokenRequest
     >>= Req.responseBody
     /> access_token
+    /> Encoding.encodeUtf8
     /> return
     |> Req.runReq Req.defaultHttpConfig
   where
@@ -330,19 +503,14 @@ getAccessToken OAuthArgs {..} code =
         <> "code" =: code
         <> "state" =: githubState
 
-getRepos :: Text -> IO (Either GitHub.Error (Vector GitHub.Repo))
-getRepos oAuthToken =
-  GitHub.github
-    (GitHub.OAuth <| Encoding.encodeUtf8 oAuthToken)
-    (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll)
-
 -- | This view presents a list of repos to select for analysis.
-newtype SelectRepo = SelectRepo (Vector GitHub.Repo)
+data SelectRepo = SelectRepo User (Vector GitHub.Repo)
 
 instance Lucid.ToHtml SelectRepo where
   toHtmlRaw = Lucid.toHtml
-  toHtml (SelectRepo repos) = do
-    Lucid.h1_ "Select a repo to analyze"
+  toHtml (SelectRepo user repos) = do
+    Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!"
+    Lucid.h2_ "Select a repo to analyze"
     Lucid.ul_ <| forM_ (Vector.toList repos) <| \repo ->
       Lucid.li_
         <. Lucid.a_
@@ -355,6 +523,8 @@ instance Lucid.ToHtml SelectRepo where
         <. Lucid.toHtml
         <. GitHub.untagName
         <| GitHub.repoName repo
+    where
+      UserEmail email = userEmail user
 
 -- * parts
 
@@ -534,13 +704,15 @@ authorsFor gitDir path =
 -- | Clones a repo from GitHub and does the analysis.
 -- TODO: break this up into fetchGitHub and analyze functions.
 analyzeGitHub ::
+  GitHub.AuthMethod authMethod =>
+  authMethod ->
   Config ->
   -- | GitHub owner
   Text ->
   -- | GitHub repo
   Text ->
   IO Analysis
-analyzeGitHub cfg o r = do
+analyzeGitHub githubAuth cfg o r = do
   -- I currently have no way of getting active users... getting a list of
   -- collaborators on a repo requires authentication for some reason.
   --
@@ -556,7 +728,7 @@ analyzeGitHub cfg o r = do
   -- Right activeUsers <- GitHub.github () (GitHub.collaboratorsOnR ghOwner ghRepo GitHub.FetchAll)
   Right user <-
     GitHub.github
-      ()
+      githubAuth
       ( GitHub.userInfoForR
           <| GitHub.mkName (Proxy :: Proxy GitHub.User) o
       )
@@ -571,7 +743,7 @@ analyzeGitHub cfg o r = do
     ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r
 
 test_analyzeGitHub :: IO Analysis
-test_analyzeGitHub = analyzeGitHub Envy.defConfig "bsima" "bin"
+test_analyzeGitHub = analyzeGitHub () Envy.defConfig "bsima" "bin"
 
 -- | Clone the repo to @<Config.depo>/<url>@. If repo already exists, just do a
 -- @git fetch@. Returns the full path to the local repo.
diff --git a/Biz/Devalloc.nix b/Biz/Devalloc.nix
index f994892..b7c7503 100644
--- a/Biz/Devalloc.nix
+++ b/Biz/Devalloc.nix
@@ -37,6 +37,7 @@ in
       serviceConfig = {
         Environment = [
           "PORT=${toString cfg.port}"
+          "AREA=Live"
         ];
         EnvironmentFile="/run/devalloc/env";
         KillSignal = "INT";