Merge branch 'master' of gitlab.ifi.lmu.de:fradrive/fradrive

CHANGELOG.md

@@ -2,6 +2,16 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [27.0.24](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.0.23...v27.0.24) (2023-02-24)
+
+## [27.0.23](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.0.22...v27.0.23) (2023-02-23)
+
+
+### Bug Fixes
+
+* **avs:** update names from avs too ([e2a8fee](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e2a8feee3b186881fb2b323ed9fd9e0cc93787c8))
+* **print:** disable default filter for print acknowledged ([f0b20a1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f0b20a1b263a072a9811ff677f25e6518d314133))
+
 ## [27.0.22](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.0.21...v27.0.22) (2023-02-10)
 
 

config/settings.yml

@@ -25,8 +25,8 @@ mail-from:
 mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
 mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true"
 #mail-reroute-to: 
-#  name:         "_env:MAIL_REROUTE_TO_NAME:"
+#  name:         "_env:MAIL_REROUTE_TO_NAME:Steffen Jost"
-#  email:        "_env:MAIL_REROUTE_TO_EMAL:"
+#  email:        "_env:MAIL_REROUTE_TO_EMAL:jost@tcs.ifi.lmu.de"
 #mail-verp:
 #  separator:    "_env:VERP_SEPARATOR:+"
 #  prefix:       "_env:VERP_PREFIX:bounce"

messages/uniworx/categories/courses/tutorial/de-de-formal.msg

@@ -45,5 +45,7 @@ TutorialUsersDeregistered count@Int64: #{show count} #{pluralDE count "-Tutorium
 TutorialUserDeregister: Vom Tutorium Abmelden
 TutorialUserSendMail: Mitteilung verschicken
 TutorialUserGrantQualification: Qualifikation vergeben
+TutorialUserRenewQualification: Qualifikation regulär verlängern
+TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert
 TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben
 CommTutorial: Tutorium-Mitteilung

messages/uniworx/categories/courses/tutorial/en-eu.msg

@@ -46,5 +46,7 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
 TutorialUserDeregister: Deregister from tutorial
 TutorialUserSendMail: Send mail
 TutorialUserGrantQualification: Grant Qualification
+TutorialUserRenewQualification: Renew Qualification
+TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
 TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
 CommTutorial: Tutorial message

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -115,7 +115,7 @@ MenuCourseEventNew: New course occurrence
 MenuCourseEventEdit: Edit course occurrence
 MenuLanguage: Language
 
-MenuQualifications: Qualifcations
+MenuQualifications: Qualifications
 MenuLms: E-Learning
 MenuLmsEdit: Edit E-Learning
 MenuLmsUsers: Download E-Learning Users

models/lms.model

@@ -57,7 +57,7 @@ QualificationEdit
 QualificationUser
   user              UserId OnDeleteCascade OnUpdateCascade
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  validUntil        Day
+  validUntil        Day                           -- addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
   lastRefresh       Day                           -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False
   firstHeld         Day                           -- first time the qualification was earned, should never change
   blockedDue        QualificationBlocked Maybe    -- isJust means that the qualification is currently revoked

nix/docker/default.nix

@@ -35,7 +35,7 @@ let
       (texlive.combine {        
           inherit (texlive) scheme-basic 
             babel-german babel-english booktabs textpos
-            enumitem eurosym koma-script parskip xcolor 
+            enumitem eurosym koma-script parskip xcolor dejavu
             # required fro LuaTeX 
             luatexbase lualatex-math unicode-math selnolig
             ;

nix/docker/demo-version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.0.22"
+  "version": "27.0.24"
 }

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.0.22"
+  "version": "27.0.24"
 }

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.0.22",
+  "version": "27.0.24",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.0.22",
+  "version": "27.0.24",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 27.0.22
+version: 27.0.24
 dependencies:
   - base
   - yesod

shell.nix

