fradrive/src/Handler/Utils/Qualification.hs

-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE TypeApplications #-}

module Handler.Utils.Qualification
  ( module Handler.Utils.Qualification
  ) where

import Import

import qualified Data.Text as Text

-- import Data.Time.Calendar (CalendarDiffDays(..))
-- import Database.Persist.Sql (updateWhereCount)
import qualified Database.Esqueleto.Experimental as E   -- might need TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E

import Handler.Utils.Widgets  (statusHtml)

-- | Compute new valid date from old one and from validDuration in months
--   Mainly to document which add months functions to use
computeNewValidDate :: Integral a => a -> Day -> Day
computeNewValidDate = addGregorianMonthsRollOver . toInteger

statusQualificationBlock :: Bool -> Html
statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s

-- needs refactoring, probbably no longer helpful
mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
   where
     qualificationUserBlockReason  = tshow reason
     qualificationUserBlockUnblock = False
     qualificationUserBlockBlocker = Nothing

-- somewhat dangerous, if not used with latest effective block
isValidQualification :: (HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> Bool
isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _qualificationUserFirstHeld
                                            ,qu ^. hasQualificationUser . _qualificationUserValidUntil)
                          && all (^. hasQualificationUserBlock . _qualificationUserBlockUnblock) qb

------------------
-- SQL Snippets --
------------------

-- | Recently became invalid or blocked and not yet notified; assumes that second argument is latest active block (if exists), also checks validity with respect to given timestamp
quserToNotify :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value Bool)
quserToNotify cutoff quser qblock = -- either recently become invalid with no prior block or recently blocked
      -- has expired without being blocked
                quser E.^. QualificationUserScheduleRenewal
      E.&&. ((  quser E.^. QualificationUserValidUntil E.<. E.val  (utctDay cutoff)
          E.&&. quser E.^. QualificationUserValidUntil E.>. E.day  (quser E.^. QualificationUserLastNotified)
          E.&&. E.not__ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
        ) E.||. ( -- was recently blocked
                        E.isFalse (qblock E.?. QualificationUserBlockUnblock)
          E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified)
        ))

-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
    newerBlock <- E.from $ E.table @QualificationUserBlock
    E.where_ $          newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
        E.&&.           newerBlock E.^. QualificationUserBlockFrom              E.<=. cutoff
        E.&&.    E.just(newerBlock E.^. QualificationUserBlockId)               E.!=. qualBlock E.?. QualificationUserBlockId
        E.&&.  ((E.just(newerBlock E.^. QualificationUserBlockFrom)             E.>.  qualBlock E.?. QualificationUserBlockFrom)
          E.||. (       newerBlock E.^. QualificationUserBlockUnblock           -- in case of equal timestamps, any unblock wins
                 E.&&. (newerBlock E.^. QualificationUserBlockFrom              E.=?. qualBlock E.?. QualificationUserBlockFrom)
               ))
  )

-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
--   variant for inner joins
isLatestBlockBefore' :: E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
isLatestBlockBefore' qualBlock cutoff = (cutoff E.>. qualBlock E.^. QualificationUserBlockFrom) E.&&. E.notExists (do
    newerBlock <- E.from $ E.table @QualificationUserBlock
    E.where_ $          newerBlock E.^. QualificationUserBlockQualificationUser E.==. qualBlock E.^. QualificationUserBlockQualificationUser
        E.&&.           newerBlock E.^. QualificationUserBlockFrom              E.<=. cutoff
        E.&&.           newerBlock E.^. QualificationUserBlockId                E.!=. qualBlock E.^. QualificationUserBlockId
        E.&&.  ((       newerBlock E.^. QualificationUserBlockFrom              E.>.  qualBlock E.^. QualificationUserBlockFrom)
          E.||. (       newerBlock E.^. QualificationUserBlockUnblock           -- in case of equal timestamps, any unblock wins
                 E.&&. (newerBlock E.^. QualificationUserBlockFrom              E.==. qualBlock E.^. QualificationUserBlockFrom)
               ))
  )

-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
  qualUserBlock <- E.from $ E.table @QualificationUserBlock
  E.where_  $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
      E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff)
      E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
      E.&&. E.notExists (do
        qualUserUnblock <- E.from $ E.table @QualificationUserBlock
        E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock)
            E.&&.  checkQualUserId (qualUserUnblock E.^. QualificationUserBlockQualificationUser)
            E.&&.  qualUserUnblock E.^. QualificationUserBlockFrom E.<=. cutoff
            E.&&.  qualUserUnblock E.^. QualificationUserBlockFrom E.>=. qualUserBlock E.^. QualificationUserBlockFrom -- in case of identical timestamps, the unblock trumps the block
      )
  whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))

-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked
quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing

