diff --git a/models/lms.model b/models/lms.model index b3165578e..528ea939b 100644 --- a/models/lms.model +++ b/models/lms.model @@ -49,9 +49,9 @@ QualificationUser user UserId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade validUntil Day - lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False - firstHeld Day -- first time the qualification was earned, should never change - blockedDue Text Maybe -- isJust means that the qualification is currently revoked + 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 -- temporärer Entzug vorsehen -- Begründungsfeld vorsehen UniqueQualificationUser qualification user diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index c20e865db..455076082 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -14,7 +14,7 @@ module Database.Esqueleto.Utils , mkExactFilter, mkExactFilterWith , mkExactFilterLast, mkExactFilterLastWith , mkContainsFilter, mkContainsFilterWith - , mkDayFilter, mkDayBetweenFilter + , mkDayFilter, mkDayFilterFrom, mkDayFilterTo , mkExistsFilter , anyFilter, allFilter , orderByList @@ -269,12 +269,20 @@ mkDayFilter lenslike row criterias | otherwise = true -mkDayBetweenFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element +mkDayFilterFrom :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element -> t -- ^ query row - -> Last (Day,Day) -- ^ a day range to filter for + -> Last Day -- ^ a day range to filter for -> E.SqlExpr (E.Value Bool) -mkDayBetweenFilter lenslike row criterias - | Last (Just (from,to)) <- criterias = day (lenslike row) `E.between` (E.val from, E.val to) +mkDayFilterFrom lenslike row criterias + | Last (Just crit) <- criterias = day (lenslike row) E.>=. E.val crit + | otherwise = true + +mkDayFilterTo :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Last Day -- ^ a day range to filter for + -> E.SqlExpr (E.Value Bool) +mkDayFilterTo lenslike row criterias + | Last (Just crit) <- criterias = day (lenslike row) E.<=. E.val crit | otherwise = true diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 5574b9418..dc926f280 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -178,7 +178,7 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. , ltcValidUntil :: Day , ltcLastRefresh :: Day , ltcFirstHeld :: Day - , ltcBlockedDue :: Maybe Text + , ltcBlockedDue :: Maybe QualificationBlocked , ltcLmsIdent :: Maybe LmsIdent , ltcLmsStatus :: Maybe LmsStatus , ltcLmsStarted :: Maybe UTCTime @@ -364,12 +364,13 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true ) - , single ("lms-notified", FilterColumn $ \(view (to queryLmsUser) -> luser) criterion -> - case getLast criterion of - Just True -> E.isJust $ luser E.?. LmsUserNotified - Just False -> E.isNothing $ luser E.?. LmsUserNotified - Nothing -> E.true - ) + , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) + --, single ("lms-notified", FilterColumn $ \(view (to queryLmsUser) -> luser) criterion -> + -- case getLast criterion of + -- Just True -> E.isJust $ luser E.?. LmsUserNotified + -- Just False -> E.isNothing $ luser E.?. LmsUserNotified + -- Nothing -> E.true + -- ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev @@ -458,7 +459,7 @@ postLmsR sid qsh = do , 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 "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d - , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> t) -> foldMap textCell t + , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b , sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid , sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 1c0034189..31a157e9b 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -315,4 +315,8 @@ lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls) where ic | isLmsSuccess ls = IconOK - | otherwise = IconNotOK \ No newline at end of file + | otherwise = IconNotOK + +qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a +qualificationBlockedCell Nothing = mempty +qualificationBlockedCell (Just qb) = iconCell IconBlocked <> msgCell qb <> dayCell (qualificationBlockedDay qb) diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 50f50090c..898395262 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -28,6 +28,7 @@ deriveJSON defaultOptions } ''LmsIdent -- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS? +-- ...also see similar type QualificationBlocked data LmsStatus = LmsBlocked { lmsStatusDay :: Day } | LmsSuccess { lmsStatusDay :: Day } deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) @@ -54,6 +55,28 @@ instance Csv.ToField LmsStatus where toField (LmsSuccess d) = "Success: " <> Csv.toField d +data QualificationBlocked + = QualificationBlockedLms { qualificationBlockedDay :: Day } + | QualificationBlockedAvs { qualificationBlockedDay :: Day } + deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already + , fieldLabelModifier = camelToPathPiece' 2 -- just day suffices for the day field + , omitNothingFields = True + , sumEncoding = TaggedObject "lms-status" "lms-result" + } ''QualificationBlocked +derivePersistFieldJSON ''QualificationBlocked + +instance Csv.ToField QualificationBlocked where + toField (QualificationBlockedLms d) = "Blocked by LMS: " <> Csv.toField d + toField (QualificationBlockedAvs d) = "Blocked by AVS: " <> Csv.toField d + +-- | ToMessage instance ignores contained timestamp +instance ToMessage QualificationBlocked where + toMessage (QualificationBlockedLms _) = "LMS" + toMessage (QualificationBlockedAvs _) = "AVS" + -- | LMS interface requires Bool to be encoded by 0 or 1 only newtype LmsBool = LmsBool { lms2bool :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable)