diff --git a/CHANGELOG.md b/CHANGELOG.md index 9bef89664..a96495c5c 100644 --- a/CHANGELOG.md +++ b/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) diff --git a/config/settings.yml b/config/settings.yml index 2c7f0bcd5..5d0702621 100644 --- a/config/settings.yml +++ b/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:" -# email: "_env:MAIL_REROUTE_TO_EMAL:" +# name: "_env:MAIL_REROUTE_TO_NAME:Steffen Jost" +# email: "_env:MAIL_REROUTE_TO_EMAL:jost@tcs.ifi.lmu.de" #mail-verp: # separator: "_env:VERP_SEPARATOR:+" # prefix: "_env:VERP_PREFIX:bounce" diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index d9a9b7493..601183d85 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/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 \ No newline at end of file diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 0c889b3f1..4ecbb64e1 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/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 diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index b517d4136..dcc934a38 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/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 diff --git a/models/lms.model b/models/lms.model index cd8b0ec75..9f04a1792 100644 --- a/models/lms.model +++ b/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 diff --git a/nix/docker/default.nix b/nix/docker/default.nix index 23cbb919e..d452f8849 100644 --- a/nix/docker/default.nix +++ b/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 ; diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index 95bdd7303..f757bb1d1 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.0.22" + "version": "27.0.24" } diff --git a/nix/docker/version.json b/nix/docker/version.json index 95bdd7303..f757bb1d1 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.0.22" + "version": "27.0.24" } diff --git a/package-lock.json b/package-lock.json index 381d16519..77bd16777 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.0.22", + "version": "27.0.24", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 947ebea96..4e3c6f592 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.0.22", + "version": "27.0.24", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f8f58ef6c..adbd023a3 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.0.22 +version: 27.0.24 dependencies: - base - yesod diff --git a/shell.nix b/shell.nix index 2327d81fc..af1ccb11a 100644 --- a/shell.nix +++ b/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 - # required for LuaTeX + enumitem eurosym koma-script parskip xcolor dejavu + # required fro LuaTeX luatexbase lualatex-math unicode-math selnolig ; }) diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index fcc6a1f8f..1299a11ef 100644 --- a/src/Audit/Types.hs +++ b/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) } diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 041af20f7..e46bde230 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 7c7aac815..904ce580d 100644 --- a/src/Foundation/Navigation.hs +++ b/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 MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 50) pagOffset + [ defNavLink MsgMenuPageIncrease $ LmsLSR sid qsh (pagLimit + 500) 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 MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 50) pagOffset + [ defNavLink MsgMenuPageIncrease $ LmsLSR sid qsh (pagLimit + 500) pagOffset + , defNavLink MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 500) pagOffset ] } , NavPageActionPrimary diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 0f44e4271..bb3832572 100644 --- a/src/Handler/Admin/Avs.hs +++ b/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 - | Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> - E.exists . E.from $ \(ucomp `E.InnerJoin` comp) -> do - E.on $ ucomp E.^. UserCompanyCompany E.==. comp E.^. CompanyId - E.where_ $ (ucomp E.^. UserCompanyUser E.==. user E.^.UserId) - E.&&. E.any (E.hasInfix (comp E.^. CompanyName)) (E.val <$> Set.toList criteria) + , 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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 8276ca7b8..80986629f 100644 --- a/src/Handler/LMS.hs +++ b/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-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status + , sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid + , 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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 945a27ef9..5dcd6fe1a 100644 --- a/src/Handler/Qualification.hs +++ b/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 diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 7fd0bd7b0..368baebbf 100644 --- a/src/Handler/SAP.hs +++ b/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 = ',' diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 912d0c886..8ece41d3a 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -26,10 +26,11 @@ import Handler.Course.Users data TutorialUserAction - = TutorialUserGrantQualification - | TutorialUserSendMail - | TutorialUserDeregister - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + = TutorialUserRenewQualification + | TutorialUserGrantQualification + | TutorialUserSendMail + | 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 - { tuQualification :: QualificationId - , tuValidUntil :: Day - } - | TutorialUserSendMailData - | TutorialUserDeregisterData{} - deriving (Eq, Ord, Read, Show, Generic) + = TutorialUserRenewQualificationData + { tuQualification :: QualificationId } + | TutorialUserGrantQualificationData + { tuQualification :: QualificationId + , tuValidUntil :: Day + } + | 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]) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 25570eba1..d66aed45e 100644 --- a/src/Handler/Users.hs +++ b/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 - | Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> - E.exists . E.from $ \(ucomp `E.InnerJoin` comp) -> do - E.on $ ucomp E.^. UserCompanyCompany E.==. comp E.^. CompanyId - E.where_ $ (ucomp E.^. UserCompanyUser E.==. user E.^.UserId) - E.&&. E.any (E.hasInfix (comp E.^. CompanyName)) (E.val <$> Set.toList criteria) + , ( "user-company", FilterColumn . E.mkExistsFilter $ \user 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.==. 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) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index db27e663b..091266a06 100644 --- a/src/Handler/Utils/Avs.hs +++ b/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 - pinCard = Set.lookupMax avsPersonPersonCards - userPin = personCard2pin <$> pinCard + userFirmAddr = plaintextToStoredMarkup <$> mbCoFirmAddr + pinCard = Set.lookupMax avsPersonPersonCards + 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 diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index dcb92cdf0..0bf580288 100644 --- a/src/Handler/Utils/LMS.hs +++ b/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 diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index cb9700ad1..ecb1236f4 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/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 - , transactionQualification = qualificationUserQualification - , transactionUser = qualificationUserUser - , transactionQualificationValidUntil = qualificationUserValidUntil + { transactionQualificationUser = quid + , transactionQualification = qualificationUserQualification + , transactionUser = qualificationUserUser + , transactionQualificationValidUntil = qualificationUserValidUntil , transactionQualificationScheduleRenewal = mbScheduleRenewal - } \ No newline at end of file + } + +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. \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index e3b469360..08557753b 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/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 } diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index f5d8af0f3..d5c3c7b86 100644 --- a/src/Utils/Form.hs +++ b/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 ", ") diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index 946e46b8d..9ad2d8280 100644 --- a/templates/letter/din5008.latex +++ b/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} - \item[Login:] \texttt{$login$} - \item[Pin:] \texttt{$pin$} + \begin{labeling}{Password:} + $if(is-de)$ + \item[Benutzer:] \texttt{$login$} + \item[Passwort:] \texttt{$pin$} + $else$ + \item[User:] \texttt{$login$} + \item[Password:] \texttt{$pin$} + $endif$ \end{labeling} ~} \end{textblock}