hero: implement the basics of user logins

There's also a lot of refactoring/renaming in here, so the diff is really messy.
The overall problem is that I've only ever added code, I've never gone back and
reorganized/rearchitected stuff. So adding even small features is becoming an
enormous effort.

Anyway, this adds the basics of user auth. Next I need to add the auth checks
for every route that needs it, and make sure everything is back to working
correctly.

1 files changed, 121 insertions, 35 deletions

diff --git a/Hero/Server.hs b/Hero/Server.hs
index 97ce7a2..d179cd2 100644
--- a/Hero/Server.hs
+++ b/Hero/Server.hs
@@ -1,11 +1,17 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -27,6 +33,8 @@
 -- : dep protolude
 -- : dep safecopy
 -- : dep servant
+-- : dep servant-auth
+-- : dep servant-auth-server
 -- : dep servant-lucid
 -- : dep servant-server
 -- : dep split
@@ -38,13 +46,16 @@
 -- : dep wai-extra
 -- : dep wai-middleware-metrics
 -- : dep warp
+-- : dep x509
 module Hero.Server where
 
 import Alpha
-import Biz.App (CSS(..), Manifest(..))
+import Biz.App (CSS (..), Manifest (..))
 import qualified Clay
+import qualified Crypto.JOSE.JWK as Crypto
 import Data.Acid (AcidState)
 import qualified Data.Acid.Abstract as Acid
+import qualified Data.Aeson as Aeson
 import Data.Text (Text)
 import qualified Data.Text.Lazy as Lazy
 import Hero.App
@@ -61,6 +72,8 @@ import Network.Wai
 import Network.Wai.Application.Static
 import qualified Network.Wai.Handler.Warp as Warp
 import Servant
+import qualified Servant.Auth.Server as Auth
+import qualified System.Directory as Directory
 import qualified System.Envy as Envy
 import qualified System.Exit as Exit
 import qualified System.IO as IO
@@ -72,26 +85,55 @@ main = bracket startup shutdown run
     prn = IO.hPutStrLn IO.stderr
     startup = Envy.decodeEnv >>= \case
       Left e -> Exit.die e
-      Right cfg -> do
-        keep <- Keep.open (heroKeep cfg)
-        say "hero"
-        prn $ "port: " ++ show (heroPort cfg)
-        prn $ "beam: " ++ heroBeam cfg
-        prn $ "keep: " ++ heroKeep cfg
-        let waiapp = mkApp keep cfg
-        return (cfg, waiapp, keep)
+      Right cfg ->
+        do
+          keep <- Keep.open (heroKeep cfg)
+          skey <- upsertKey (heroSkey cfg)
+          say "hero"
+          prn $ "port: " ++ show (heroPort cfg)
+          prn $ "beam: " ++ heroBeam cfg
+          prn $ "keep: " ++ heroKeep cfg
+          prn $ "skey: " ++ heroSkey cfg
+          let jwts = Auth.defaultJWTSettings skey
+              cs = Auth.defaultCookieSettings
+              ctx = cs :. jwts :. EmptyContext
+              proxy = Proxy @(AllRoutes '[Auth.JWT])
+              static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam cfg
+              server =
+                static
+                  :<|> cssHandlers
+                  :<|> (return "hi")
+                  :<|> loginHookHandler cs jwts
+                  :<|> jsonHandlers keep
+                  :<|> publicHandlers
+                  :<|> pure heroManifest
+                  :<|> Tagged handle404
+          return
+            ( cfg,
+              serveWithContext
+                proxy
+                ctx
+                server,
+              keep
+            )
     shutdown :: App -> IO ()
     shutdown (_, _, keep) = do
       Keep.close keep
       return ()
 
+upsertKey :: FilePath -> IO Crypto.JWK
+upsertKey fp = Directory.doesFileExist fp >>= \exists ->
+  if exists
+    then Auth.readKey fp
+    else Auth.writeKey fp >> Auth.readKey fp
+
 -- This part is a little confusing. I have:
 --
 --   - 'App' which encapsulates the entire runtime state
 --   - 'Config' has stuff I can set at startup
 --   - 'HeroKeep' is the database and any other persistance
---   - 'mkApp' take the second two and makes a 'Wai.Application', should really be
---     called 'serve', and might need to be Servant's 'hoistServer' thing
+--   - the above are then put together in the 'startup' private function in
+--     `main` above
 --
 -- I'm sure this can be cleaned up with a monad stack of some sort, but I
 -- haven't the brain power to think through that. For now, just try and keep
@@ -104,29 +146,16 @@ data Config
   = Config
       { heroPort :: Warp.Port,
         heroBeam :: FilePath,
-        heroKeep :: FilePath
+        heroKeep :: FilePath,
+        heroSkey :: FilePath
       }
   deriving (Generic, Show)
 
 instance Envy.DefConfig Config where
-  defConfig = Config 3000 "_bild/Hero.Client/static" "_keep"
+  defConfig = Config 3000 "_bild/Hero.Client/static" "_keep" "/run/hero/skey"
 
 instance Envy.FromEnv Config
 
-mkApp :: AcidState Keep.HeroKeep -> Config -> Application
-mkApp keep cfg =
-  serve
-    (Proxy @AllRoutes)
-    ( static
-        :<|> cssHandlers
-        :<|> jsonHandlers keep
-        :<|> serverHandlers
-        :<|> pure heroManifest
-        :<|> Tagged handle404
-    )
-  where
-    static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam cfg
-
 -- | Convert client side routes into server-side web handlers
 type ServerRoutes = ToServerRoutes ClientRoutes Templated Action
 
@@ -138,10 +167,39 @@ cssHandlers :: Server CssRoute
 cssHandlers =
   return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main
 
-type AllRoutes =
+type Ping = "ping" :> Get '[JSON] Text
+
+type LoginHook =
+  "login-hook"
+    :> ReqBody '[JSON] LoginForm
+    :> Post '[JSON]
+         ( Headers
+             '[ Header "Set-Cookie" Auth.SetCookie,
+                Header "Set-Cookie" Auth.SetCookie
+              ]
+             User
+         )
+
+loginHookHandler ::
+  Auth.CookieSettings ->
+  Auth.JWTSettings ->
+  LoginForm ->
+  Handler
+    ( Headers
+        '[ Header "Set-Cookie" Auth.SetCookie,
+           Header "Set-Cookie" Auth.SetCookie
+         ]
+        User
+    )
+loginHookHandler cs jwts =
+  checkCreds cs jwts
+
+type AllRoutes auths =
   ("static" :> Raw)
     :<|> CssRoute
