Merge branch 'fradrive/tutorial-overhaul'

This commit is contained in:
Steffen Jost 2023-02-23 22:19:04 +01:00
commit 5a886c9837
14 changed files with 163 additions and 52 deletions

View File

@ -45,5 +45,7 @@ TutorialUsersDeregistered count@Int64: #{show count} #{pluralDE count "-Tutorium
TutorialUserDeregister: Vom Tutorium Abmelden TutorialUserDeregister: Vom Tutorium Abmelden
TutorialUserSendMail: Mitteilung verschicken TutorialUserSendMail: Mitteilung verschicken
TutorialUserGrantQualification: Qualifikation vergeben TutorialUserGrantQualification: Qualifikation vergeben
TutorialUserRenewQualification: Qualifikation regulär verlängern
TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert
TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben
CommTutorial: Tutorium-Mitteilung CommTutorial: Tutorium-Mitteilung

View File

@ -46,5 +46,7 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
TutorialUserDeregister: Deregister from tutorial TutorialUserDeregister: Deregister from tutorial
TutorialUserSendMail: Send mail TutorialUserSendMail: Send mail
TutorialUserGrantQualification: Grant Qualification TutorialUserGrantQualification: Grant Qualification
TutorialUserRenewQualification: Renew Qualification
TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"} TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
CommTutorial: Tutorial message CommTutorial: Tutorial message

View File

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

View File

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

View File

@ -38,7 +38,7 @@ module Database.Esqueleto.Utils
, unKey , unKey
, selectCountRows, selectCountDistinct , selectCountRows, selectCountDistinct
, selectMaybe , selectMaybe
, day, diffDays, diffTimes , day, interval, diffDays, diffTimes
, exprLift , exprLift
, explicitUnsafeCoerceSqlExprValue , explicitUnsafeCoerceSqlExprValue
, module Database.Esqueleto.Utils.TH , module Database.Esqueleto.Utils.TH
@ -65,6 +65,8 @@ import Crypto.Hash (Digest, SHA256)
import Data.Coerce (Coercible) import Data.Coerce (Coercible)
import Data.Time.Clock (NominalDiffTime) import Data.Time.Clock (NominalDiffTime)
import Data.Time.Calendar (CalendarDiffDays)
import Data.Time.Format.ISO8601 (iso8601Show)
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
@ -525,6 +527,14 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
day = E.unsafeSqlCastAs "date" 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 . wrapSqlString . Text.Builder.fromString . iso8601Show
where
singleQuote = Text.Builder.singleton '\''
wrapSqlString b = singleQuote <> b <> singleQuote
infixl 6 `diffDays`, `diffTimes` infixl 6 `diffDays`, `diffTimes`
diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)

View File

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

View File

@ -46,7 +46,7 @@ import Handler.LMS.Userlist as Handler.LMS
import Handler.LMS.Result as Handler.LMS import Handler.LMS.Result as Handler.LMS
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! 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 -- avoids repetition of local definitions
single :: (k,a) -> Map k a single :: (k,a) -> Map k a

View File

@ -35,7 +35,7 @@ import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH 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 -- avoids repetition of local definitions
single :: (k,a) -> Map k a single :: (k,a) -> Map k a
@ -269,12 +269,13 @@ mkQualificationTable ::
( Functor h, ToSortable h ( Functor h, ToSortable h
, AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols
) )
=> Entity Qualification => Bool
-> Entity Qualification
-> Map QualificationTableAction (AForm Handler QualificationTableActionData) -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-> cols -> cols
-> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
-> DB (FormResult (QualificationTableActionData, Set UserId), Widget) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
mkQualificationTable (Entity qid quali) acts cols psValidator = do mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
svs <- getSupervisees svs <- getSupervisees
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute
@ -284,7 +285,7 @@ mkQualificationTable (Entity qid quali) acts cols psValidator = do
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "qualification" dbtIdent = "qualification"
fltrSvs = \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
dbtSQLQuery q = qualificationTableQuery qid fltrSvs q dbtSQLQuery q = qualificationTableQuery qid fltrSvs q
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjFilteredPostId dbtProj = dbtProjFilteredPostId
@ -379,6 +380,7 @@ getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand ->
getQualificationR = postQualificationR getQualificationR = postQualificationR
postQualificationR sid qsh = do postQualificationR sid qsh = do
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
isAdmin <- hasReadAccessTo AdminR
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
@ -388,7 +390,7 @@ postQualificationR sid qsh = do
] ]
colChoices = mconcat colChoices = mconcat
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameLinkHdr MsgLmsUser AdminUserR , colUserNameLinkHdr MsgLmsUser ForProfileR
, colUserEmail , colUserEmail
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
@ -403,10 +405,9 @@ postQualificationR sid qsh = do
$ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu
] ]
psValidator = def psValidator = def
tbl <- mkQualificationTable qent acts colChoices psValidator tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
return (tbl, qent) return (tbl, qent)
isAdmin <- hasReadAccessTo AdminR
formResult lmsRes $ \case formResult lmsRes $ \case
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now
(action, selectedUsers) | isExpiryAct action -> do (action, selectedUsers) | isExpiryAct action -> do

