fix(lms): filter by status

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -127,6 +127,7 @@ LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für
 LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden komplett neu gestartet mit neuem Login und Passwort.
 LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage
 LmsActRestartUnblock: Entzug ggf. aufheben
+LmsStateOpen: E‑Learning offen
 LmsStatusLocked: E‑Learning gesperrt, wird ggf. bald geöffnet
 LmsStatusUnlocked: E‑Learning offen, wird ggf. bald gesperrt
 LmsStatusResetTries: Fehlversuche werden demnächst zurückgesetzt

messages/uniworx/categories/qualification/en-eu.msg

@@ -127,8 +127,9 @@ LmsActRestartWarning: The existing e‑learning will be erased immediately! For
 LmsActRestartExtend: Ensure validity for the next # days
 LmsActRestartUnblock: Undo any revocations
 LmsActRestartFeedback n@Int m@Int: #{n}/#{m} e-learnings were completely restarted with new login credentials.
-LmsStatusLocked: E‑Learning locked, may be opened soon
-LmsStatusUnlocked: E‑Learning still open, may be locked soon
+LmsStateOpen: E‑learning open
+LmsStatusLocked: E‑learning locked, may be opened soon
+LmsStatusUnlocked: E‑learning still open, may be locked soon
 LmsStatusResetTries: Failed attempts will be soon reset
 LmsStatusNotificationSent: E‑learning password has been sent to examinee or supervisor by letter post or by email; e‑learning is currently open
 LmsNotificationSend n: E‑learning notifications will be sent to #{n} #{pluralENs n "examinee"} by letter post or by email.

src/Database/Esqueleto/Utils.hs

@@ -20,6 +20,7 @@ module Database.Esqueleto.Utils
   , subSelectAnd, subSelectOr
   , mkExactFilter, mkExactFilterWith
   , mkExactFilterLast, mkExactFilterLastWith
+  , mkExactFilterMaybeLast
   , mkContainsFilter, mkContainsFilterWith
   , mkDayFilter, mkDayFilterFrom, mkDayFilterTo
   , mkExistsFilter
@@ -292,9 +293,20 @@ mkExactFilterLastWith :: (PersistField b)
                       -> Last a                        -- ^ needle
                       -> E.SqlExpr (E.Value Bool)
 mkExactFilterLastWith cast lenslike row criterias
-  | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
+  | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)  
   | otherwise = true
 
+-- | like `mkExactFilterLast` but deals with Nothing being a filter criterion as well
+mkExactFilterMaybeLast :: PersistField a
+                      => (t -> E.SqlExpr (E.Value (Maybe a)))  -- ^ getter from query to searched element
+                      -> t                                     -- ^ query row
+                      -> Last (Maybe a)                        -- ^ needle
+                      -> E.SqlExpr (E.Value Bool)
+mkExactFilterMaybeLast lenslike row criterias
+  | Last (Just Nothing) <- criterias = E.isNothing $ lenslike row
+  | Last (Just crit)    <- criterias = lenslike row E.==. E.val crit
+  | otherwise   = true
+
 -- | generic filter creation for dbTable
 --   Given a lens-like function, make filter searching for needles in String-like elements
 --   (Keep Set here to ensure that there are no duplicates)

src/Foundation/I18n.hs

@@ -254,6 +254,10 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma
 
 embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3)
 
+instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite
+  renderMessage f ls (Just s) = renderMessage f ls s
+  renderMessage f ls Nothing  = renderMessage f ls MsgLmsStateOpen
+
 instance RenderMessage UniWorX AvsDataCardColor where
   renderMessage _foundation _ls (AvsCardColorMisc t) = Text.cons '*' t
   renderMessage f ls AvsCardColorGrün = renderMessage f ls MsgAvsCardColorGreen

src/Handler/LMS.hs

@@ -473,7 +473,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
     dbtFilter = mconcat
       [ single $ fltrUserNameEmail queryUser
       , single ("ident"   , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
-      , single ("status"  , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.^. LmsUserStatus))
+      , single ("status"  , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus))
       -- , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
       , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
       -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
@@ -518,7 +518,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
       , prismAForm (singletonFilter "ident"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
       , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
       , prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
-      , prismAForm (singletonFilter "status"  . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) optionsFinite :: Field _ LmsStatus) (fslI MsgTableLmsStatus)
+      , prismAForm (singletonFilter "status"  . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
       -- , if isNothing mbRenewal then mempty
       --   else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)      
       ]

src/Model/Types/Lms.hs

@@ -40,7 +40,7 @@ data LmsStatus = LmsExpired
                | LmsSuccess
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite)  
 
--- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- neccessarily moved to Handler.Utils.Lms
+-- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- moved to src/Foundation.hs
 
 deriveJSON  defaultOptions
   { constructorTagModifier = camelToPathPiece' 1      -- remove lms from constructor