@@ -282,8 +282,8 @@ in pkgs.mkShell {
         (texlive.combine {
           inherit (texlive) scheme-basic
             babel-german babel-english booktabs textpos
-            enumitem eurosym koma-script parskip xcolor
+            enumitem eurosym koma-script parskip xcolor dejavu
-            # required for LuaTeX
+            # required fro LuaTeX
             luatexbase lualatex-math unicode-math selnolig
             ;
         })

src/Audit/Types.hs

@@ -201,7 +201,7 @@ data Transaction
   | TransactionQualificationUserEdit
     { transactionQualificationUser            :: QualificationUserId
     , transactionQualification                :: QualificationId
-    , transactionUser                         :: UserId
+    , transactionUser                         :: UserId                 -- qualification holder that is updated
     , transactionQualificationValidUntil      :: Day
     , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
     }

src/Database/Esqueleto/Utils.hs

@@ -38,7 +38,7 @@ module Database.Esqueleto.Utils
   , unKey
   , selectCountRows, selectCountDistinct
   , selectMaybe
-  , day, diffDays, diffTimes
+  , day, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
   , module Database.Esqueleto.Utils.TH
@@ -65,6 +65,8 @@ import Crypto.Hash (Digest, SHA256)
 import Data.Coerce (Coercible)
 
 import Data.Time.Clock (NominalDiffTime)
+import Data.Time.Calendar (CalendarDiffDays)
+import Data.Time.Format.ISO8601 (iso8601Show)
 
 import qualified Data.Text.Lazy.Builder as Text.Builder
 
@@ -525,6 +527,14 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
 day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
 day = E.unsafeSqlCastAs "date"
 
+interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=.  requires both types to be the same, so we use Day
+-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example 
+interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
+  where 
+    singleQuote     = Text.Builder.singleton '\''
+    wrapSqlString b = singleQuote <> b <> singleQuote
+
+
 infixl 6 `diffDays`, `diffTimes`
 
 diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)

src/Foundation/Navigation.hs

@@ -2333,15 +2333,15 @@ pageActions (LmsLSR sid qsh pagLimit pagOffset) = return
   [ NavPageActionPrimary
     { navLink = defNavLink MsgMenuPrevPage $ LmsLSR sid qsh pagLimit $ pred pagOffset
     , navChildren = 
-        [ defNavLink MsgMenuPageIncrease $ LmsLSR sid qsh (pagLimit + 50) pagOffset
+        [ defNavLink MsgMenuPageIncrease $ LmsLSR sid qsh (pagLimit + 500) pagOffset
-        , defNavLink MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 50) pagOffset
+        , defNavLink MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 500) pagOffset
         ]
     }
   , NavPageActionPrimary
     { navLink = defNavLink MsgMenuNextPage $ LmsLSR sid qsh pagLimit $ succ pagOffset
     , navChildren = 
-        [ defNavLink MsgMenuPageIncrease $ LmsLSR sid qsh (pagLimit + 50) pagOffset
+        [ defNavLink MsgMenuPageIncrease $ LmsLSR sid qsh (pagLimit + 500) pagOffset
-        , defNavLink MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 50) pagOffset
+        , defNavLink MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 500) pagOffset
         ]
     }
   ,  NavPageActionPrimary

src/Handler/Admin/Avs.hs

@@ -23,6 +23,7 @@ import qualified Data.Map as Map
 
 import Handler.Utils
 import Handler.Utils.Avs
+-- import Handler.Utils.Qualification
 
 import Utils.Avs
 
