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

@@ -44,4 +44,9 @@ LmsDirectUpload: Direkter Upload für automatisierte Systeme
 LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
 MailSubjectQualificationRenewal qname@Text: Ihre Qualifikation #{qname} muss demnächst erneuert werden
 MailSubjectQualificationExpiry qname@Text: Ihre Qualifikation #{qname} läuft demnächst ab
-MailLmsRenewalBody: Sie müssen diese Qualifikaton demnächst durch einen E-Learning Kurs erneuern.
+MailLmsRenewalBody: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern.
+LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden
+LmsActRenewPin: Neue zufällige E-Lernen PIN zuweisen
+LmsActRenewNotify: Neue zufällige E-Lernen PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden
+LmsNotificationSend n@Int: E-Lernen Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet.
+LmsPinRenewal n@Int: E-Lernen Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. 

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

@@ -44,4 +44,9 @@ LmsDirectUpload: Direct upload for automated Systems
 LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set.
 MailSubjectQualificationRenewal qname@Text: Your qualification #{qname} must be renewed shortly
 MailSubjectQualificationExpiry qname@Text: Your qualification #{qname} expires soon
-MailLmsRenewalBody: You will soon need to renew this qualficiation by completing an e-learning course.
+MailLmsRenewalBody: You will soon need to renew this qualficiation by completing an e-learning course.
+LmsActNotify: Resend e-learning notification by post or email
+LmsActRenewPin: Randomly replace e-learning PIN
+LmsActRenewNotify: Randomly replace e-learning PIN and re-send notification by post or email
+LmsNotificationSend n@Int: E-learning notifications will be sent to #{n} #{pluralEN n "Examinee" "Examinees"} by letter post or by email.
+LmsPinRenewal n@Int: E-learning pin replaced randomly for #{n} #{pluralEN n "Examinee" "Examinees"}.

models/lms.model

@@ -101,7 +101,8 @@ LmsUser
   received          UTCTime Maybe               -- last acknowledgement by LMS 
   ended             UTCTime Maybe               -- ident was deleted from LMS 
   -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this?
-  UniqueLmsUser ident -- idents must be unique accross all qualifications, since idents are global within LMS!
+  UniqueLmsIdent ident                           -- idents must be unique accross all qualifications, since idents are global within LMS!
+  UniqueLmsQualificationUser qualification user  -- each user may be enrolled at most once per course
   deriving Generic
 
 -- LmsUserlist stores LMS upload for later processing only 

src/Handler/LMS.hs

@@ -20,8 +20,10 @@ import Import
 import Jobs
 import Handler.Utils
 -- import Handler.Utils.Csv
--- import Handler.Utils.LMS
+import Handler.Utils.LMS
 
+
+import qualified Data.Set as Set
 import qualified Data.Map as Map
 -- import qualified Data.Csv as Csv
 -- import qualified Data.Conduit.List as C
@@ -38,21 +40,21 @@ import Handler.LMS.Result   as Handler.LMS
 single :: (k,a) -> Map k a
 single = uncurry Map.singleton
 
--- Button only needed here 
+-- Button only needed here
 data ButtonManualLms = LmsEnqueue | LmsDequeue
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonManualLms  
+instance Universe ButtonManualLms
 instance Finite   ButtonManualLms
 
 nullaryPathPiece ''ButtonManualLms camelToPathPiece
 
 instance Button UniWorX ButtonManualLms where
   btnLabel LmsEnqueue = "Enqeue"
-  btnLabel LmsDequeue = "Deqeue"  
+  btnLabel LmsDequeue = "Deqeue"
 
   btnClasses LmsEnqueue = [BCIsButton, BCPrimary]
   btnClasses LmsDequeue = [BCIsButton, BCDefault]
-  
+
 
 getLmsSchoolR :: SchoolId -> Handler Html
 getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)])
@@ -61,26 +63,26 @@ getLmsAllR, postLmsAllR :: Handler Html
 getLmsAllR = postLmsAllR
 postLmsAllR = do
   ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
-  let btnForm = wrapForm btnWdgt def 
+  let btnForm = wrapForm btnWdgt def
         { formAction   = Just $ SomeRoute LmsAllR
         , formEncoding = btnEnctype
         , formSubmit   = FormNoSubmit
         }
-  case btnResult of 
+  case btnResult of
     (FormSuccess LmsEnqueue) -> queueJob' JobLmsQualificationsEnqueue
     (FormSuccess LmsDequeue) -> queueJob' JobLmsQualificationsDequeue
     FormMissing -> return ()
     _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
 
   lmsTable <- runDB $ do
-    view _2 <$> mkLmsAllTable  
+    view _2 <$> mkLmsAllTable
   siteLayoutMsg MsgMenuQualifications $ do
     setTitleI MsgMenuQualifications
     $(widgetFile "lms-all")
 
 type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
 resultAllQualification :: Lens' AllQualificationTableData Qualification
