chore(lms): add field for suspending qualifications

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
+  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        Text Maybe              -- isJust means that the qualification is currently revoked
+  blockedDue        QualificationBlocked Maybe    -- isJust means that the qualification is currently revoked
   -- temporärer Entzug vorsehen
   -- Begründungsfeld vorsehen 
   UniqueQualificationUser qualification user

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 
+mkDayFilterFrom lenslike row criterias 
-  | Last (Just (from,to)) <- criterias = day (lenslike row) `E.between` (E.val from, E.val to) 
+  | 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
 
 

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 ->
+      , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
-          case getLast criterion of
+      --, single ("lms-notified", FilterColumn $ \(view (to queryLmsUser) -> luser) criterion ->
-            Just True  -> E.isJust    $ luser E.?. LmsUserNotified
+      --    case getLast criterion of
-            Just False -> E.isNothing $ luser E.?. LmsUserNotified
+      --      Just True  -> E.isJust    $ luser E.?. LmsUserNotified
-            Nothing    -> E.true
+      --      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

src/Handler/Utils/Table/Cells.hs

@@ -316,3 +316,7 @@ lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls)
   where 
     ic | isLmsSuccess ls = IconOK
        | otherwise       = IconNotOK
+
+qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
+qualificationBlockedCell Nothing   = mempty 
+qualificationBlockedCell (Just qb) = iconCell IconBlocked <> msgCell qb <> dayCell (qualificationBlockedDay qb)

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)