fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(qualifications): renew regularly implemented

Browse Source
This commit is contained in:
Steffen Jost 2023-02-21 13:45:34 +01:00
parent 8c7158eac9
commit b3861144aa
11 changed files with 107 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/lms.model
View File

@ -57,7 +57,7 @@ QualificationEdit
QualificationUser
user UserId OnDeleteCascade OnUpdateCascade
qualification QualificationId OnDeleteCascade OnUpdateCascade
validUntil Day
validUntil Day -- addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False
firstHeld Day -- first time the qualification was earned, should never change
blockedDue QualificationBlocked Maybe -- isJust means that the qualification is currently revoked

2
src/Audit/Types.hs
View File

@ -201,7 +201,7 @@ data Transaction
| TransactionQualificationUserEdit
{ transactionQualificationUser :: QualificationUserId
, transactionQualification :: QualificationId
, transactionUser :: UserId
, transactionUser :: UserId -- qualification holder that is updated
, transactionQualificationValidUntil :: Day
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
}

2
src/Database/Esqueleto/Utils.hs
View File

@ -528,7 +528,7 @@ day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
day = E.unsafeSqlCastAs "date"
interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
where
singleQuote = Text.Builder.singleton '\''

1
src/Handler/Admin/Avs.hs
View File

@ -23,6 +23,7 @@ import qualified Data.Map as Map
import Handler.Utils
import Handler.Utils.Avs
-- import Handler.Utils.Qualification
import Utils.Avs

2
src/Handler/LMS.hs
View File

@ -46,7 +46,7 @@ import Handler.LMS.Userlist as Handler.LMS
import Handler.LMS.Result as Handler.LMS
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production!
import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below?
-- import Handler.Utils.Qualification (validQualification)
-- avoids repetition of local definitions
single :: (k,a) -> Map k a

2
src/Handler/Qualification.hs
View File

@ -35,7 +35,7 @@ import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below?
-- import Handler.Utils.Qualification (validQualification)
-- avoids repetition of local definitions
single :: (k,a) -> Map k a

2
src/Handler/Tutorial/Users.hs
View File

@ -111,7 +111,7 @@ postTUsersR tid ssh csh tutn = do
addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserRenewQualificationData{..}, selectedUsers) -> do
noks <- runDB $ renewQualificationUsers tuQualification $ Set.toList selectedUsers
noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers
addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserSendMailData{}, selectedUsers) -> do

21
src/Handler/Utils/Avs.hs
View File

@ -5,9 +5,11 @@
{-# LANGUAGE TypeApplications #-}
-- Module for functions directly related to the AVS interface,
-- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification
module Handler.Utils.Avs
( validQualification, validQualification'
, guessAvsUser
( guessAvsUser
, upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, AvsLicenceDifferences(..)
@ -35,6 +37,7 @@ import qualified Data.CaseInsensitive as CI
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
import Handler.Utils.Company
import Handler.Utils.Qualification
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
@ -63,21 +66,7 @@ instance Exception AvsException
Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
-}
------------------
-- SQL Snippets --
------------------
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
------------------

81
src/Handler/Utils/Qualification.hs
View File

@ -13,6 +13,42 @@ import Import
import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E
------------------
-- 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
@ -31,20 +67,37 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
]
)
audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid
, transactionQualification = qualificationUserQualification
, transactionUser = qualificationUserUser
, transactionQualificationValidUntil = qualificationUserValidUntil
{ transactionQualificationUser = quid
, transactionQualification = qualificationUserQualification
, transactionUser = qualificationUserUser
, transactionQualificationValidUntil = qualificationUserValidUntil
, transactionQualificationScheduleRenewal = mbScheduleRenewal
}
renewQualificationUsers :: QualificationId -> [UserId] -> DB Int
renewQualificationUsers qid uids = do
--TODO: user updateWhere Count instead
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)
-- TODO: AUDIT LOG!!!
-- forM_ uids $ \quid -> audit
return (-1)
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.

11
src/Jobs/Handler/LMS.hs
View File

@ -70,6 +70,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
E.&&. quser E.^. QualificationUserScheduleRenewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue)
E.&&. E.notExists (do
luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
@ -208,12 +209,20 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && isLmsSuccess newStatus
then do
-- TODO: refactor using functions from Handler.Utils.Qualification to ensure nothing is forgotten!
update quid [ QualificationUserValidUntil =. newValidTo
, QualificationUserLastRefresh =. lmsResultSuccess
]
]
update luid [ LmsUserStatus =. Just newStatus
, LmsUserReceived =. Just lmsResultTimestamp
]
audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid
, transactionQualification = qualificationUserQualification
, transactionUser = qualificationUserUser
, transactionQualificationValidUntil = newValidTo
, transactionQualificationScheduleRenewal = Nothing
}
return Nothing
else do
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]

22
src/Utils/Form.hs
View File

@ -848,12 +848,26 @@ cfCI :: (Functor m, CI.FoldCase s) => Field m s -> Field m (CI s)
cfCI = convertField CI.mk CI.original
cfCommaSeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.splitOn ",") (T.intercalate ", " . Set.toList)
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split (==',')) (T.intercalate ", " . Set.toList)
-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", " . Set.toList)
-- where anySeparator :: Char -> Bool
-- anySeparator c = C.isSeparator c || c == ',' || c == ';'
cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", " . Set.toList)
where anySeparator :: Char -> Bool
anySeparator c = C.isSeparator c || c == ',' || c == ';'
cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
where splitConditionally :: Text -> [Text]
splitConditionally t
| ';' `telem` t = T.split (==';') t
| ',' `telem` t = T.split (==',') t
| otherwise = T.split C.isSeparator t
-- Our version of Data.Text does not yet support T.elem
telem :: Char -> Text -> Bool
telem c = T.any (==c)
-- -- TODO: consider using package ordered-containers?
-- cfAnySeparatedList :: (Functor m) => Field m Text -> Field m [Text]