@@ -546,13 +547,14 @@ mkLicenceTable PaginationParameters{..} dbtIdent aLic apids = do
       dbtFilter = mconcat
         [ single $ fltrUserNameEmail   queryUser
         , single ("validity"           , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work?                
-        , single ( "user-company", FilterColumn $ \(queryUser -> user) criteria -> if
+        , single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> 
-                | Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool)
+              E.from $ \(usrComp `E.InnerJoin` comp) -> do 
-                | otherwise ->
+                let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
-                    E.exists . E.from $ \(ucomp `E.InnerJoin` comp) -> do
+                                (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
-                      E.on $ ucomp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+                    testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
-                      E.where_ $ (ucomp E.^. UserCompanyUser E.==. user E.^.UserId)
+                    testcrit = maybe testname testnumber $ readMay $ CI.original criterion
-                          E.&&.  E.any (E.hasInfix (comp E.^. CompanyName)) (E.val <$> Set.toList criteria)
+                E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+                E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
             )                 
         ]
       dbtFilterUI mPrev = mconcat

src/Handler/LMS.hs

@@ -46,7 +46,7 @@ import Handler.LMS.Userlist as Handler.LMS
 import Handler.LMS.Result   as Handler.LMS
 import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!
 
-import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below?
+-- import Handler.Utils.Qualification (validQualification)
 
 -- avoids repetition of local definitions
 single :: (k,a) -> Map k a
@@ -406,6 +406,7 @@ mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
       , single ("blocked-due"   , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
       , single ("schedule-renew", SortColumn $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))      
       , single ("lms-ident"     , SortColumn $ queryLmsUser  >>> (E.?. LmsUserIdent))
+      , single ("lms-pin"       , SortColumn $ queryLmsUser  >>> (E.?. LmsUserPin))
       , single ("lms-status"    , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
       , single ("lms-started"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))
       , single ("lms-datepin"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserDatePin))
@@ -428,15 +429,31 @@ mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
              | otherwise -> E.true
         )
       , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
+      , single ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
+              E.from $ \usrAvs -> -- do 
+                E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
+                    E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
+                          (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
+      , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
+              E.from $ \(usrComp `E.InnerJoin` comp) -> do 
+                let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
+                                (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
+                    testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
+                    testcrit = maybe testname testnumber $ readMay $ CI.original criterion
+                E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+                E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
+        )                          
       ]
     dbtFilterUI mPrev = mconcat
       [ fltrUserNameEmailHdrUI MsgLmsUser 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 "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
+      , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
       , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
       , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
       , if isNothing mbRenewal then mempty
-        else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
+        else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)      
       ]
     dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
     dbtCsvEncode = Just DBTCsvEncode
@@ -500,12 +517,12 @@ mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
 
 getLmsR,  postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
 getLmsR = postLmsR
-postLmsR sid qsh = redirect $ LmsLSR sid qsh 500 0
+postLmsR sid qsh = redirect $ LmsLSR sid qsh 2000 0
 
 getLmsLSR,  postLmsLSR :: SchoolId -> QualificationShorthand -> Int64 -> Int64 -> Handler Html
 getLmsLSR = postLmsLSR
 postLmsLSR sid qsh nlimit noffset 
-  | nlimit < 0 || noffset < 0 = redirect $ LmsLSR sid qsh 500 0
+  | nlimit < 0 || noffset < 0 = redirect $ LmsLSR sid qsh 2000 0
   | otherwise = do
   isAdmin <- hasReadAccessTo AdminR
   currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
@@ -528,8 +545,10 @@ postLmsLSR sid qsh nlimit noffset
                                                                                     )  $ \(   view $ resultQualUser . _entityVal . _qualificationUserBlockedDue  -> b)  -> qualificationBlockedCell b
           , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal  & cellTooltip MsgTableQualificationNoRenewalTooltip
                                                                                     )  $ \(   view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
-          , sortable (Just "lms-ident")     (i18nCell MsgTableLmsIdent)    $ \(preview $ resultLmsUser  . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
+          , sortable (Just "lms-ident")     (i18nCell MsgTableLmsIdent)    $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
-          , sortable (Just "lms-status")    (i18nCell MsgTableLmsStatus)   $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStatus -> status)            -> foldMap lmsStatusCell $ join status
+          , sortable (Just "lms-pin")       (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
+                                                                         ) $ \(preview $ resultLmsUser . _entityVal . _lmsUserPin                  -> pin) -> foldMap textCell pin
+          , sortable (Just "lms-status")    (i18nCell 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

src/Handler/Qualification.hs

@@ -35,7 +35,7 @@ import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
 
-import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below?
+-- import Handler.Utils.Qualification (validQualification)
 
 -- avoids repetition of local definitions
 single :: (k,a) -> Map k a
@@ -269,12 +269,13 @@ mkQualificationTable ::
               ( Functor h, ToSortable h
               , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool                                        QualificationTableData))) cols
               )
-           => Entity Qualification
+           => Bool
+           -> Entity Qualification
            -> Map QualificationTableAction (AForm Handler QualificationTableActionData)           
            -> cols
            -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
            -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