-resultAllQualification = _dbrOutput . _1 . _entityVal 
+resultAllQualification = _dbrOutput . _1 . _entityVal
 
 resultAllQualificationActive :: Lens' AllQualificationTableData Word64
 resultAllQualificationActive = _dbrOutput . _2 . _unValue
@@ -90,46 +92,46 @@ resultAllQualificationTotal  = _dbrOutput . _3 . _unValue
 
 
 mkLmsAllTable :: DB (Any, Widget)
-mkLmsAllTable = do 
+mkLmsAllTable = do
   now <- liftIO getCurrentTime
-  let    
+  let
     resultDBTable = DBTable{..}
       where
-        dbtSQLQuery quali = do         
-          cusers <- pure . Ex.subSelectCount $ do 
+        dbtSQLQuery quali = do
+          cusers <- pure . Ex.subSelectCount $ do
             quser <- Ex.from $ Ex.table @QualificationUser
-            Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId                  
-          cactive <- pure . Ex.subSelectCount $ do 
+            Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
+          cactive <- pure . Ex.subSelectCount $ do
             quser <- Ex.from $ Ex.table @QualificationUser
-            Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId                  
+            Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
                   E.&&. quser Ex.^. QualificationUserValidUntil    Ex.>=. E.val (utctDay now)
-          -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem 
-          return (quali, cactive, cusers)                          
+          -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
+          return (quali, cactive, cusers)
         dbtRowKey = (E.^. QualificationId)
         dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
         dbtColonnade = dbColonnade $ mconcat
           [ colSchool $ resultAllQualification . _qualificationSchool
-          , sortable (Just "qshort")        (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> 
-              let qsh = qualificationShorthand quali in 
+          , sortable (Just "qshort")        (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
+              let qsh = qualificationShorthand quali in
               anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh
-          , sortable (Just "qname")         (i18nCell MsgQualificationName)  $ \(view resultAllQualification -> quali) -> 
+          , sortable (Just "qname")         (i18nCell MsgQualificationName)  $ \(view resultAllQualification -> quali) ->
               let qsh = qualificationShorthand quali
-                  qnm = qualificationName quali 
+                  qnm = qualificationName quali
               in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm
           , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
               maybeCell (qualificationDescription quali) markupCellLargeModal
-          , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ 
+          , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
               foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
           , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgTableDiffDaysTooltip) $
-              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)          
+              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)
           -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin)   $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
-          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) 
+          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
                                                                         $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
-          , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) 
+          , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
                                                                         $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
           , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
                                                                        -- \(view resultAllQualificationTotal  -> n) -> wgtCell $ word2widget n
