Fradrive dbselectif

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

@@ -1,7 +1,7 @@
 HealthReport: Health report
 HealthMatchingClusterConfig: Cluster config matches
 HealthHTTPReachable: Cluster can be reached under the expected URL via HTTP
-HealthLDAPAdmins: Proportion of administrators with LDAP authentication that were acutally found in the LDAP directory
+HealthLDAPAdmins: Proportion of administrators with LDAP authentication that were actually found in the LDAP directory
 HealthSMTPConnect: SMTP server is reachable
 HealthWidgetMemcached: Memcached server is serving widgets correctly
 HealthActiveJobExecutors: Proportion of job workers accepting new jobs

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

@@ -2,26 +2,27 @@ QualificationShort: Kürzel
 QualificationName: Qualifikation
 QualificationDescription: Beschreibung
 QualificationValidDuration: Gültigkeitsdauer
-QualificationAuditDuration: Aufbewahrung Audit Log 
+QualificationAuditDuration: Aufbewahrung Audit Log
 QualificationRefreshWithin: Erneurerungszeitraum
 QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E-Lernens
 QualificationElearningStart: E-Lernen automatisch starten
 TableQualificationCountActive: Aktive
-TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifkation
+TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
 TableQualificationCountTotal: Gesamt
 TableQualificationValidUntil: Gültig bis
-TableQualificationLastRefresh: Zuletzt erneuert 
+TableQualificationLastRefresh: Zuletzt erneuert
 TableQualificationFirstHeld: Erstmalig
 TableLmsUser: Prüfling
 TableLmsIdent: Identifikation
 TableLmsElearning: E-Lernen
 TableLmsPin: E-Lernen Pin
 TableLmsResetPin: Pin zurücksetzen?
+TableLmsDatePin: Pin erstellt
 TableLmsDelete: Löschen?
 TableLmsStaff: Interner Mitarbeiter?
 TableLmsStarted: Begonnen
 TableLmsReceived: Letzte Rückmeldung
-TableLmsEnded: Beended 
+TableLmsEnded: Beended
 TableLmsStatus: Status E-Lernen
 TableLmsSuccess: Bestanden
 TableLmsFailed: Gesperrt
@@ -34,9 +35,9 @@ CsvColumnLmsDelete: Wird der Identifikator in der E-Lernen Plattform bei der nä
 CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.)
 CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC)
 CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
-LmsUserlistInsert: Neuer LMS User 
+LmsUserlistInsert: Neuer LMS User
 LmsUserlistUpdate: LMS User aktualisierung
-LmsResultInsert: Neues LMS Ergebnis 
+LmsResultInsert: Neues LMS Ergebnis
 LmsResultUpdate: LMS Ergebnis aktualisierung
 LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
 LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
@@ -49,4 +50,5 @@ 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"}. 
+LmsPinRenewal n@Int: E-Lernen Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}.
+LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen.

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

@@ -3,20 +3,21 @@ QualificationName: Qualification
 QualificationDescription: Description
 QualificationValidDuration: Validity period
 QualificationAuditDuration: Audit log keept
-QualificationRefreshWithin: Refresh within 
+QualificationRefreshWithin: Refresh within
 QualificationRefreshWithinTooltip: Period before expiry to send a notification or to start e-learning
 QualificationElearningStart: Start e-learning automatically
 TableQualificationCountActive: Active
-TableQualificationCountActiveTooltip: Number of currently valid qualifcation holders
+TableQualificationCountActiveTooltip: Number of currently valid qualification holders
 TableQualificationCountTotal: Total
 TableQualificationValidUntil: Valid until
 TableQualificationLastRefresh: Last renewed
 TableQualificationFirstHeld: First held
 TableLmsUser: Examinee
-TableLmsIdent: Identifier 
+TableLmsIdent: Identifier
 TableLmsPin: E-learning pin
 TableLmsElearning: E-learning
 TableLmsResetPin: Reset pin?
+TableLmsDatePin: Pin created
 TableLmsDelete: Delete?
 TableLmsStaff: Staff?
 TableLmsStarted: Started
@@ -34,7 +35,7 @@ CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom
 CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored)
 CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
 CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
-LmsUserlistInsert: New LMS User 
+LmsUserlistInsert: New LMS User
 LmsUserlistUpdate: Update of LMS User
 LmsResultInsert: New LMS result
 LmsResultUpdate: Update of LMS result
@@ -48,5 +49,6 @@ MailLmsRenewalBody: You will soon need to renew this qualficiation by completing
 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.
+LmsNotificationSend n@Int: E-learning notifications will be sent to #{n} #{pluralENs n "examinee"} by letter post or by email.
-LmsPinRenewal n@Int: E-learning pin replaced randomly for #{n} #{pluralEN n "Examinee" "Examinees"}.
+LmsPinRenewal n@Int: E-learning pin replaced randomly for #{n} #{pluralENs n "examinee"}.
+LmsActionFailed n@Int: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -123,7 +123,7 @@ MenuCourseEventNew: Neuer Kurstermin
 MenuCourseEventEdit: Kurstermin bearbeiten
 MenuLanguage: Sprache
 