View File

@ -26,10 +26,11 @@ import Handler.Course.Users
data TutorialUserAction data TutorialUserAction
= TutorialUserGrantQualification = TutorialUserRenewQualification
| TutorialUserSendMail | TutorialUserGrantQualification
| TutorialUserDeregister | TutorialUserSendMail
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) | TutorialUserDeregister
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe TutorialUserAction instance Universe TutorialUserAction
instance Finite TutorialUserAction instance Finite TutorialUserAction
@ -37,13 +38,15 @@ nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''TutorialUserAction id embedRenderMessage ''UniWorX ''TutorialUserAction id
data TutorialUserActionData data TutorialUserActionData
= TutorialUserGrantQualificationData = TutorialUserRenewQualificationData
{ tuQualification :: QualificationId { tuQualification :: QualificationId }
, tuValidUntil :: Day | TutorialUserGrantQualificationData
} { tuQualification :: QualificationId
| TutorialUserSendMailData , tuValidUntil :: Day
| TutorialUserDeregisterData{} }
deriving (Eq, Ord, Read, Show, Generic) | TutorialUserSendMailData
| TutorialUserDeregisterData{}
deriving (Eq, Ord, Read, Show, Generic)
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
@ -85,7 +88,11 @@ postTUsersR tid ssh csh tutn = do
} }
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
acts = Map.fromList acts = Map.fromList
[ ( TutorialUserGrantQualification [ ( TutorialUserRenewQualification
, TutorialUserRenewQualificationData
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
)
, ( TutorialUserGrantQualification
, TutorialUserGrantQualificationData , TutorialUserGrantQualificationData
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
@ -103,6 +110,10 @@ postTUsersR tid ssh csh tutn = do
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
redirect $ CTutorialR tid ssh csh tutn TUsersR redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserRenewQualificationData{..}, selectedUsers) -> do
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 (TutorialUserSendMailData{}, selectedUsers) -> do
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])

View File

@ -296,6 +296,12 @@ postUsersR = do
E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId) E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId)
E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria) E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
) )
, ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion ->
E.from $ \usrAvs -> -- do
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^.UserId
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
)
] ]
, dbtFilterUI = \mPrev -> mconcat , dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
@ -303,6 +309,7 @@ postUsersR = do
, prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
-- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr) -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment) , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment)
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)

View File

@ -5,9 +5,11 @@
{-# LANGUAGE TypeApplications #-} {-# 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 module Handler.Utils.Avs
( validQualification, validQualification' ( guessAvsUser
, guessAvsUser
, upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, AvsLicenceDifferences(..) , AvsLicenceDifferences(..)
@ -35,6 +37,7 @@ import qualified Data.CaseInsensitive as CI
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException()) import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
import Handler.Utils.Company import Handler.Utils.Company
import Handler.Utils.Qualification
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma 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? 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
------------------ ------------------

View File

@ -3,13 +3,51 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
module Handler.Utils.Qualification module Handler.Utils.Qualification
( module Handler.Utils.Qualification ( module Handler.Utils.Qualification
) where ) where
import Import import Import
-- import Data.Time.Calendar (CalendarDiffDays(..))
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 :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB ()
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
@ -29,9 +67,37 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
] ]
) )
audit TransactionQualificationUserEdit audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid { transactionQualificationUser = quid
, transactionQualification = qualificationUserQualification , transactionQualification = qualificationUserQualification
, transactionUser = qualificationUserUser , transactionUser = qualificationUserUser
, transactionQualificationValidUntil = qualificationUserValidUntil , transactionQualificationValidUntil = qualificationUserValidUntil
, transactionQualificationScheduleRenewal = mbScheduleRenewal , 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.

View File

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

View File

@ -855,6 +855,19 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m
where anySeparator :: Char -> Bool where anySeparator :: Char -> Bool
anySeparator c = C.isSeparator c || c == ',' || c == ';' anySeparator c = C.isSeparator c || c == ',' || c == ';'
-- Version that splits conditionally whether or not a separator is found:
-- 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) . 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)
-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) -- 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) . splitConditionally) (T.intercalate "; " . Set.toList) -- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
-- where splitConditionally :: Text -> [Text] -- where splitConditionally :: Text -> [Text]