-- | Variant of `isBlocked` for outer joins
quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing

qualificationValid :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
qualificationValid = flip validQualification

validQualification :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
validQualification cutoff qualUser =
  (E.val (utctDay cutoff) `E.between` (qualUser E.^. QualificationUserFirstHeld
                                      ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
           E.&&. quserBlock False cutoff qualUser

-- |  Variant of `validQualification` for outer joins
validQualification' :: UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
validQualification' cutoff qualUser =
  (E.justVal (utctDay cutoff) `E.between` (qualUser E.?. QualificationUserFirstHeld
                                          ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
           E.&&. quserBlock' False cutoff qualUser

-- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
-- selectValidQualifications ::
--   ( MonadIO m
--   , BackendCompatible SqlBackend backend
--   , PersistQueryRead backend
--   , PersistUniqueRead backend
--   ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
selectValidQualifications :: (MonadIO m, E.SqlBackendCanRead backend)
  => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
selectValidQualifications qid uids cutoff =
  -- cutoff <- utctDay <$> liftIO getCurrentTime
  E.select $ do
    qUser <- E.from $ E.table @QualificationUser
    E.where_ $  (qUser E.^. QualificationUserQualification E.==. E.val qid)
          E.&&.  qUser E.^. QualificationUserUser `E.in_` E.valList uids
          E.&&.  validQualification cutoff qUser
    -- whenIsJust mbUids (\uids -> E.where_ $ qUser E.^. QualificationUserUser `E.in_` E.valList uids)
    pure qUser

selectRelevantBlock :: UTCTime -> QualificationUserId -> DB (Maybe (Entity QualificationUserBlock))
selectRelevantBlock cutoff quid =
  selectFirst [QualificationUserBlockQualificationUser ==. quid, QualificationUserBlockFrom <=. cutoff] [Desc QualificationUserBlockFrom]

------------------------
-- Complete Functions --
------------------------


upsertQualificationUser :: QualificationId -> UTCTime -> Day -> Maybe Bool -> Text -> UserId -> DB () -- ignores blocking
upsertQualificationUser  qualificationUserQualification startTime qualificationUserValidUntil mbScheduleRenewal reason qualificationUserUser = do
  let qualificationUserLastRefresh = utctDay startTime
  Entity quid _ <- upsert
    QualificationUser
      { qualificationUserFirstHeld        = qualificationUserLastRefresh
      , qualificationUserScheduleRenewal  = fromMaybe True mbScheduleRenewal
      , qualificationUserLastNotified     = utctDayMidnight qualificationUserLastRefresh
      , ..
      }
    (
      [ QualificationUserScheduleRenewal    =. scheduleRenewal              | Just scheduleRenewal <- [mbScheduleRenewal]
      ] ++
      [ QualificationUserValidUntil         =. qualificationUserValidUntil
      , QualificationUserLastRefresh        =. qualificationUserLastRefresh
      ]
    )
  authUsr <- liftHandler maybeAuthId
  insert_ $ QualificationUserBlock quid True startTime reason authUsr
  audit TransactionQualificationUserEdit
    { transactionQualificationUser            = quid
    , transactionQualification                = qualificationUserQualification
    , transactionUser                         = qualificationUserUser
    , transactionQualificationValidUntil      = qualificationUserValidUntil
    , transactionQualificationScheduleRenewal = mbScheduleRenewal
    , transactionNote                         = canonical $ Just reason
    }

-- | Renew an existing valid qualification, ignoring all blocks otherwise
-- renewValidQualificationUsers :: QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB
renewValidQualificationUsers ::
  ( AuthId (HandlerSite m) ~ Key User
  , IsPersistBackend (YesodPersistBackend (HandlerSite m))
  , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
  , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
  , PersistQueryWrite (YesodPersistBackend (HandlerSite m))
  , PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
  , HasInstanceID (HandlerSite m) InstanceId
  , YesodAuthPersist (HandlerSite m)
  , HasAppSettings (HandlerSite m)
  , MonadHandler m
  , MonadCatch m
  ) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
renewValidQualificationUsers qid reason renewalTime uids =
  -- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed?
  -- E.update $ \qu -> do
  --   E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
  --   E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
  --       E.&&.  (qu E.^. QualificationUserUser `E.in_` E.valList uids)
  get qid >>= \case
    Just Qualification{qualificationElearningRenews=False}
      | Just (Right (QualificationRenewELearningBy _)) <- reason -> return 0
    Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
      cutoff <- maybe (liftIO getCurrentTime) return renewalTime
      quEntsAll <- selectValidQualifications qid uids cutoff
      let cutoffday   = utctDay cutoff
          maxValidTo  = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday
          quEnts      = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
      forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
        let newValidTo = computeNewValidDate renewalMonths qualificationUserValidUntil
        update quId [ QualificationUserValidUntil   =. newValidTo
                    , QualificationUserLastRefresh  =. cutoffday
                    ]
        audit TransactionQualificationUserEdit
          { transactionQualificationUser            = quId
          , transactionQualification                = qualificationUserQualification
          , transactionUser                         = qualificationUserUser
          , transactionQualificationValidUntil      = newValidTo
          , transactionQualificationScheduleRenewal = Nothing
          , transactionNote                         = qualificationChangeReasonText <$> reason
          }
      return $ length quEnts
    _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.

-- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used)
qualificationUserBlocking ::
  ( AuthId (HandlerSite m) ~ Key User
  , IsPersistBackend (YesodPersistBackend (HandlerSite m))
  , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
  , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
  , PersistQueryWrite (YesodPersistBackend (HandlerSite m))
  , PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
  , HasInstanceID (HandlerSite m) InstanceId
  , YesodAuthPersist (HandlerSite m)
  , HasAppSettings (HandlerSite m)
  , MonadHandler m
  , MonadCatch m
  , Num n
  ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReasonText -> reason) notify = do
  $logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify, "#Users:" <> tshow (length uids), tshow uids] -- this message can get very long on test systems
  authUsr <- liftHandler maybeAuthId
  now <- liftIO getCurrentTime
  let blockTime = fromMaybe now mbBlockTime
  -- -- Code would work, but problematic
  -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
  --   E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid
  --       E.&&.  qualificationUser E.^. QualificationUserUser E.in_ E.valList uid
  --       E.&&.  quserBlock unblock blockTime qualificationUser -- only unblock blocked qualification and vice versa
  --   return $ QualificationUserBlock
  --     E.<#  qualificationUser E.^. QualificationUserId
  --     E.<&> E.val unblock
  --     E.<&> E.val blockTime
  --     E.<&> E.val reason
  --     E.<&> E.val authUsr
  toChange <- E.select $ do
    qualUser <- E.from $ E.table @QualificationUser
    E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid
        E.&&.  qualUser E.^. QualificationUserUser `E.in_` E.valList uids
        E.&&.  quserBlock unblock blockTime qualUser -- only unblock blocked qualification and vice versa
    return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
  let newBlocks = map (\(E.Value quid, E.Value uid) -> (uid, QualificationUserBlock
                      { qualificationUserBlockQualificationUser = quid
                      , qualificationUserBlockUnblock           = unblock
                      , qualificationUserBlockFrom              = blockTime
                      , qualificationUserBlockReason            = reason
                      , qualificationUserBlockBlocker           = authUsr
                      })) toChange
  E.insertMany_ (snd <$> newBlocks)
  unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. addUTCTime 1 blockTime]
  forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking
    { transactionQualification      = qid
    , transactionUser               = uid
    , transactionQualificationBlock = qub
    }
  return $ fromIntegral $ length newBlocks

qualificationUserUnblockByReason ::
  ( AuthId (HandlerSite m) ~ Key User
  , IsPersistBackend (YesodPersistBackend (HandlerSite m))
  , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
  , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
  , PersistQueryWrite (YesodPersistBackend (HandlerSite m))
  , PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
  , HasInstanceID (HandlerSite m) InstanceId
  , YesodAuthPersist (HandlerSite m)
  , HasAppSettings (HandlerSite m)
  , MonadHandler m
  , MonadCatch m
  , Num n
  ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do
  cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime
  toUnblock <- E.select $ do
    quser <- E.from $ E.table @QualificationUser
    E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
        E.&&.  quser E.^. QualificationUserUser `E.in_` E.valList uids
        E.&&.  quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
    return $ quser E.^. QualificationUserUser
  qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify


-----------
-- Forms --
-----------


qualificationOption :: Entity Qualification -> Option QualificationId
qualificationOption (Entity qid Qualification{..}) =
  let qsh = ciOriginal $ unSchoolKey qualificationSchool
  in  Option{ optionDisplay       = ciOriginal qualificationName      <> " ("  <> qsh <> ")"
            , optionExternalValue = toPathPiece $ ciOriginal qualificationShorthand <> "___" <> qsh  -- both a publicly known already
            , optionInternalValue = qid
            }

qualificationsOptionList :: [Entity Qualification] -> OptionList QualificationId
qualificationsOptionList = mkOptionList . map qualificationOption

{- Should we encrypt the external value or simply rely on uniqueness? --TODO: still used in Handler.Admin.Avs
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
qualOpt (Entity qualId qual) = do
  cQualId :: CryptoUUIDQualification <- encrypt qualId
  return $ Option
    { optionDisplay       = ciOriginal $ qualificationName qual
    , optionInternalValue = qualId
    , optionExternalValue = tshow cQualId
    }
-}