devalloc: initialize keep database

1 files changed, 103 insertions, 26 deletions

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index 7dbc4a5..38976c1 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -1,11 +1,13 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE NoImplicitPrelude #-}
@@ -14,14 +16,17 @@
 -- Developer allocation
 --
 -- : out devalloc
+-- : dep acid-state
 -- : dep clay
 -- dep cmark
 -- sys cmark
 -- : dep envy
 -- : dep github
+-- : dep ixset
 -- : dep lucid
 -- : dep protolude
 -- : dep req
+-- : dep safe-copy
 -- : dep servant
 -- : dep servant-lucid
 -- : dep servant-server
@@ -39,9 +44,15 @@ import Biz.App (CSS (..), HtmlApp (..))
 import qualified Biz.Look
 import qualified Clay
 import qualified Control.Exception as Exception
+import Data.Acid (makeAcidic)
+import qualified Data.Acid as Acid
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy as LBS
+import Data.Data (Data, Typeable)
+import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet, (@=))
+import qualified Data.IxSet as IxSet
 import qualified Data.List as List
+import Data.SafeCopy (base, deriveSafeCopy)
 import qualified Data.String as String
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Encoding
@@ -68,29 +79,84 @@ import System.FilePath ((<.>), (</>))
 import qualified System.Process as Process
 import qualified Web.FormUrlEncoded
 
+-- * persistent data
+
+-- this must go first because of template haskell splicing
+
+newtype UserEmail = UserEmail {unUserEmail :: Text}
+  deriving (Eq, Ord, Data, Typeable)
+
+$(deriveSafeCopy 0 'base ''UserEmail)
+
+data User = User
+  { userEmail :: UserEmail,
+    userGitHubToken :: Text
+  }
+  deriving (Eq, Data, Typeable, Ord)
+
+$(deriveSafeCopy 0 'base ''User)
+
+instance Indexable User where
+  empty =
+    ixSet
+      [ ixFun <| \u -> [userEmail u]
+      ]
+
+-- | The database.
+newtype Keep = Keep {users :: IxSet User}
+  deriving (Data, Typeable)
+
+instance Semigroup Keep where
+  a <> b = Keep <| users a <> users b
+
+instance Monoid Keep where
+  mempty = Keep <| mempty []
+
+$(deriveSafeCopy 0 'base ''Keep)
+
+newUser :: User -> Acid.Update Keep User
+newUser u = do
+  keep <- get
+  put <| keep {users = IxSet.insert u (users keep)}
+  return u
+
+getUserByEmail :: Text -> Acid.Query Keep (Maybe User)
+getUserByEmail email = do
+  Keep {..} <- ask
+  return <| IxSet.getOne <| users @= email
+
+$(makeAcidic ''Keep ['newUser, 'getUserByEmail])
+
+-- * main and test
+
 main :: IO ()
 main = Exception.bracket startup shutdown run
   where
     startup = do
       cfg <- Envy.decodeWithDefaults Envy.defConfig
       oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig
+      kp <- Acid.openLocalStateFrom (keep cfg) mempty :: IO (Acid.AcidState Keep)
       putText "@"
       putText "devalloc"
       putText <| "port: " <> (show <| port cfg)
       putText <| "depo: " <> (Text.pack <| depo cfg)
-      return (cfg, serve paths (toServant <| htmlApp cfg oAuthArgs))
-    shutdown :: (Config, Application) -> IO ()
-    shutdown _ = pure ()
-    run :: (Config, Wai.Application) -> IO ()
-    run (cfg, app) = Warp.run (port cfg) (logStdout app)
+      putText <| "keep: " <> (Text.pack <| keep cfg)
+      return (cfg, serve paths (toServant <| htmlApp kp cfg oAuthArgs), 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)
 
 test :: IO Analysis
 test = test_analyzeGitHub
 
+-- * app configurations
+
 data Config = Config
   { port :: Warp.Port,
     -- | The repo depo! Depository of repositories!
-    depo :: FilePath
+    depo :: FilePath,
+    keep :: FilePath
   }
   deriving (Generic, Show)
 
@@ -98,7 +164,8 @@ instance Envy.DefConfig Config where
   defConfig =
     Config
       { port = 8005,
-        depo = "_/var/devalloc/depo"
+        depo = "_/var/devalloc/depo",
+        keep = "_/var/devalloc/keep"
       }
 
 instance Envy.FromEnv Config
@@ -122,6 +189,8 @@ instance Envy.DefConfig OAuthArgs where
 
 instance Envy.FromEnv OAuthArgs
 
+-- * paths and pages
+
 -- | Wraps pages in default HTML
 instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
   toHtmlRaw = Lucid.toHtml
@@ -148,8 +217,7 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
             Lucid.href_ _href
           ]
 
--- * paths and pages
-
+-- | All of the routes in the app.
 data Paths path = Paths
   { home :: path :- Get '[HTML] (HtmlApp Home),
     githubAuth ::
@@ -169,11 +237,11 @@ paths :: Proxy (ToServantApi Paths)
 paths = genericApi (Proxy :: Proxy Paths)
 
 -- | Main HTML handlers for all paths.
-htmlApp :: Config -> OAuthArgs -> Paths AsServer
-htmlApp cfg oAuthArgs =
+htmlApp :: Acid.AcidState Keep -> Config -> OAuthArgs -> Paths AsServer
+htmlApp kp cfg oAuthArgs =
   Paths
     { home = page (Home oAuthArgs),
-      githubAuth = auth oAuthArgs,
+      githubAuth = auth kp oAuthArgs,
       githubAnalysis = \user repo ->
         liftIO <| analyzeGitHub cfg user repo >>= HtmlApp .> pure,
       css = look
@@ -229,25 +297,28 @@ data OAuthResponse = OAuthResponse
   }
   deriving (Generic, Aeson.FromJSON)
 
-auth :: OAuthArgs -> Maybe Text -> Handler (HtmlApp SelectRepo)
-auth _ Nothing = panic "no code from github api"
-auth OAuthArgs {..} (Just code) =
-  liftIO <| getAccessToken
+-- | Login a user by authenticating with GitHub.
+auth ::
+  Acid.AcidState Keep ->
+  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
+getAccessToken OAuthArgs {..} code =
+  accessTokenRequest
+    >>= Req.responseBody
+    /> access_token
+    /> return
+    |> Req.runReq Req.defaultHttpConfig
   where
-    getRepos oAuthToken =
-      GitHub.github
-        (GitHub.OAuth <| Encoding.encodeUtf8 oAuthToken)
-        (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll)
-    getAccessToken =
-      accessTokenRequest
-        >>= Req.responseBody
-        /> access_token
-        /> return
-        |> Req.runReq Req.defaultHttpConfig
     accessTokenRequest =
       Req.req
         Req.POST
@@ -259,6 +330,12 @@ auth OAuthArgs {..} (Just 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)