Servant:hoist-server-with-context

 

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Log where

import Prelude ()
import Prelude.Compat

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader
import Data.Aeson
import Data.Default
import Data.Proxy
import Data.Text
import Data.Time.Clock ( UTCTime, getCurrentTime )
import GHC.Generics
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp as Warp
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.RequestLogger.JSON
import Servant as S
import Servant.Auth as SA
import Servant.Auth.Server as SAS
import System.Log.FastLogger                      ( ToLogStr(..)
                                                  , LoggerSet
                                                  , defaultBufSize
                                                  , newStdoutLoggerSet
                                                  , flushLogStr
                                                  , pushLogStrLn )


port :: Int
port = 3001



type AppM = ReaderT AppCtx Handler

data AppCtx = AppCtx {
  _getConfig   :: SiteConfig
  , _getLogger :: LoggerSet
  }

data SiteConfig = SiteConfig {
  environment     :: !Text
  , version       :: !Text
  , adminUsername :: !Text
  , adminPasswd   :: !Text
} deriving (Generic, Show)



data LogMessage = LogMessage {
  message        :: !Text
  , timestamp    :: !UTCTime
  , level        :: !Text
  , lversion     :: !Text
  , lenvironment :: !Text
} deriving (Eq, Show, Generic)

instance FromJSON LogMessage
instance ToJSON LogMessage where
  toEncoding = genericToEncoding defaultOptions

instance ToLogStr LogMessage where
  toLogStr = toLogStr . encode


data AdminUser = AdminUser { name :: Text }
   deriving (Eq, Show, Read, Generic)


instance ToJSON AdminUser
instance FromJSON AdminUser
instance SAS.ToJWT AdminUser
instance SAS.FromJWT AdminUser


type AdminApi =
    "admin" :> Get '[JSON] LogMessage
  
type LoginApi =
  "login"
      :> ReqBody '[JSON] LoginForm
      :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] LogMessage)

data LoginForm = LoginForm {
  username :: Text
  , password :: Text
} deriving (Eq, Show, Generic)

instance ToJSON LoginForm
instance FromJSON LoginForm
type AdminAndLogin auths = (SAS.Auth auths AdminUser :> AdminApi) :<|> LoginApi


adminServer :: SAS.CookieSettings -> SAS.JWTSettings -> ServerT (AdminAndLogin auths) AppM
adminServer cs jwts = adminHandler :<|> loginHandler cs jwts

adminHandler :: AuthResult AdminUser -> AppM LogMessage
adminHandler (SAS.Authenticated adminUser) = do
    config <- asks _getConfig
    logset <- asks _getLogger

    tstamp <- liftIO getCurrentTime
    let logMsg = LogMessage { message = "Admin User accessing admin: " <> name adminUser
                            , timestamp = tstamp
                            , level = "info"
                            , lversion = version config
                            , lenvironment = environment config
                            }
    -- emit log message
    liftIO $ pushLogStrLn logset $ toLogStr logMsg
    -- return handler result (for simplicity, result is a LogMessage)
    pure logMsg
adminHandler _ = throwError err401


loginHandler :: CookieSettings
             -> JWTSettings
             -> LoginForm
             -> AppM (Headers '[ Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] LogMessage)
loginHandler cookieSettings jwtSettings form = do
  config     <- asks _getConfig
  logset     <- asks _getLogger

  tstamp <- liftIO getCurrentTime
  let logMsg = LogMessage { message = "AdminUser login attempt failed!"
                          , timestamp = tstamp
                          , level = "info"
                          , lversion = version config
                          , lenvironment = environment config
                          }
  case validateLogin config form of
    Nothing -> do
      liftIO $ pushLogStrLn logset $ toLogStr logMsg
      throwError err401
    Just usr -> do
      mApplyCookies <- liftIO $ SAS.acceptLogin cookieSettings jwtSettings usr
      case mApplyCookies of
        Nothing           -> do
          liftIO $ pushLogStrLn logset $ toLogStr logMsg
          throwError err401
        Just applyCookies -> do
          let successMsg = logMsg{message = "AdminUser succesfully authenticated!"}
          liftIO $ pushLogStrLn logset $ toLogStr successMsg
          pure $ applyCookies successMsg
loginHandler _ _ _ = throwError err401

validateLogin :: SiteConfig -> LoginForm -> Maybe AdminUser
validateLogin config (LoginForm uname passwd ) =
  if (uname == adminUsername config) && (passwd == adminPasswd config)
    then Just $ AdminUser uname
    else Nothing



adminLoginApi :: Proxy (AdminAndLogin '[JWT])
adminLoginApi = Proxy

mkApp :: Context '[SAS.CookieSettings, SAS.JWTSettings] -> CookieSettings -> JWTSettings -> AppCtx -> Application
mkApp cfg cs jwts ctx =
  serveWithContext adminLoginApi cfg $
    hoistServerWithContext adminLoginApi (Proxy :: Proxy '[SAS.CookieSettings, SAS.JWTSettings])
      (flip runReaderT ctx) (adminServer cs jwts)


jsonRequestLogger :: IO Middleware
jsonRequestLogger =
  mkRequestLogger $ def { outputFormat = CustomOutputFormatWithDetails formatAsJSON }





main :: IO ()
main = do
  -- typically, we'd create our config from environment variables
  -- but we're going to just make one here
  let config = SiteConfig "dev" "1.0.0" "admin" "secretPassword"

  warpLogger <- jsonRequestLogger
  appLogger <- newStdoutLoggerSet defaultBufSize

  tstamp <- getCurrentTime
  myKey <- generateKey

  let lgmsg = LogMessage {
    message = "My app starting up!"
    , timestamp = tstamp
    , level = "info"
    , lversion = version config
    , lenvironment = environment config
  }
  pushLogStrLn appLogger (toLogStr lgmsg) >> flushLogStr appLogger

  let ctx = AppCtx config appLogger

      warpSettings = Warp.defaultSettings
      portSettings = Warp.setPort port warpSettings
      settings = Warp.setTimeout 55 portSettings
      jwtCfg = defaultJWTSettings myKey
      cookieCfg = if environment config == "dev"
                  then defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
                  else defaultCookieSettings
      cfg = cookieCfg :. jwtCfg :. EmptyContext

  Warp.runSettings settings $ warpLogger $ mkApp cfg cookieCfg jwtCfg ctx

https://haskell-servant.readthedocs.io/en/stable/cookbook/hoist-server-with-context/HoistServerWithContext.html