espial-0.0.34: src/Foundation.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}

module Foundation where

import Archiver.Backend (ArchiverBackend)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE
import Data.Type.Equality (type (~))
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Import.NoFoundation
import qualified Network.Wai as Wai
import PathPiece ()
import Text.Hamlet (hamletFile)
import Yesod.Auth.Message
import Yesod.Core.Types
import qualified Yesod.Core.Unsafe as Unsafe

data App = App
  { appSettings :: AppSettings,
    -- | Settings for static file serving.
    appStatic :: Static,
    -- | Frontend ESM bundle filename under static/js.
    appFrontendBundleName :: Text,
    -- | Database connection pool.
    appConnPool :: ConnectionPool,
    appHttpManager :: Manager,
    appLogger :: Logger,
    -- | Active archiver plugin; 'Nothing' disables archiving.
    appArchiver :: Maybe ArchiverBackend
  }
  deriving (Typeable)

mkYesodData "App" $(parseRoutesFile "config/routes")

deriving instance Typeable Route

deriving instance Generic (Route App)

-- YesodPersist

instance YesodPersist App where
  type YesodPersistBackend App = SqlBackend
  runDB action = do
    master <- getYesod
    runSqlPool action (appConnPool master)

instance YesodPersistRunner App where
  getDBRunner = defaultGetDBRunner appConnPool

session_timeout_minutes :: Int
session_timeout_minutes = 10080 -- (7 days)

-- Yesod

instance Yesod App where
  approot = ApprootRequest \app req ->
    case appRoot (appSettings app) of
      Nothing -> getApprootText guessApproot app req
      Just root -> root

  makeSessionBackend :: App -> IO (Maybe SessionBackend)
  makeSessionBackend App {appSettings} = do
    backend <-
      defaultClientSessionBackend
        session_timeout_minutes
        "config/client_session_key.aes"
    maybeSSLOnly $ pure (Just backend)
    where
      maybeSSLOnly =
        if appSSLOnly appSettings
          then sslOnlySessions
          else id

  yesodMiddleware :: HandlerFor App res -> HandlerFor App res
  yesodMiddleware = customMiddleware . defaultYesodMiddleware . customCsrfMiddleware
    where
      customCsrfMiddleware handler = do
        maybeRoute <- getCurrentRoute
        dontCheckCsrf <- case maybeRoute of
          -- `maybeAuthId` checks for the validity of the Authorization
          -- header anyway, but it is still a good idea to limit this
          -- flexibility to designated routes.
          -- For the time being, `AddR` is the only route that accepts an
          -- authentication token.
          Just AddR -> isJust <$> lookupHeader "Authorization"
          _ -> pure False
        (if dontCheckCsrf then id else defaultCsrfMiddleware) handler

      customMiddleware handler = do
        addHeader "X-Frame-Options" "DENY"
        yesod <- getYesod
        ( if appSSLOnly (appSettings yesod)
            then sslOnlyMiddleware session_timeout_minutes
            else id
          )
          handler

  jsAttributes _ = [("type", "module")]

  defaultLayout widget = do
    req <- getRequest
    master <- getYesod
    urlrender <- getUrlRender
    mmsg <- getMessage
    musername <- maybeAuthUsername
    muser <- (fmap . fmap) snd maybeAuthPair
    let msourceCodeUri = appSourceCodeUri (appSettings master)
        frontendBundleName = appFrontendBundleName master
    pc <- widgetToPageContent do
      setTitle "Espial"
      addAppScripts
      addStylesheet (StaticR css_tachyons_min_css)
      addStylesheet (StaticR css_common_css)
      addStylesheet (StaticR css_main_css)
      $(widgetFile "default-layout")
    withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")

  shouldLogIO app "yesod-core" LevelWarn = pure False -- remove verbose CSRF token warnings
  shouldLogIO app source level = pure $ appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError

  makeLogger = return . appLogger

  authRoute _ = Just (AuthR LoginR)

  isAuthorized (AuthR _) _ = pure Authorized
  isAuthorized _ _ = pure Authorized

  defaultMessageWidget title body = do
    setTitle title
    toWidget
      [hamlet|
        <main .pv2.ph3.mh1>
          <div .w-100.mw8.center>
            <div .pa3.thm-bg-secondary>
              <h1>#{title}
              ^{body}
      |]

isAuthenticated :: Handler AuthResult
isAuthenticated =
  maybeAuthId >>= \case
    Just authId -> pure Authorized
    _ -> pure $ AuthenticationRequired

addAppScripts :: (MonadWidget m, HandlerSite m ~ App) => m ()
addAppScripts = do pure ()

