diff options
Diffstat (limited to 'Hero/Server.hs')
| -rw-r--r-- | Hero/Server.hs | 156 |
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 - |