-MenuQualifications: Qualifkationen
+MenuQualifications: Qualifikationen
 MenuLms: E-Lernen
 MenuLmsEdit: Bearbeiten E-Lernen
 MenuLmsUsers: Export E-Lernen Benutzer
@@ -133,4 +133,4 @@ MenuLmsUpload: Hochladen
 MenuLmsDirect: Direkter Upload 
 
 MenuApiDocs: API-Dokumentation (Englisch)
-MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
+MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

models/lms.model

@@ -95,6 +95,7 @@ LmsUser
   ident             LmsIdent                    -- must be unique accross all LMS courses!
   pin               Text
   resetPin          Bool          default=false -- should pin be reset?
+  datePin           UTCTime       default=now() -- time pin was created
   status            LmsStatus Maybe             -- open, success or failure; isJust indicates user will be deleted from LMS 
   --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
   started           UTCTime       default=now()

nix/docker/default.nix

@@ -30,7 +30,7 @@ let
             babel-german babel-english booktabs 
             enumitem eurosym koma-script parskip xcolor 
             # required fro LuaTeX 
-            luatexbase unicode-math lualatex-math selnolig
+            luatexbase lualatex-math unicode-math selnolig
             ;
         })      
       # just for manual testing within the pod, may be removef for production?

routes

@@ -277,4 +277,4 @@
 /swagger       SwaggerR              GET      !free
 /swagger.json  SwaggerJsonR          GET      !free
 