-- popupLayout

popupLayout :: Widget -> Handler Html
popupLayout widget = do
  req <- getRequest
  master <- getYesod
  mmsg <- getMessage
  musername <- maybeAuthUsername
  let msourceCodeUri = appSourceCodeUri (appSettings master)
      frontendBundleName = appFrontendBundleName master
  pc <- widgetToPageContent do
    addAppScripts
    addStylesheet (StaticR css_tachyons_min_css)
    addStylesheet (StaticR css_common_css)
    addStylesheet (StaticR css_popup_css)
    $(widgetFile "popup-layout")
  withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")

-- YesodAuth

instance YesodAuth App where
  type AuthId App = UserId
  authPlugins _ = [dbAuthPlugin]
  authenticate = authenticateCreds
  loginDest = const HomeR
  logoutDest = const HomeR
  onLogin =
    maybeAuth >>= \case
      Nothing -> cpprint ("onLogin: could not find user" :: Text)
      Just (Entity _ uname) -> setSession userNameKey (userName uname)
  onLogout =
    deleteSession userNameKey
  redirectToReferer = const True
  maybeAuthId = do
    req <- waiRequest
    let mAuthHeader = lookup "Authorization" (Wai.requestHeaders req)
        extractKey = stripPrefix "ApiKey " . TE.decodeUtf8
    case mAuthHeader of
      Just authHeader ->
        case extractKey authHeader of
          Just apiKey -> do
            user <- liftHandler $ runDB $ getApiKeyUser (ApiKey apiKey)
            let userId = entityKey <$> user
            pure userId
          -- Since we disable CSRF middleware in the presence of Authorization
          -- header, we need to explicitly check for the validity of the header
          -- content. Otherwise, a dummy Authorization header with garbage input
          -- could be provided to circumvent CSRF token requirement, making the app
          -- vulnerable to CSRF attacks.
          Nothing -> pure Nothing
      _ -> defaultMaybeAuthId

instance YesodAuthPersist App

-- session keys

maybeAuthUsername :: Handler (Maybe Text)
maybeAuthUsername = do
  lookupSession userNameKey

ultDestKey :: Text
ultDestKey = "_ULT"

userNameKey :: Text
userNameKey = "_UNAME"

-- dbAuthPlugin

dbAuthPluginName :: Text
dbAuthPluginName = "db"

dbAuthPlugin :: AuthPlugin App
dbAuthPlugin = AuthPlugin dbAuthPluginName dbDispatch dbLoginHandler
  where
    dbDispatch :: Text -> [Text] -> AuthHandler App TypedContent
    dbDispatch "POST" ["login"] = dbPostLoginR >>= sendResponse
    dbDispatch _ _ = notFound
    dbLoginHandler toParent = do
      req <- getRequest
      lookupSession ultDestKey >>= \case
        Just dest | "logout" `isInfixOf` dest -> deleteSession ultDestKey
        _ -> pure ()
      setTitle "Espial | Log In"
      $(widgetFile "login")

dbLoginR :: AuthRoute
dbLoginR = PluginR dbAuthPluginName ["login"]

dbPostLoginR :: AuthHandler master TypedContent
dbPostLoginR = do
  mresult <-
    runInputPostResult
      ( dbLoginCreds
          <$> ireq textField "username"
          <*> ireq textField "password"
      )
  case mresult of
    FormSuccess creds -> setCredsRedirect creds
    _ -> loginErrorMessageI LoginR InvalidUsernamePass

dbLoginCreds :: Text -> Text -> Creds master
dbLoginCreds username password =
  Creds
    { credsPlugin = dbAuthPluginName,
      credsIdent = username,
      credsExtra = [("password", password)]
    }

authenticateCreds ::
  (MonadHandler m, HandlerSite m ~ App) =>
  Creds App ->
  m (AuthenticationResult App)
authenticateCreds Creds {..} = do
  muser <-
    case credsPlugin of
      p
        | p == dbAuthPluginName ->
            liftHandler $
              runDB $
                join <$> mapM (\pwd -> authenticatePassword credsIdent pwd) (lookup "password" credsExtra)
      _ -> pure Nothing
  case muser of
    Nothing -> pure (UserError InvalidUsernamePass)
    Just (Entity uid _) -> pure (Authenticated uid)

-- Util

instance RenderMessage App FormMessage where
  renderMessage :: App -> [Lang] -> FormMessage -> Text
  renderMessage _ _ = defaultFormMessage

instance HasHttpManager App where
  getHttpManager :: App -> Manager
  getHttpManager = appHttpManager

unsafeHandler :: App -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger