fradrive/src/Handler/Utils/Qualification.hs

-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later


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

import Import

-- 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.DateTime (toMidnight)


mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> Maybe Day -> QualificationUserBlock
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockUntil = QualificationUserBlock{..}
  where 
    qualificationUserBlockReason = qualificationBlockedReasonText reason    


isValidQualification :: HasQualificationUser a => Day -> a -> Bool
isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld
                                         ,q ^. hasQualificationUser . _qualificationUserValidUntil)
                            && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue)  

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

-- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date
validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
validQualification nowaday = \qualUser ->
  (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
                             ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
           E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)    -- not blocked            

validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
validQualification' nowaday qualUser =
  (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
                                 ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
     E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue)    -- not blocked            


selectValidQualifications :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser]
selectValidQualifications qid mbUids nowaday = 
  -- nowaday <- utctDay <$> liftIO getCurrentTime
  E.select $ do 
    qUser <- E.from $ E.table @QualificationUser
    E.where_ $  (qUser E.^. QualificationUserQualification E.==. E.val qid)
          E.&&. validQualification nowaday qUser
          E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
    pure qUser


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


upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB ()
upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
  Entity quid _ <- upsert
    QualificationUser
      { qualificationUserFirstHeld        = qualificationUserLastRefresh
      , qualificationUserBlockedDue       = Nothing
      , qualificationUserScheduleRenewal  = fromMaybe True mbScheduleRenewal
      , qualificationUserLastNotified     = toMidnight qualificationUserLastRefresh
      , ..
      }
    (
      [ QualificationUserScheduleRenewal    =. scheduleRenewal              | Just scheduleRenewal <- [mbScheduleRenewal]
      ] ++
      [ QualificationUserValidUntil         =. qualificationUserValidUntil
      , QualificationUserLastRefresh        =. qualificationUserLastRefresh
      , QualificationUserBlockedDue         =. Nothing
      ]
    )
  audit TransactionQualificationUserEdit
    { transactionQualificationUser            = quid
    , transactionQualification                = qualificationUserQualification
    , transactionUser                         = qualificationUserUser
    , transactionQualificationValidUntil      = qualificationUserValidUntil
    , transactionQualificationScheduleRenewal = mbScheduleRenewal
    }

renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int
renewValidQualificationUsers qid uids =
  -- This code works in principle, but it does not allow audit log entries.
  -- 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{qualificationValidDuration=Just renewalMonths} -> do
      nowaday <- utctDay <$> liftIO getCurrentTime
      quEntsAll <- selectValidQualifications qid (Just uids) nowaday     
      let maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
          quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
      forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do 
        let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil        
        update quId [ QualificationUserValidUntil   =. newValidTo
                    , QualificationUserLastRefresh  =. nowaday
                    ]
        audit TransactionQualificationUserEdit
          { transactionQualificationUser            = quId
          , transactionQualification                = qualificationUserQualification
          , transactionUser                         = qualificationUserUser
          , transactionQualificationValidUntil      = newValidTo
          , transactionQualificationScheduleRenewal = Nothing
          }
      return $ length quEnts
    _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.


-- qualificationUserBlocking :: QualificationId -> [UserId] -> Maybe QualificationBlocked -> DB Int64
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 QualificationBlocked -> ReaderT (YesodPersistBackend (HandlerSite m)) m n

qualificationUserBlocking qid uids notify qb = do
  now <- liftIO getCurrentTime
  oks <- updateWhereCount -- prevents storage of transactionQualificatioUser 
    ( [ QualificationUserBlockedDue     !=. Nothing  |  isNothing qb  -- only unblock blocked qualification; allow overwrite for existing blocks
      ] ++  
      [ QualificationUserQualification  ==. qid
      , QualificationUserUser           <-. uids    
      ]
    )
    (guardMonoid (not notify)
    [   QualificationUserLastNotified =. now
    ] ++
    [   QualificationUserBlockedDue   =. qb 
    ])
  forM_ uids $ \uid -> do     
    audit TransactionQualificationUserBlocking 
      { -- transactionQualificationUser  = quid
        transactionQualification      = qid
      , transactionUser               = uid
      , transactionQualificationBlock = qb
      }
  return $ fromIntegral oks

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] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids reason = do
  blockedUsers <- selectList [ QualificationUserQualification ==. qid
                             , QualificationUserBlockedDue !=. Nothing
                             , QualificationUserUser <-. uids
                             ] [Asc QualificationUserId]
  let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers
  oks <- updateWhereCount  [ QualificationUserId <-. (view _entityKey <$> toUnblock) ]
                           [ QualificationUserBlockedDue =. Nothing ]
  forM_ toUnblock $ \ubl -> do     
    audit TransactionQualificationUserBlocking 
      { -- transactionQualificationUser  = quid
        transactionQualification      = qid
      , transactionUser               = ubl ^. _entityVal . _qualificationUserUser
      , transactionQualificationBlock = Nothing
      }                           
  return $ fromIntegral oks