fradrive/src/Foundation/Instances.hs

{-# LANGUAGE UndecidableInstances #-} -- for `MonadCrypto` and `MonadSecretBox`
{-# LANGUAGE InstanceSigs #-}
{-# 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 UnliftIO.Pool (withResource)

import qualified Control.Monad.State.Class as State
import qualified Crypto.Hash as Crypto
import qualified Crypto.MAC.KMAC as Crypto

import qualified Data.Binary as Binary

import qualified Data.CaseInsensitive as CI

import qualified Database.Esqueleto as E


data instance ButtonClass UniWorX
  = BCIsButton
  | BCDefault
  | BCPrimary
  | BCSuccess
  | BCInfo
  | BCWarning
  | BCDanger
  | BCLink
  | BCMassInputAdd | BCMassInputDelete
  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 . to ($ ApprootDefault) 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 :: HasCallStack => YesodDB UniWorX a -> HandlerFor UniWorX a
  runDB = UniWorX.runDB' callStack

instance YesodPersistRunner UniWorX where
  getDBRunner :: HasCallStack => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
  getDBRunner = UniWorX.getDBRunner' callStack

    
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

    maybeAuthId = runMaybeT $ authIdFromBearer <|> MaybeT defaultMaybeAuthId
      where authIdFromBearer = do
              BearerToken{..} <- MaybeT maybeBearerToken
              hoistMaybe bearerImpersonate

instance YesodAuthPersist UniWorX where
  getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User)
  getAuthEntity = liftHandler . runDBRead' callStack . get

    
instance YesodMail UniWorX where
  defaultFromAddress = getsYesod $ view _appMailFrom
  envelopeFromAddress = getsYesod $ view _appMailEnvelopeFrom
  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
  mailDateTZ = return appTZ
  mailSmtp act = do
    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
    withResource pool act
  mailT ctx mail = do
    mailRecord <- newEmptyTMVarIO
    mailProcess <- allocateLinkedAsync $ do
      defMailT ctx $ do
        void setMailObjectIdRandom
        sentMailSentAt <- liftIO getCurrentTime
        setDate sentMailSentAt
        replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailSender . to renderAddress)

        (mRes, smtpData) <- listen mail

        sentMailObjectId <- getMailObjectId
  
        mContent <- State.get
  
        smtpData' <- if | smtpData ^. _MailSmtpDataSet -> return smtpData
                        | otherwise -> getMailSmtpData
        verpMode <- getsYesod $ view _appMailVerp
        (smtpData'', sentMailBounceSecret) <- if
          | Verp{..} <- verpMode
          , [_] <- smtpData' ^.. _smtpRecipients . folded
          , Just [l, d] <- previews (_smtpEnvelopeFrom . _Wrapped . _Just) (Text.splitOn "@") smtpData'
            -> do
              verpSecret <- getsYesod appVerpSecret
              let bounceSecret = BounceSecret . Crypto.kmacGetDigest $ kmaclazy ("bounce" :: ByteString) verpSecret $ Binary.encode mContent
                  verpAddr = l <> Text.singleton verpSeparator <> verpPrefix <> "." <> toPathPiece bounceSecret <> "@" <> d
              return ( smtpData' <> mempty { smtpEnvelopeFrom = Last $ Just verpAddr }
                     , Just bounceSecret
                     )
          | otherwise -> return (smtpData', Nothing)
        tell smtpData''

        sentMailSentBy <- getsYesod appInstanceID
        let sentMailRecipient = Nothing -- Fill in later
            sentMailHeaders = MailHeaders $ mconcat
              [ renderAddressHeader "From" [mailFrom mContent]
              , fromMaybe [] $ do
                  toAddrs <- assertM' (not . null) $ mailTo mContent
                  return $ renderAddressHeader "To" toAddrs
              , fromMaybe [] $ do
                  ccAddrs <- assertM' (not . null) $ mailCc mContent
                  return $ renderAddressHeader "Cc" ccAddrs
              , fromMaybe [] $ do
                  bccAddrs <- assertM' (not . null) $ mailBcc mContent
                  return $ renderAddressHeader "Bcc" bccAddrs
              , mailHeaders mContent
              ]
              where
                renderAddressHeader :: ByteString -> [Address] -> [(ByteString, Text)]
                renderAddressHeader lbl = pure . (lbl, ) . Text.intercalate ", " . map renderAddress
            sentMailContent = MailContent $ mailParts mContent
            sentMailContentRef = SentMailContentKey . MailContentReference . Crypto.hashlazy $ Binary.encode sentMailContent

        atomically $ putTMVar mailRecord
          ( smtpData'' ^.. _smtpRecipients . folded
          , sentMailContent
          , SentMail{..}
          )
        atomically . guardM $ isEmptyTMVar mailRecord
        return mRes

    (smtpRecipients, sentMailContentContent, sentMail) <- atomically $ takeTMVar mailRecord
    void . tryAny . liftHandler . runDB . setSerializable $ do -- Ignore exceptions that occur during logging
      sentMailRecipient <- if
        | [Address _ (CI.mk -> recipAddr)] <- smtpRecipients -> do
            recipUsers <- E.select . E.from $ \user -> do
              E.where_ $ user E.^. UserDisplayEmail E.==. E.val recipAddr
                   E.||. user E.^. UserEmail        E.==. E.val recipAddr
                   E.||. user E.^. UserIdent        E.==. E.val recipAddr
              return user
            let recipUserCompare = mconcat
                  [ comparing $ Down . (== recipAddr) . userIdent . entityVal
                  , comparing $ Down . (== recipAddr) . userEmail . entityVal
                  , comparing $ Down . (== recipAddr) . userDisplayEmail . entityVal
                  ]
            return $ if
              | ( bU : us ) <- sortBy recipUserCompare recipUsers
              , maybe True (\u -> recipUserCompare bU u == LT) $ listToMaybe us
                -> Just $ entityKey bU
              | otherwise -> Nothing
        | otherwise -> return Nothing

      -- @insertUnique@ _does not_ work here
      unlessM (exists [ SentMailContentHash ==. unSentMailContentKey (sentMailContentRef sentMail) ]) $
        insert_ SentMailContent { sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail
                                , sentMailContentContent
                                }
      insert_ sentMail{ sentMailRecipient }
      wait mailProcess -- Abort transaction if sending failed
    wait mailProcess -- Rethrow exceptions for mailprocess; technically unnecessary due to linkage, doesn't hurt, though

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

instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadAuth m where
  authKey = getsYesod appAuthKey