diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg
index 1d76ad70f..6267eff82 100644
--- a/messages/uniworx/categories/qualification/de-de-formal.msg
+++ b/messages/uniworx/categories/qualification/de-de-formal.msg
@@ -86,6 +86,7 @@ QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung un
QualificationActBlockSupervisor: Dauerhaft entziehen und Ansprechpartner entfernen, mit sofortiger Wirkung
QualificationActBlock: Entziehen
QualificationActUnblock: Entzug löschen
+QualificationActRenew: Qualifikation regulär verlängern
QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach.
diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg
index 25de10365..6880fa3ee 100644
--- a/messages/uniworx/categories/qualification/en-eu.msg
+++ b/messages/uniworx/categories/qualification/en-eu.msg
@@ -86,6 +86,7 @@ QualificationSetUnexpire n: Expiry notification and e‑learning activated for #
QualificationActBlockSupervisor: Waive permanently and remove all supervisiors, effective immediately
QualificationActBlock: Revoke
QualificationActUnblock: Clear revocation
+QualificationActRenew: Renew Qualification
QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.
diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs
index 141cc9357..8d693c17f 100644
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@@ -253,21 +253,30 @@ data QualificationTableAction
| QualificationActBlockSupervisor
| QualificationActBlock
| QualificationActUnblock
- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+ | QualificationActRenew
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe QualificationTableAction
instance Finite QualificationTableAction
nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''QualificationTableAction id
--- Not yet needed, since there is no additional data for now:
+{-
+isAdminAct :: QualificationTableAction -> Bool
+isAdminAct QualificationActExpire = False
+isAdminAct QualificationActUnexpire = False
+isAdminAct QualificationActBlockSupervisor = False
+isAdminAct _ = True
+-}
+
data QualificationTableActionData
= QualificationActExpireData
| QualificationActUnexpireData
| QualificationActBlockSupervisorData
- | QualificationActBlockData { qualTableActBlockReason :: Text}
+ | QualificationActBlockData { qualTableActBlockReason :: Text}
| QualificationActUnblockData
- deriving (Eq, Ord, Read, Show, Generic)
+ | QualificationActRenewData
+ deriving (Eq, Ord, Read, Show, Generic)
isExpiryAct :: QualificationTableActionData -> Bool
isExpiryAct QualificationActExpireData = True
@@ -356,15 +365,17 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = 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
- )
+ , single ("avs-card" , FilterColumn . E.mkExistsFilter $ \row criterion ->
+ E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do
+ E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
+ E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
+ E.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text)))
+ `E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text))))
+ )
+ , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
+ | Set.null criteria -> E.true
+ | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
+ )
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
if | Just renewal <- mbRenewal
@@ -375,8 +386,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
- , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
+ , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
+ , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
+ , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
+ , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
, if isNothing mbRenewal then mempty
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
@@ -460,10 +473,11 @@ postQualificationR sid qsh = do
[ singletonMap QualificationActExpire $ pure QualificationActExpireData
, singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData
] ++ bool
- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin Supervisor
- [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData
+ [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor
+ [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions
, singletonMap QualificationActBlock $ QualificationActBlockData
<$> apreq textField (fslI MsgQualificationBlockReason) Nothing
+ , singletonMap QualificationActRenew $ pure QualificationActRenewData
] isAdmin
linkLmsUser = toMaybe isAdmin LmsUserR
linkUserName = bool ForProfileR ForProfileDataR isAdmin
@@ -471,18 +485,8 @@ postQualificationR sid qsh = do
colChoices cmpMap = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserNameModalHdr MsgLmsUser linkUserName
- , colUserEmail
- , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
- companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
- E.orderBy [E.asc (comp E.^. CompanyName)]
- return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
- let companies = intercalate (text2markup ", ") $
- (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
- icnSuper = text2markup " " <> icon IconSupervisor
- pure $ toWgt companies
- , sortable (Just "company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
+ , colUserEmail
+ , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
let icnSuper = text2markup " " <> icon IconSupervisor
cs = [ (cmpName, cmpSpr)
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
@@ -509,7 +513,11 @@ postQualificationR sid qsh = do
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
return (tbl, qent)
- formResult lmsRes $ \case
+ formResult lmsRes $ \case
+ (QualificationActRenewData, selectedUsers) | isAdmin -> do
+ noks <- runDB $ renewValidQualificationUsers qid $ Set.toList selectedUsers
+ addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
+ reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do
let isUnexpire = action == QualificationActUnexpireData
upd <- runDB $ updateWhereCount
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 13c67c30c..8d34c713b 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -163,7 +163,7 @@ fillDb = do
, userAuthentication = pwSimple
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
- , userMatrikelnummer = Just "94094094094"
+ , userMatrikelnummer = Just "12345678"
, userEmail = "S.Jost@Fraport.de"
, userDisplayEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost"
@@ -680,6 +680,10 @@ fillDb = do
void . insert' $ UserAvs (AvsPersonId 4) sbarth 4
void . insert' $ UserAvs (AvsPersonId 5) fhamann 5
void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77
+ void . insert' $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now
+ void . insert' $ UserAvsCard (AvsPersonId 2) (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now
+ void . insert' $ UserAvsCard (AvsPersonId 3) (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now
+ void . insert' $ UserAvsCard (AvsPersonId 4) (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now
let f_descr = Just $ htmlToStoredMarkup [shamlet|Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
let r_descr = Just $ htmlToStoredMarkup [shamlet|
Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]