-!/*WellKnownFileName WellKnownR GET !free
+!/*WellKnownFileName WellKnownR GET !free

src/Foundation/I18n.hs

@@ -140,6 +140,27 @@ ordinalEN (toMessage -> numStr) = case lastChar of
   where
     lastChar = last <$> fromNullable numStr
 
+
+{-  -- TODO: use this is message eventually
+-- Commonly used plurals 
+data Thing = Person | Examinee
+  deriving (Eq)
+
+thingDE :: Int -> Thing -> Text 
+thingDE num = (tshow num <>) . Text.cons ' ' . thing
+  where 
+    thing :: Thing -> Text
+    thing Person    = pluralDE num "Person"   "Personen"
+    thing Examinee  = pluralDE num "Prüfling" "Prüflinge"
+  
+thingEN :: Int -> Thing -> Text 
+thingEN num t = tshow num <> Text.cons ' ' (thing t)
+  where 
+    thing :: Thing -> Text
+    thing Person    = pluralENs num "person"
+    thing Examinee  = pluralENs num "examinee"
+-}
+
 notDE :: Bool -> Text
 notDE = bool "nicht" ""
 

src/Handler/LMS.hs

@@ -267,6 +267,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
       , 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-datepin" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserDatePin))
       , single ("lms-received", SortColumn $ queryLmsUser  >>> (E.?. LmsUserReceived))
       , single ("lms-ended"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserEnded))
       ]
@@ -330,6 +331,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
 getLmsR,  postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
 getLmsR = postLmsR
 postLmsR sid qsh = do
+  currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
   ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
     qent <- getBy404 $ SchoolQualificationShort sid qsh
     let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
@@ -339,7 +341,7 @@ postLmsR sid qsh = do
           , singletonMap LmsActRenewPin     $ pure LmsActRenewPinData
           ]
         colChoices = mconcat
-          [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
+          [ dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using  function "is"
           , colUserNameLinkHdr MsgTableLmsUser AdminUserR
           , colUserEmail
           , sortable (Just "valid-until")   (i18nCell MsgTableQualificationValidUntil) $ \(   view $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> dayCell d
@@ -348,6 +350,7 @@ postLmsR sid qsh = do
           , 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-datepin")   (i18nLms MsgTableLmsDatePin)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserDatePin  -> d) -> foldMap dateTimeCell        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
           ]
@@ -360,16 +363,23 @@ postLmsR sid qsh = do
 
   formResult lmsRes $ \case
     (action, selectedUsers) -> do --   | isRenewPinAct action || isNotifyAct action -> do
-      runDBJobs $ forM_ selectedUsers $ \uid -> do
+      now <- liftIO getCurrentTime
-        when (isRenewPinAct action) $ do
+      numExaminees <- runDBJobs $ do
-          newPin <- liftIO randomLMSpw
+        okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] []
-          updateBy (UniqueLmsQualificationUser qid uid) [LmsUserPin =. newPin] -- must be within its own runDB
+        forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do
-        when (isNotifyAct action) $ 
+          when (isRenewPinAct action) $ do
-          queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid}
+            newPin <- liftIO randomLMSpw
-      let numExaminees = Set.size selectedUsers
+            update lid [LmsUserPin =. newPin, LmsUserDatePin =. now] -- must be within its own runDB
+          when (isNotifyAct action) $ 
+            queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' }
+        return $ length okUsers
+      let numSelected  = length selectedUsers          
+          diffSelected = numSelected - numExaminees
       when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal       numExaminees
       when (isNotifyAct action)   $ addMessageI Success $ MsgLmsNotificationSend numExaminees
-  
+      when (diffSelected /= 0)    $ addMessageI Warning $ MsgLmsActionFailed     diffSelected
+      redirect currentRoute
+
   let heading = citext2widget $ qualificationName quali
   siteLayout heading $ do
     setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh

src/Handler/Qualification.hs

@@ -186,6 +186,7 @@ mkLmsTable (Entity qid quali) = do
           , 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-datepin")   (i18nLms MsgTableLmsDatePin)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserDatePin  -> d) -> foldMap dateTimeCell        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
           ] 
@@ -201,6 +202,7 @@ mkLmsTable (Entity qid quali) = do
           , 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-datepin" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserDatePin))
           , single ("lms-received", SortColumn $ queryLmsUser  >>> (E.?. LmsUserReceived))
           , single ("lms-ended"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserEnded))
           ]          

src/Handler/Utils/Table/Pagination.hs

@@ -48,7 +48,7 @@ module Handler.Utils.Table.Pagination
   , listCell, listCell', listCellOf, listCellOf'
   , ilistCell, ilistCell', ilistCellOf, ilistCellOf'
   , formCell, DBFormResult(..), getDBFormResult
-  , dbSelect
+  , dbSelect, dbSelectIf
   , (&)
   , cap'
   , module Control.Monad.Trans.Maybe
@@ -1857,11 +1857,31 @@ dbSelect :: forall x h r i a. (Headedness h, Monoid' x)
          -> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
 -- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
 dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ pure ("uw-hide-columns--no-hide","")) $ formCell resLens genIndex genForm
-  where
+  where    
     genForm _ mkUnique = do
       (selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
       return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
 
+-- conditional version of dbSelect producing disabled checkboxes if the condition is not met
+dbSelectIf :: forall x h r i a. (Headedness h, Monoid' x)
+         => Lens' x (FormResult (DBFormResult i a (DBRow r)))
+         -> Setter' a Bool
+         -> (DBRow r -> MForm (HandlerFor UniWorX) i)
+         -> (DBRow r -> Bool) 
+         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
+dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ [("uw-hide-columns--no-hide","")] ) fCell
+  where
+    fCell = formCell resLens genIndex genForm
+    genForm row mkUnique = do
+      (selResult, selWidget) <- mreq checkBoxField ((bool inputDisabled id $ condition row) $ fsUniq mkUnique "select") (Just False) -- produces disabled field, but still checked by master checkbox from header
+      --(selResult, selWidget) <- mreq (bool noField checkBoxField $ condition row) (fsUniq mkUnique "select") (Just False) -- omits field entirely, but also removes master checkbox from header
+      {- Similar to previous: omits field entirely, but also removes master checkbox from header
+      (selResult, selWidget) <- if condition row 
+          then mreq checkBoxField (fsUniq mkUnique "select") (Just False)
+          else return (FormMissing, FieldView "" Nothing "" mempty Nothing False) 
+      -}
+      return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
+
 
 cap' :: ( AsCornice Sortable p r' (DBCell m x) colonnade
         , IsDBTable m x

src/Jobs/Handler/LMS.hs

@@ -90,6 +90,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
             , lmsUserIdent         = lid 
             , lmsUserPin           = lpin 
             , lmsUserResetPin      = False 
+            , lmsUserDatePin       = now
             , lmsUserStatus        = Nothing
             , lmsUserStarted       = now 
             , lmsUserReceived      = Nothing

src/Utils/Form.hs

@@ -95,6 +95,15 @@ _olReadExternal f = \case
   x@OptionList{} -> (\olReadExternal -> x{olReadExternal}) <$> f (olReadExternal x)
   x@OptionListGrouped{} -> (\olReadExternalGrouped -> x{olReadExternalGrouped}) <$> f (olReadExternalGrouped x)
 
+-- if a field is required, but none should be there
+noField :: Monad m => Field m a
+noField = Field{..}
+  where 
+    fieldParse _ _        = return $ Right Nothing
+    fieldView  _ _ _ _ _  = mempty
+    fieldEnctype          = UrlEncoded
+
+
 --------------------
 -- Field Settings --
 --------------------

test/Database/Fill.hs

@@ -485,7 +485,7 @@ fillDb = do
   void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8)
   void . insert' $ QualificationUser svaupel    qid_f (n_day    1) (n_day $ -1) (n_day $  -2)
   void . insert' $ QualificationUser sbarth     qid_f (n_day  400) (n_day $ -40) (n_day $ -1200)
-  void . insert' $ QualificationUser tinaTester qid_f (n_day $ -33) (n_day $ -60) (n_day $ -250)
+  void . insert' $ QualificationUser tinaTester qid_f (n_day    3) (n_day $ -60) (n_day $ -250)
   void . insert' $ QualificationUser gkleen     qid_r (n_day $ -7) (n_day $ -2) (n_day $  -9)
   void . insert' $ QualificationUser maxMuster  qid_r (n_day    1) (n_day $ -1) (n_day $  -2)
   void . insert' $ QualificationUser fhamann    qid_r (n_day $ -3) (n_day $ -1) (n_day $  -2)