Merge branch 'master' of gitlab.ifi.lmu.de:fradrive/fradrive
This commit is contained in:
commit
e16b1f9242
10
CHANGELOG.md
10
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)
|
||||
|
||||
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
;
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "27.0.22"
|
||||
"version": "27.0.24"
|
||||
}
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "27.0.22"
|
||||
"version": "27.0.24"
|
||||
}
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.0.22",
|
||||
"version": "27.0.24",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.0.22",
|
||||
"version": "27.0.24",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 27.0.22
|
||||
version: 27.0.24
|
||||
dependencies:
|
||||
- base
|
||||
- yesod
|
||||
|
||||
@ -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
|
||||
;
|
||||
})
|
||||
|
||||
@ -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)
|
||||
}
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 = ','
|
||||
|
||||
@ -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])
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
}
|
||||
|
||||
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.
|
||||
@ -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 }
|
||||
|
||||
@ -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 ", ")
|
||||
|
||||
@ -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}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user