Fradrive dbselectif

2022-06-10 19:12:07 +02:00 · 2022-06-10 19:12:07 +02:00 · dd8910c3c4
commit dd8910c3c4
parent 99e39bc27a
14 changed files with 98 additions and 30 deletions
--- a/messages/uniworx/categories/health/en-eu.msg
+++ b/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
--- a/messages/uniworx/categories/qualification/de-de-formal.msg
+++ b/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.
--- a/messages/uniworx/categories/qualification/en-eu.msg
+++ b/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.
-LmsPinRenewal n@Int: E-learning pin replaced randomly for #{n} #{pluralEN n "Examinee" "Examinees"}.
+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} #{pluralENs n "examinee"}.
+LmsActionFailed n@Int: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
--- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg
+++ b/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)
--- a/models/lms.model
+++ b/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()
--- a/nix/docker/default.nix
+++ b/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?
--- a/2
+++ b/2
@ -277,4 +277,4 @@
 /swagger       SwaggerR              GET      !free
 /swagger.json  SwaggerJsonR          GET      !free

-!/*WellKnownFileName WellKnownR GET !free
+!/*WellKnownFileName WellKnownR GET !free
--- a/src/Foundation/I18n.hs
+++ b/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" ""

--- a/src/Handler/LMS.hs
+++ b/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
-        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
+      now <- liftIO getCurrentTime
+      numExaminees <- runDBJobs $ do
+        okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] []
+        forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do
+          when (isRenewPinAct action) $ do
+            newPin <- liftIO randomLMSpw
+            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
--- a/src/Handler/Qualification.hs
+++ b/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))
          ]          
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/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
--- a/src/Jobs/Handler/LMS.hs
+++ b/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
--- a/src/Utils/Form.hs
+++ b/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 --
 --------------------
--- a/test/Database/Fill.hs
+++ b/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)