fradrive/src/Handler/Utils/Qualification.hs

-- SPDX-FileCopyrightText: 2022-25 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 (deleteWhereCount) -- (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)
import Handler.Utils.Memcached
import Handler.Utils.DateTime (addLocalDays)

retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification)
retrieveQualification qid = liftHandler $ $(memcachedByHere) (Just . Right $ 7 * diffHour) qid $ runDBRead $ get qid

{-
This experiment proves that a newtype-wrapper is entirely ignored by the derived Binary instance, since
regardless whether the prime or unprimed version is used, the same QualificationId leads to a hit:

newtype MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId } -- unnecessary, also see top comment in Handler.Utils.Memcached
  deriving newtype (Eq, Ord, Show, Binary)
instance NFData MemcachedQualification where
  rnf MemcachedQualification{..} = rnf unMemachedQualification

-- note that data does not work as expected either, the binary instance is only distinguished by the addition of another element
data MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId } -- , someId :: Text } -- with Text works OK
  deriving (Eq, Ord, Show, Generic, Binary)
instance NFData MemcachedQualification where
  rnf MemcachedQualification{..} = rnf (unMemachedQualification, someId)

retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification)
retrieveQualification qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) (MemcachedQualification qid) $ do
  $logWarnS "CACHE-MISS" [st|Retrieve Qualification #{tshow qid} with Newtype-wrapper.|]
  runDBRead $ get qid

retrieveQualification' :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification)
retrieveQualification' qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) qid $ do
  $logWarnS "CACHE-MISS" [st|Retrieve Qualification #{tshow qid} directly without a wrapper.|]
  runDBRead $ get qid
-}


-- | 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 = addGregorianMonthsClip . toInteger

computeNewValidDate' :: CalendarDiffDays -> Day -> Day
computeNewValidDate' = addGregorianDurationClip



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  = computeNewValidDate (renewalMonths `div` 2) cutoffday -- earliest renewal: only if less than half the valid duration remains!
          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
    }
-}


-----------------
-- LMS related --
-----------------

data LmsOrphanReason
  = LmsOrphanReasonManualTermination
  | LmsOrphanReasonB
  | LmsOrphanReasonC
  deriving (Eq, Ord, Enum, Bounded, Generic)
  deriving anyclass (Universe, Finite, NFData)

-- NOTE: it is intentional not to have an embedRenderMessage here; within the DB, we allow arbitrary text, but we do match on these ones to recognise certain functions
--       so do not change values here without a proper migration
instance Show LmsOrphanReason where
  show LmsOrphanReasonManualTermination = "Manuell abgebrochen"
  show LmsOrphanReasonB = "B"
  show LmsOrphanReasonC = "C"

-- | Remove user from e-learning for given qualification and add to LmsOrphan dated back for immediate deletion. Calls audit
terminateLms :: LmsOrphanReason -> QualificationId -> [UserId] -> DB Int
terminateLms _      _   [] = return 0
terminateLms reason qid uids = do
  now <- liftIO getCurrentTime
  orphanDelDays <- getsYesod $ view $ _appLmsConf . _lmsOrphanDeletionDays
  let delSeenFirst = addLocalDays (negate orphanDelDays) now
      tReason = Just $ tshow reason
  lusers <- selectList [LmsUserQualification ==. qid, LmsUserUser <-. uids] []  -- relies on UniqueLmsQualificationUser
  if null lusers then return 0 else do
    forM_ lusers $ \Entity{entityVal=LmsUser{..}} -> do
      void $ upsertBy (UniqueLmsOrphan lmsUserQualification lmsUserIdent) LmsOrphan
        { lmsOrphanQualification = lmsUserQualification
        , lmsOrphanIdent         = lmsUserIdent
        , lmsOrphanSeenFirst     = delSeenFirst -- ensure fast deletion, since users might still to e-learning
        , lmsOrphanSeenLast      = now          -- ensure fast deletion -- fromMaybe now $ lmsUserLastReceived
        , lmsOrphanDeletedLast   = Nothing
        , lmsOrphanResultLast    = lmsUserStatus & lmsStatus2State
        , lmsOrphanReason        = tReason
        } -- update should not happen, but just in case ensure fast deletion
        [ LmsOrphanSeenFirst =. delSeenFirst
        , LmsOrphanSeenLast  =. now
        , LmsOrphanReason    =. tReason
        ]
      audit TransactionLmsTerminated
        { transactionQualification = lmsUserQualification
        , transactionLmsIdent      = lmsUserIdent
        , transactionLmsUser       = lmsUserUser
        , transactionNote          = tReason
        }
    fromIntegral <$> deleteWhereCount [LmsUserId <-. fmap entityKey lusers]