-mkQualificationTable (Entity qid quali) acts cols psValidator = do
+mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
   svs <- getSupervisees
   now <- liftIO getCurrentTime
   currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute
@@ -284,7 +285,7 @@ mkQualificationTable (Entity qid quali) acts cols psValidator = do
     csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
     dbtIdent :: Text
     dbtIdent = "qualification"
-    fltrSvs = \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
+    fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
     dbtSQLQuery q = qualificationTableQuery qid fltrSvs q
     dbtRowKey = queryUser >>> (E.^. UserId)
     dbtProj = dbtProjFilteredPostId
@@ -379,6 +380,7 @@ getQualificationR,  postQualificationR :: SchoolId -> QualificationShorthand ->
 getQualificationR = postQualificationR
 postQualificationR sid qsh = do
   currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
+  isAdmin <- hasReadAccessTo AdminR
   ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
     qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
     let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
@@ -388,7 +390,7 @@ postQualificationR sid qsh = do
           ]
         colChoices = mconcat
           [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
-          , colUserNameLinkHdr MsgLmsUser AdminUserR
+          , colUserNameLinkHdr MsgLmsUser ForProfileR
           , colUserEmail
           , 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
@@ -403,10 +405,9 @@ postQualificationR sid qsh = do
                                                                                        $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu
           ]
         psValidator = def
-    tbl <- mkQualificationTable qent acts colChoices psValidator
+    tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
     return (tbl, qent)
-
+  
-  isAdmin <- hasReadAccessTo AdminR
   formResult lmsRes $ \case
     _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now
     (action, selectedUsers) | isExpiryAct action -> do 

src/Handler/SAP.hs

@@ -53,11 +53,13 @@ instance ToNamedRecord SapUserTableCsv where
     , "Ausprägung"      Csv..= csvSUTausprägung   
     ]
 
--- | Removes all personalNummer which are not numbers (i.e. excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
+-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
 --   TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo
 sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv]
 sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l 
-               , readMay persNo > Just (0::Int)       -- filter E-accounts for SAP export
+               , let persNoAsInt = readMay persNo
+               , persNoAsInt >= Just (10000::Int)       -- filter E-accounts for SAP export
+               , persNoAsInt <= Just (99999::Int)       -- filter E-accounts for SAP export                                      
                , let res = SapUserTableCsv
                             { csvSUTpersonalNummer = persNo
                             , csvSUTqualifikation  = sapId
@@ -68,8 +70,12 @@ sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value val
                             }
                ]
 
+-- | Deliver all employess with a successful LDAP synch within the last 3 months
 getQualificationSAPDirectR :: Handler TypedContent
 getQualificationSAPDirectR = do
+  now   <- liftIO getCurrentTime  
+  fdate <- formatTime' "%Y%m%d_%H-%M" now 
+  let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
   qualUsers <- runDB $ Ex.select $ do
     (qual :& qualUser :& user) <- 
       Ex.from $ Ex.table @Qualification 
