fradrive-old/src/Foundation/Instances.hs

{-# LANGUAGE UndecidableInstances #-} -- for `MonadCrypto` and `MonadSecretBox`
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Foundation.Instances
  ( ButtonClass(..), YesodPersistBackend, AuthId, MonadCryptoKey
  , unsafeHandler
  ) where

import Import.NoFoundation

import qualified Data.Text as Text
import qualified Data.List as List
import Data.List (inits)

import qualified Yesod.Core.Unsafe as Unsafe
import qualified Yesod.Auth.Message as Auth

import Utils.Form
import Auth.LDAP
import Auth.PWHash
import Auth.Dummy

import qualified Foundation.Yesod.Session as UniWorX
import qualified Foundation.Yesod.Middleware as UniWorX
import qualified Foundation.Yesod.ErrorHandler as UniWorX
import qualified Foundation.Yesod.StaticContent as UniWorX
import qualified Foundation.Yesod.Persist as UniWorX
import qualified Foundation.Yesod.Auth as UniWorX

import Foundation.SiteLayout
import Foundation.Type
import Foundation.I18n
import Foundation.Authorization
import Foundation.Yesod.Auth hiding (authenticate)
import Foundation.Routes
import Foundation.DB

import Network.Wai.Parse (lbsBackEnd)

import Control.Monad.Writer.Class (MonadWriter(..))
import UnliftIO.Pool (withResource)


data instance ButtonClass UniWorX
  = BCIsButton
  | BCDefault
  | BCPrimary
  | BCSuccess
  | BCInfo
  | BCWarning
  | BCDanger
  | BCLink
  | BCMassInputAdd | BCMassInputDelete
  | BCScheduleView | BCScheduleOffset
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
  deriving anyclass (Universe, Finite)

instance PathPiece (ButtonClass UniWorX) where
  toPathPiece BCIsButton = "btn"
  toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
  fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF

instance Button UniWorX ButtonSubmit where
  btnClasses BtnSubmit = [BCIsButton, BCPrimary]



-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod UniWorX where
    -- Controls the base of generated URLs. For more information on modifying,
    -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
    approot = ApprootRequest $ \app req ->
        case app ^. _appRoot of
            Nothing -> getApprootText guessApproot app req
            Just root -> root

    makeSessionBackend = UniWorX.makeSessionBackend

    maximumContentLength app _ = app ^. _appMaximumContentLength

    -- Yesod Middleware allows you to run code before and after each handler function.
    -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
    -- Some users may also want to add the defaultCsrfMiddleware, which:
    --   a) Sets a cookie with a CSRF token in it.
    --   b) Validates that incoming write requests include that token in either a header or POST parameter.
    -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
    -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
    yesodMiddleware = UniWorX.yesodMiddleware

    -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
    defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"

    errorHandler = UniWorX.errorHandler

    defaultLayout = siteLayout' Nothing

    -- The page to be redirected to when authentication is required.
    authRoute _ = Just $ AuthR LoginR

    isAuthorized = evalAccess

    addStaticContent = UniWorX.addStaticContent

    fileUpload _site _length = FileUploadMemory lbsBackEnd

    -- What messages should be logged. The following includes all messages when
    -- in development, and warnings and errors in production.
    shouldLogIO app _source level = do
      LogSettings{..} <- readTVarIO $ appLogSettings app
      return $ logAll || level >= logMinimumLevel

    makeLogger = readTVarIO . snd . appLogger

unsafeHandler :: UniWorX -> HandlerFor UniWorX a -> IO a
unsafeHandler f h = do
  logger <- makeLogger f
  Unsafe.fakeHandlerGetLogger (const logger) f h


-- How to run database actions.
instance YesodPersist UniWorX where
    type YesodPersistBackend UniWorX = SqlBackend
    runDB = UniWorX.runDB

instance YesodPersistRunner UniWorX where
    getDBRunner = UniWorX.getDBRunner

    
instance YesodAuth UniWorX where
    type AuthId UniWorX = UserId

    -- Where to send a user after successful login
    loginDest _ = NewsR
    -- Where to send a user after logout
    logoutDest _ = NewsR
    -- Override the above two destinations when a Referer: header is present
    redirectToReferer _ = True

    loginHandler = do
      toParent <- getRouteToParent
      liftHandler . defaultLayout $ do
        plugins <- getsYesod authPlugins
        $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)

        setTitleI MsgLoginTitle
        $(widgetFile "login")

    authenticate = UniWorX.authenticate

    authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
      [ flip campusLogin campusUserFailoverMode <$> appLdapPool
      , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
      , dummyLogin <$ guard appAuthDummyLogin
      ]

    authHttpManager = getsYesod appHttpManager

    onLogin = liftHandler $ do
      mlang <- runDB $ updateUserLanguage Nothing
      app <- getYesod
      let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang
             | otherwise = renderMessage app []
      addMessage Success . toHtml $ mr Auth.NowLoggedIn

    onErrorHtml dest msg = do
      addMessage Error $ toHtml msg
      redirect dest

    renderAuthMessage _ ls = case lang of
      ("en" : _) -> Auth.englishMessage
      _other     -> Auth.germanMessage
      where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls

instance YesodAuthPersist UniWorX where
  getAuthEntity = liftHandler . runDBRead . get

    
instance YesodMail UniWorX where
  defaultFromAddress = getsYesod $ view _appMailFrom
  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
  mailVerp = getsYesod $ view _appMailVerp
  mailDateTZ = return appTZ
  mailSmtp act = do
    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
    withResource pool act
  mailT ctx mail = defMailT ctx $ do
    void setMailObjectIdRandom
    setDateCurrent
    replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)

    (mRes, smtpData) <- listen mail
    unless (view _MailSmtpDataSet smtpData)
      setMailSmtpData

    return mRes


instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
  type MonadCryptoKey m = CryptoIDKey
  cryptoIDKey f = getsYesod appCryptoIDKey >>= f

instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
  secretBoxKey = getsYesod appSecretBoxKey