-    :<|> JsonApi
+    :<|> Ping
+    :<|> LoginHook
+    :<|> (Auth.Auth auths User :> JsonApi)
     :<|> ServerRoutes
     :<|> ("manifest.json" :> Get '[JSON] Manifest)
     :<|> Raw
@@ -231,7 +289,6 @@ instance L.ToHtml a => L.ToHtml (Templated a) where
           (L.link_ mempty)
           [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
 
-
 handle404 :: Application
 handle404 _ respond =
   respond
@@ -249,12 +306,15 @@ animateRef :: MisoString
 animateRef =
   "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css"
 
+-- TODO: if I remove this, then the login form (and probably other stuff) gets
+-- messed up. When I remove this, I need to also port the necessary CSS styles
+-- to make stuff look good.
 bulmaRef :: MisoString
 bulmaRef =
   "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css"
 
-serverHandlers :: Server ServerRoutes
-serverHandlers =
+publicHandlers :: Server ServerRoutes
+publicHandlers =
   homeHandler
     :<|> comicCoverHandler
     :<|> comicPageHandler
@@ -264,8 +324,35 @@ serverHandlers =
     :<|> discoverHandler
     :<|> chooseExperienceHandler
 
-jsonHandlers :: AcidState Keep.HeroKeep -> Server JsonApi
-jsonHandlers keep = Acid.query' keep $ Keep.GetComics 10
+
+instance Auth.ToJWT User
+
+instance Auth.FromJWT User
+
+checkCreds ::
+  Auth.CookieSettings ->
+  Auth.JWTSettings ->
+  LoginForm ->
+  Handler
+    ( Headers
+        '[ Header "Set-Cookie" Auth.SetCookie,
+           Header "Set-Cookie" Auth.SetCookie
+         ]
+        User
+    )
+checkCreds cookieSettings jwtSettings (LoginForm "ben@bsima.me" "test") = do
+  -- TODO: get this from keep
+  liftIO $ say "successful login"
+  let usr = User "ben@bsima.me" "ben" [] -- TODO: load initial library
+  mApplyCookies <- liftIO $ Auth.acceptLogin cookieSettings jwtSettings usr
+  case mApplyCookies of
+    Nothing -> throwError err401
+    Just applyCookies -> return $ applyCookies usr
+checkCreds _ _ _ = throwError err401
+
+jsonHandlers :: AcidState Keep.HeroKeep -> Auth.AuthResult User -> Server JsonApi
+jsonHandlers keep (Auth.Authenticated user) = Acid.query' keep $ Keep.GetComics 10
+jsonHandlers _ _ = Auth.throwAll err401
 
 homeHandler :: Handler (Templated (View Action))
 homeHandler = pure . Templated . home $ initModel homeLink
@@ -295,4 +382,3 @@ chooseExperienceHandler id n =
 
 loginHandler :: Handler (Templated (View Action))
 loginHandler = pure . Templated . login $ initModel loginLink
-