@@ -79,15 +85,15 @@ getQualificationSAPDirectR = do
       `Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId)
     Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId)
         Ex.&&.  E.isJust (user Ex.^. UserCompanyPersonalNumber)
+        Ex.&&.  E.isJust (user Ex.^. UserLastLdapSynchronisation)
+        Ex.&&.  (E.justVal ldap_cutoff Ex.<=. user Ex.^. UserLastLdapSynchronisation)
     return 
       ( user      Ex.^. UserCompanyPersonalNumber
       , qualUser  Ex.^. QualificationUserFirstHeld
       , qualUser  Ex.^. QualificationUserValidUntil
       -- , qualUser  Ex.^. QualificationUserBlockedDue
       , qual      Ex.^. QualificationSapId
-      )
+      )    
-  now   <- liftIO getCurrentTime
-  fdate <- formatTime' "%Y%m%d_%H-%M" now 
   let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
       fmtOpts = def { csvIncludeHeader  = True
                     , csvDelimiter      = ','

src/Handler/Tutorial/Users.hs

@@ -26,10 +26,11 @@ import Handler.Course.Users
 
 
 data TutorialUserAction
-   = TutorialUserGrantQualification
+  = TutorialUserRenewQualification
-   | TutorialUserSendMail
+  | TutorialUserGrantQualification
-   | TutorialUserDeregister
+  | TutorialUserSendMail
-   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  | TutorialUserDeregister
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe TutorialUserAction
 instance Finite TutorialUserAction
@@ -37,13 +38,15 @@ nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''TutorialUserAction id
 
 data TutorialUserActionData
-   = TutorialUserGrantQualificationData
+  = TutorialUserRenewQualificationData
-     { tuQualification :: QualificationId
+    { tuQualification :: QualificationId }
-     , tuValidUntil    :: Day
+  | TutorialUserGrantQualificationData
-     }
+    { tuQualification :: QualificationId
-   | TutorialUserSendMailData
+    , tuValidUntil    :: Day
-   | TutorialUserDeregisterData{}
+    }
-   deriving (Eq, Ord, Read, Show, Generic)
+  | TutorialUserSendMailData
+  | TutorialUserDeregisterData{}
+  deriving (Eq, Ord, Read, Show, Generic)
 
 
 getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
@@ -52,7 +55,7 @@ postTUsersR tid ssh csh tutn = do
   showSex <- getShowSex
   (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
     tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
-    qualifications <- selectList [QualificationSchool ==. ssh] []
+    qualifications <- selectList [QualificationSchool ==. ssh] [Asc QualificationShorthand]
     now <- liftIO getCurrentTime
     let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications)  -- no instance Ord CalendarDiffDays        
         dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
@@ -85,7 +88,11 @@ postTUsersR tid ssh csh tutn = do
           }
       acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
       acts = Map.fromList
-        [ ( TutorialUserGrantQualification
+        [ ( TutorialUserRenewQualification
+          , TutorialUserRenewQualificationData
+            <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing            
+          )
+        , ( TutorialUserGrantQualification
           , TutorialUserGrantQualificationData
             <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
             <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
@@ -103,6 +110,10 @@ postTUsersR tid ssh csh tutn = do
       runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
       addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
       redirect $ CTutorialR tid ssh csh tutn TUsersR
+    (TutorialUserRenewQualificationData{..}, selectedUsers) -> do
+      noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers      
+      addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
+      redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserSendMailData{}, selectedUsers) -> do
         cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
         redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])

src/Handler/Users.hs

@@ -280,13 +280,14 @@ postUsersR = do
                       in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
                 | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
             )
-          , ( "user-company", FilterColumn $ \user criteria -> if
+          , ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
-                | Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool)
+                E.from $ \(usrComp `E.InnerJoin` comp) -> do 
-                | otherwise ->
+                  let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
-                    E.exists . E.from $ \(ucomp `E.InnerJoin` comp) -> do
+                                  (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
-                      E.on $ ucomp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+                      testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
-                      E.where_ $ (ucomp E.^. UserCompanyUser E.==. user E.^.UserId)
+                      testcrit = maybe testname testnumber $ readMay $ CI.original criterion
-                          E.&&.  E.any (E.hasInfix (comp E.^. CompanyName)) (E.val <$> Set.toList criteria)
+                  E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+                  E.where_ $ usrComp E.^. UserCompanyUser    E.==. user E.^. UserId E.&&. testcrit
             )
           , ( "user-supervisor", FilterColumn $ \user criteria -> if
                 | Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool)
@@ -296,6 +297,12 @@ postUsersR = do
                       E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId)
                         E.&&.  E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
             )
+          , ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion ->
+              E.from $ \usrAvs -> -- do 
+                E.where_ $ usrAvs E.^. UserAvsUser      E.==. user E.^.UserId
+                    E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
+                          (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
+            )
           ]
       , dbtFilterUI  = \mPrev -> mconcat
           [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField  (fslI MsgName)
@@ -303,6 +310,7 @@ postUsersR = do
           , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
           -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField  (fslI MsgTableMatrikelNr)          
           , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
+          , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
           , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment)
           , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
           , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)

src/Handler/Utils/Avs.hs

@@ -5,9 +5,11 @@
 {-# LANGUAGE TypeApplications #-}
 
 
+-- Module for functions directly related to the AVS interface,
+-- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification
+
 module Handler.Utils.Avs
-  ( validQualification, validQualification'
+  ( guessAvsUser
-  , guessAvsUser
   , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
   -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
   , AvsLicenceDifferences(..)
@@ -35,6 +37,7 @@ import qualified Data.CaseInsensitive as CI
 import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
 
 import Handler.Utils.Company
+import Handler.Utils.Qualification
 
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
@@ -63,21 +66,7 @@ instance Exception AvsException
   Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
 -}
 
-------------------
--- SQL Snippets --
-------------------
 
-validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
-validQualification nowaday = \qualUser ->
-  (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
-                             ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
-           E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)    -- not blocked            
-
-validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
-validQualification' nowaday qualUser =
-  (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
-                                 ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
-     E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue)    -- not blocked            
 
 
 ------------------
@@ -430,13 +419,19 @@ upsertAvsUserById api = do
         upsertUserCompany uid mbCompany userFirmAddr
       return mbUid
 
-    (Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword
+    (Just (Entity _ UserAvs{userAvsUser=uid})
+      , Just AvsDataPerson{avsPersonPersonCards, avsPersonInternalPersonalNo, avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname}) -> do -- known user, update address and pinPassword
       let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards          
-          userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr
+          userFirmAddr    = plaintextToStoredMarkup <$> mbCoFirmAddr
-          pinCard     = Set.lookupMax avsPersonPersonCards
+          pinCard         = Set.lookupMax avsPersonPersonCards
-          userPin     = personCard2pin <$> pinCard          
+          userPin         = personCard2pin <$> pinCard                    
+      now <- liftIO getCurrentTime
       runDB $ do
-        now <- liftIO getCurrentTime
+        update uid  [ UserFirstName             =. avsFirstName      -- update in case of name changes via AVS; might be changed again through LDAP
+                    , UserSurname               =. avsSurname
+                    , UserDisplayName           =. avsFirstName <> Text.cons ' ' avsSurname
+                    , UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
+                    ]        
         oldCards <- selectList [UserAvsCardPersonId ==. api] []
         let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards
         unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do  -- update postal address, unless the exact address had been seen before

src/Handler/Utils/LMS.hs

@@ -127,7 +127,7 @@ maxLmsUserIdentRetries = 27
 randomText :: MonadIO m => String -> Int -> m Text
 randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
   where
-    num_letters = ['0'..'9'] ++ ['a'..'z']
+    num_letters = ['2'..'9'] ++ ['a'..'k'] ++ ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these
     range       = extra ++ num_letters
 
 --TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though
@@ -150,4 +150,4 @@ randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
 randomLMSpw :: MonadIO m => m Text
 randomLMSpw = randomText extra lengthPassword
   where
-    extra = "+*:=!?#&" -- you cannot distinguish ;: and ., in printed letters
+    extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters

src/Handler/Utils/Qualification.hs

@@ -3,16 +3,54 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 
-
+module Handler.Utils.Qualification
-module Handler.Utils.Qualification 
   ( module Handler.Utils.Qualification
-  ) where 
+  ) where
 
 import Import
 
+-- import Data.Time.Calendar (CalendarDiffDays(..))
+import qualified Database.Esqueleto.Experimental as E   -- might need TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Utils as E
+
+
+
+------------------
+-- SQL Snippets --
+------------------
+
+-- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date
+validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
+validQualification nowaday = \qualUser ->
+  (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
+                             ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
+           E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)    -- not blocked            
+
+validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
+validQualification' nowaday qualUser =
+  (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
+                                 ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
+     E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue)    -- not blocked            
+
+
+selectValidQualifications :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser]
+selectValidQualifications qid mbUids nowaday = 
+  -- nowaday <- utctDay <$> liftIO getCurrentTime
+  E.select $ do 
+    qUser <- E.from $ E.table @QualificationUser
+    E.where_ $  (qUser E.^. QualificationUserQualification E.==. E.val qid)
+          E.&&. validQualification nowaday qUser
+          E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
+    pure qUser
+
+
+------------------------
+-- Complete Functions --
+------------------------
+
 
 upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB ()
-upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do   
+upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
   Entity quid _ <- upsert
     QualificationUser
       { qualificationUserFirstHeld        = qualificationUserLastRefresh
@@ -20,18 +58,46 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
       , qualificationUserScheduleRenewal  = fromMaybe True mbScheduleRenewal
       , ..
       }
-    ( 
+    (
       [ QualificationUserScheduleRenewal    =. scheduleRenewal              | Just scheduleRenewal <- [mbScheduleRenewal]
       ] ++
       [ QualificationUserValidUntil         =. qualificationUserValidUntil
       , QualificationUserLastRefresh        =. qualificationUserLastRefresh
       , QualificationUserBlockedDue         =. Nothing
       ]
-    )    
+    )
   audit TransactionQualificationUserEdit
-    { transactionQualificationUser        = quid
+    { transactionQualificationUser            = quid
-    , transactionQualification            = qualificationUserQualification
+    , transactionQualification                = qualificationUserQualification
-    , transactionUser                     = qualificationUserUser
+    , transactionUser                         = qualificationUserUser
-    , transactionQualificationValidUntil  = qualificationUserValidUntil
+    , transactionQualificationValidUntil      = qualificationUserValidUntil
     , transactionQualificationScheduleRenewal = mbScheduleRenewal
-    }
+    }
+
+renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int
+renewValidQualificationUsers qid uids =
+  -- This code works in principle, but it does not allow audit log entries.
+  -- E.update $ \qu -> do
+  --   E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
+  --   E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
+  --       E.&&.  (qu E.^. QualificationUserUser `E.in_` E.valList uids)
+  get qid >>= \case     
+    Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
+      nowaday <- utctDay <$> liftIO getCurrentTime
+      quEntsAll <- selectValidQualifications qid (Just uids) nowaday     
+      let maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
+          quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
+      forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do 
+        let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil        
+        update quId [ QualificationUserValidUntil   =. newValidTo
+                    , QualificationUserLastRefresh  =. nowaday
+                    ]
+        audit TransactionQualificationUserEdit
+          { transactionQualificationUser            = quId
+          , transactionQualification                = qualificationUserQualification
+          , transactionUser                         = qualificationUserUser
+          , transactionQualificationValidUntil      = newValidTo
+          , transactionQualificationScheduleRenewal = Nothing
+          }
+      return $ length quEnts
+    _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.

src/Jobs/Handler/LMS.hs

@@ -31,6 +31,9 @@ import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries
 import qualified Data.CaseInsensitive as CI
 
 
+blockedByElearning :: Text 
+blockedByElearning = "E-Learning durchgefallen"
+
 dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
 dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
 
@@ -70,6 +73,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                   E.&&. quser E.^. QualificationUserScheduleRenewal
                   E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day
                   E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
+                  E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue)
                   E.&&. E.notExists (do
                           luser <- E.from $ E.table @LmsUser
                           E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
@@ -194,7 +198,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
                         E.&&. luser E.^. LmsUserQualification  E.==. lresult E.^. LmsResultQualification)
           E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
             E.&&.    luser E.^. LmsUserQualification           E.==. E.val qid
-            E.&&. E.isNothing (luser E.^. LmsUserStatus)  -- do not process learners already having a result
+            -- E.&&. E.isNothing (luser E.^. LmsUserStatus)  -- do not process learners already having a result WORKAROUND LMS-Bug: LMS may send blocked & success simultanesouly or within a few hours; in this case, success is the correct meaning
             E.&&. E.isNothing (luser E.^. LmsUserEnded)   -- do not process closed learners
           return (quser, luser, lresult)
         now <- liftIO getCurrentTime
@@ -208,12 +212,24 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
               newValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
           note <- if saneDate && isLmsSuccess newStatus
             then do
-              update quid [ QualificationUserValidUntil  =. newValidTo
+              -- TODO: refactor using functions from Handler.Utils.Qualification to ensure nothing is forgotten!
+              qUsr <- updateGet quid 
+                          [ QualificationUserValidUntil  =. newValidTo
                           , QualificationUserLastRefresh =. lmsResultSuccess
                           ]
+              -- WORKAROUND LMS-Bug: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
+              when (Just blockedByElearning == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $
+                update quid [ QualificationUserBlockedDue =. Nothing ]              
               update luid [ LmsUserStatus   =. Just newStatus
                           , LmsUserReceived =. Just lmsResultTimestamp
-                          ]
+                          ]                          
+              audit TransactionQualificationUserEdit
+                { transactionQualificationUser            = quid
+                , transactionQualification                = qualificationUserQualification
+                , transactionUser                         = qualificationUserUser
+                , transactionQualificationValidUntil      = newValidTo
+                , transactionQualificationScheduleRenewal = Nothing
+                }
               return Nothing
             else do
               let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
@@ -280,7 +296,7 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
             update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
             updateBy (UniqueQualificationUser qid (lmsUserUser luser)) 
               [QualificationUserBlockedDue =. Just (QualificationBlocked { qualificationBlockedDay = blockedDay
-                                                                         , qualificationBlockedReason = "E-Learning durchgefallen" } )]
+                                                                         , qualificationBlockedReason = blockedByElearning } )]
             queueDBJob JobSendNotification
               { jRecipient    = lmsUserUser luser
               , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay }

src/Utils/Form.hs

@@ -848,13 +848,37 @@ cfCI :: (Functor m, CI.FoldCase s) => Field m s -> Field m (CI s)
 cfCI = convertField CI.mk CI.original
 
 cfCommaSeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
-cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.splitOn ",") (T.intercalate ", " . Set.toList)
+cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split (==',')) (T.intercalate ", " . Set.toList)
 
 cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
 cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", " . Set.toList)
   where anySeparator :: Char -> Bool
         anySeparator c = C.isSeparator c || c == ',' || c == ';'
 
+-- Version that splits conditionally whether or not a separator is found:
+-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
+-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
+--   where splitConditionally :: Text -> [Text]
+--         splitConditionally t 
+--           | ';' `telem` t = T.split (==';') t
+--           | ',' `telem` t = T.split (==',') t
+--           | otherwise  = T.split C.isSeparator t 
+--         -- Our version of Data.Text does not yet support T.elem
+--         telem :: Char -> Text -> Bool
+--         telem c = T.any (==c)
+
+
+-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
+-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
+--   where splitConditionally :: Text -> [Text]
+--         splitConditionally t 
+--           | ';' `telem` t = T.split (==';') t
+--           | ',' `telem` t = T.split (==',') t
+--           | otherwise  = T.split C.isSeparator t 
+--         -- Our version of Data.Text does not yet support T.elem
+--         telem :: Char -> Text -> Bool
+--         telem c = T.any (==c)
+
 -- -- TODO: consider using package ordered-containers?
 -- cfAnySeparatedList :: (Functor m) => Field m Text -> Field m [Text]
 -- cfAnySeparatedList = guardField (not . null) . convertField (mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", ")

templates/letter/din5008.latex

@@ -61,7 +61,13 @@ $endif$
   \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc}
   \usepackage[utf8]{inputenc}
   \usepackage{textcomp} % provide euro and other symbols
-\else % if luatex or xetex
+  \usepackage{DejaVuSansMono} % better monofont
+\else 
+  % if luatex or xetex
+  \usepackage{fontspec}
+  \setmonofont{DejaVu Sans Mono}
+\fi 
+
 $if(mathspec)$
   \ifXeTeX
     \usepackage{mathspec}
@@ -139,9 +145,14 @@ $endif$
 
         \begin{textblock}{65}(84,232)%hpos,vpos
             \textcolor{black!39}{ 
-              \begin{labeling}{Login:x}
+              \begin{labeling}{Password:}
-                \item[Login:] \texttt{$login$}
+                $if(is-de)$
-                \item[Pin:]   \texttt{$pin$}
+                  \item[Benutzer:]  \texttt{$login$}
+                  \item[Passwort:]  \texttt{$pin$}
+                $else$
+                  \item[User:]      \texttt{$login$}
+                  \item[Password:]  \texttt{$pin$}
+                $endif$
               \end{labeling}    
               ~}          
         \end{textblock}