-          ] 
+          ]
         dbtSorting = mconcat
           [
             sortSchool $ to (E.^. QualificationSchool)
@@ -149,22 +151,8 @@ mkLmsAllTable = do
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
         dbtParams = def
-            {-    = DBParamsForm
-          { dbParamsFormMethod = POST
-          , dbParamsFormAction = Just $ SomeRoute currentRoute
-          , dbParamsFormAttrs  = []
-          , dbParamsFormSubmit = FormSubmit
-          , dbParamsFormAdditional
-              = renderAForm FormStandard
-                   $  (, mempty) . First . Just
-                  <$> multiActionA acts (fslI MsgTableAction) Nothing
-          , dbParamsFormEvaluate = liftHandler . runFormPost
-          , dbParamsFormResult   = id
-          , dbParamsFormIdent    = def
-          }
-          -}
         dbtIdent :: Text
-        dbtIdent = "qualification-overview"        
+        dbtIdent = "qualification-overview"
         dbtCsvEncode = noCsvEncode
         dbtCsvDecode = Nothing
         dbtExtraReps = []
@@ -176,7 +164,7 @@ mkLmsAllTable = do
 
 
 getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsEditR = postLmsEditR 
+getLmsEditR = postLmsEditR
 postLmsEditR = error "TODO"
 
 
@@ -204,98 +192,184 @@ resultUser = _dbrOutput . _2
 resultLmsUser :: Traversal' LmsTableData (Entity LmsUser)
 resultLmsUser = _dbrOutput . _3 . _Just
 
-instance HasEntity LmsTableData User where 
-  hasEntity = resultUser  
+instance HasEntity LmsTableData User where
+  hasEntity = resultUser
 
 instance HasUser LmsTableData where
   hasUser = resultUser . _entityVal
 
-mkLmsTable :: Entity Qualification -> DB (Any, Widget)
-mkLmsTable (Entity qid quali) = do    
+data LmsTableAction = LmsActNotify
+                    | LmsActRenewNotify
+                    | LmsActRenewPin
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe LmsTableAction
+instance Finite LmsTableAction
+nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''LmsTableAction id
+
+-- Not yet needed, since there is no additional data for now:
+data LmsTableActionData = LmsActNotifyData
+                        | LmsActRenewNotifyData
+                        | LmsActRenewPinData                        
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+isNotifyAct :: LmsTableActionData -> Bool
+isNotifyAct LmsActNotifyData      = True
+isNotifyAct LmsActRenewNotifyData = True 
+isNotifyAct LmsActRenewPinData    = False 
+
+isRenewPinAct :: LmsTableActionData -> Bool
+isRenewPinAct LmsActNotifyData      = False
+isRenewPinAct LmsActRenewNotifyData = True 
+isRenewPinAct LmsActRenewPinData    = True 
+
+lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
+                                                               , E.SqlExpr (Entity User)
+                                                               , E.SqlExpr (Maybe (Entity LmsUser))
+                                                               )
+lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
+  E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
+  E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
+          E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause
+  E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification
+  return (qualUser, user, lmsUser)
+
+
+mkLmsTable :: forall h p cols act act'.
+              ( Functor h, ToSortable h
+              , Ord act, PathPiece act, RenderMessage UniWorX act
+              , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool                                        LmsTableData))) cols
+              )
+           => Entity Qualification
+           -> Map act (AForm Handler act')
+           -> (LmsTableExpr -> E.SqlExpr (E.Value Bool))
+           -> cols
+           -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
+           -> DB (FormResult (act', Set UserId), Widget)
+mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
   now <- liftIO getCurrentTime
+  -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route precisely heres
   let
+    currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali)
     nowaday = utctDay now
-    mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday 
-    resultDBTable = DBTable{..}
-      where
-        dbtSQLQuery = runReaderT $ do
-          qualUser  <- asks queryQualUser
-          user      <- asks queryUser
-          lmsUser   <- asks queryLmsUser
-          lift $ do
-            E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
-            E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
-                    E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause
-            E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification                                  
-          return (qualUser, user, lmsUser)
-        dbtRowKey = queryUser >>> (E.^. UserId)
-        dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
-        dbtColonnade = dbColonnade $ mconcat
-          [ colUserNameLinkHdr MsgTableLmsUser AdminUserR
-          , colUserEmail          
+    mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
+    dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q)
+    dbtRowKey = queryUser >>> (E.^. UserId)
+    dbtProj = dbtProjFilteredPostId 
+    dbtColonnade = cols
+    dbtSorting = mconcat
+      [ single $ sortUserNameLink queryUser
+      , single $ sortUserEmail    queryUser
+      , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
+      , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
+      , single ("first-held"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
+      , single ("lms-ident"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserIdent))
+      , single ("lms-status"  , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
+      , single ("lms-started" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))
+      , single ("lms-received", SortColumn $ queryLmsUser  >>> (E.?. LmsUserReceived))
+      , single ("lms-ended"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserEnded))
+      ]
+    dbtFilter = mconcat
+      [ single $ fltrUserNameEmail   queryUser
+      , single ("lms-ident"   , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
+      -- , single ("lms-status"  , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
+      , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
+      , single ("renewal-due" , FilterColumn $ \(view (to queryQualUser) -> quser) criterion ->
+          if | Just renewal <- mbRenewal
+             , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
+                                          E.&&.  quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
+             | otherwise -> E.true
+        )
+      ]
+    dbtFilterUI mPrev = mconcat
+      [ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev
+      , prismAForm (singletonFilter "lms-ident"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
+      -- , prismAForm (singletonFilter "lms-status"  . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
+      , prismAForm (singletonFilter "validity"    . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+      , if isNothing mbRenewal then mempty
+        else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
+      ]
+    dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
+    dbtIdent :: Text
+    dbtIdent = "qualification"
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+    dbtExtraReps = []
+    dbtParams = DBParamsForm
+      { dbParamsFormMethod = POST
+      , dbParamsFormAction = Just $ SomeRoute currentRoute
+      , dbParamsFormAttrs  = []
+      , dbParamsFormSubmit = FormSubmit
+      , dbParamsFormAdditional
+          = renderAForm FormStandard
+               $  (, mempty) . First . Just
+              <$> multiActionA acts (fslI MsgTableAction) Nothing
+      , dbParamsFormEvaluate = liftHandler . runFormPost
+      , dbParamsFormResult   = id
+      , dbParamsFormIdent    = def
+      }
+
+    -- acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
+    -- acts = mconcat
+    --   [ singletonMap LmsActNotify    $ pure LmsActNotifyData
+    --   , singletonMap LmsActRenewPin  $ pure LmsActRenewPinData
+    --   ]
+    postprocess :: FormResult (First act', DBFormResult UserId Bool LmsTableData)
+                -> FormResult (      act', Set UserId)
+    postprocess inp = do
+        (First (Just act), usrMap) <- inp
+        let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
+        return (act, usrSet)
+
+    -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData))
+    -- resultDBTableValidator = def
+      -- & defaultSorting [SortAscBy csvLmsIdent]
+  over _1 postprocess <$> dbTable psValidator DBTable{..}
+
+getLmsR,  postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
+getLmsR = postLmsR
+postLmsR sid qsh = do
+  ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
+    qent <- getBy404 $ SchoolQualificationShort sid qsh
+    let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
+        acts = mconcat
+          [ singletonMap LmsActNotify       $ pure LmsActNotifyData
+          , singletonMap LmsActRenewNotify  $ pure LmsActRenewNotifyData
+          , singletonMap LmsActRenewPin     $ pure LmsActRenewPinData
+          ]
+        colChoices = mconcat
+          [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
+          , colUserNameLinkHdr MsgTableLmsUser AdminUserR
+          , colUserEmail
           , sortable (Just "valid-until")   (i18nCell MsgTableQualificationValidUntil) $ \(   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 "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
-          , sortable (Just "lms-received")  (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser  . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d 
+          , sortable (Just "lms-received")  (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser  . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d
           , sortable (Just "lms-ended")     (i18nLms MsgTableLmsEnded)    $ \(preview $ resultLmsUser  . _entityVal . _lmsUserEnded    -> d) -> foldMap dateTimeCell $ join d
-          ] 
-          where 
-            i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
-            i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
-        dbtSorting = mconcat
-          [ single $ sortUserNameLink queryUser
-          , single $ sortUserEmail    queryUser 
-          , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
-          , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
-          , single ("first-held"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))                    
-          , single ("lms-ident"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserIdent))
-          , single ("lms-status"  , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
-          , single ("lms-started" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))
-          , single ("lms-received", SortColumn $ queryLmsUser  >>> (E.?. LmsUserReceived))
-          , single ("lms-ended"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserEnded))
-          ]          
-        dbtFilter = mconcat
-          [ single $ fltrUserNameEmail   queryUser
-          , single ("lms-ident"   , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
-          -- , single ("lms-status"  , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
-          , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
-          , single ("renewal-due" , FilterColumn $ \(view (to queryQualUser) -> quser) criterion ->
-              if | Just renewal <- mbRenewal
-                 , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
-                                              E.&&.  quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
-                 | otherwise -> E.true
-            )
-          ]          
-        dbtFilterUI mPrev = mconcat 
-          [ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev
-          , prismAForm (singletonFilter "lms-ident"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)          
-          -- , prismAForm (singletonFilter "lms-status"  . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
-          , prismAForm (singletonFilter "validity"    . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
-          , if isNothing mbRenewal then mempty
-            else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
           ]
-        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
-        dbtParams = def
-        dbtIdent :: Text
-        dbtIdent = "qualification"        
-        dbtCsvEncode = noCsvEncode
-        dbtCsvDecode = Nothing
-        dbtExtraReps = []
+          where
+            -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
+            i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
+        psValidator = def
+    tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator
+    return (tbl, qent)
 
-    resultDBTableValidator = def
-      -- & defaultSorting [SortAscBy csvLmsIdent]
-  dbTable resultDBTableValidator resultDBTable
-
-getLmsR,  postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsR = postLmsR
-postLmsR sid qsh = do
-  (lmsTable, quali) <- runDB $ do 
-    qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh 
-    tbl <- view _2 <$> mkLmsTable qent
-    return (tbl, quali)
+  formResult lmsRes $ \case
+    (action, selectedUsers) -> do --   | isRenewPinAct action || isNotifyAct action -> do
+      runDBJobs $ forM_ selectedUsers $ \uid -> do
+        when (isRenewPinAct action) $ do
+          newPin <- liftIO randomLMSpw
+          updateBy (UniqueLmsQualificationUser qid uid) [LmsUserPin =. newPin] -- must be within its own runDB
+        when (isNotifyAct action) $ 
+          queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid}
+      let numExaminees = Set.size selectedUsers
+      when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal       numExaminees
+      when (isNotifyAct action)   $ addMessageI Success $ MsgLmsNotificationSend numExaminees
+  
   let heading = citext2widget $ qualificationName quali
   siteLayout heading $ do
     setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh

src/Handler/LMS/Result.hs

@@ -268,7 +268,7 @@ postLmsResultDirectR sid qsh = do
                 .| decodeCsv
                 .| foldMC (saveResultCsv qid) 0
         case enr of 
-          Left (e :: SomeException) -> do
+          Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
             $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
             return (badRequest400, "Exception: " <> tshow e)
           Right nr -> do