fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'fradrive/jost'

Browse Source
This commit is contained in:
Steffen Jost 2024-09-05 17:55:09 +02:00
commit 4959736c90
19 changed files with 281 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -22,6 +22,7 @@ AdminUserPostAddress: Postalische Anschrift
AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
AdminUserNoPassword: Kein Passwort gesetzt
AdminUserPinPassNotIncluded: Hinweis: Das Passwort wird hier zur Bequemlichkeit zusätzlich angezeigt und ist selbstverständlich nicht im originalem Inhalt enthalten.
AdminUserAssimilate: Diesen Benutzer assimilieren von
UserAdded: Benutzer erfolgreich angelegt
UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden

1
messages/uniworx/categories/user/en-eu.msg
View File

@ -22,6 +22,7 @@ AdminUserPostAddress: Postal Address
AdminUserPrefersPostal: Prefers postal letters over email
AdminUserPinPassword: Password used for PDF attachments to emails
AdminUserNoPassword: No password set
AdminUserPinPassNotIncluded: Note: the password is shown here only for convenience, but is not contained in the original content, of course.
AdminUserAssimilate: Assimilate user by another user
UserAdded: Successfully added user
UserCollision: Could not create user due to uniqueness constraint

1
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -153,6 +153,7 @@ MenuCommCenter: Benachrichtigungen
MenuMailCenter: E‑Mails
MenuMailHtml !ident-ok: Html
MenuMailPlain !ident-ok: Text
MenuMailAttachment: Anhang
MenuApiDocs: API-Dokumentation (Englisch)
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

1
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -153,6 +153,7 @@ MenuCommCenter: Notifications
MenuMailCenter: Email
MenuMailHtml: Html
MenuMailPlain: Text
MenuMailAttachment: Attachment
MenuApiDocs: API documentation
MenuSwagger: OpenAPI 2.0 (Swagger)

1
messages/uniworx/utils/utils/de-de-formal.msg
View File

@ -83,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hie
AmbiguousEmail: E-Mail-Adresse nicht eindeutig
InvalidEmailAddress: E-Mail-Adresse ist ungültig
InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
MailFileAttachment: Dateianhang
UtilExamResultGrade: Note
UtilExamResultPass: Bestanden/Nicht Bestanden
UtilExamResultNoShow: Nicht erschienen

1
messages/uniworx/utils/utils/en-eu.msg
View File

@ -83,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email
AmbiguousEmail: Email address is ambiguous
InvalidEmailAddress: Email address is invalid
InvalidEmailAddressWith e: Email asdress #{show e} is invalid
MailFileAttachment: Attached file
UtilExamResultGrade: Grade
UtilExamResultPass: Passed/Failed
UtilExamResultNoShow: Not present

1
routes
View File

@ -82,6 +82,7 @@
/comm/email MailCenterR GET POST
/comm/email/html/#CryptoUUIDSentMail MailHtmlR GET
/comm/email/plain/#CryptoUUIDSentMail MailPlainR GET
/comm/email/attachment/#CryptoUUIDSentMail/#Text MailAttachmentR GET
/print PrintCenterR GET POST !system-printer
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer

1
src/Foundation/Navigation.hs
View File

@ -134,6 +134,7 @@ breadcrumb CommCenterR = i18nCrumb MsgMenuCommCenter Nothing
breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter $ Just CommCenterR
breadcrumb MailHtmlR{} = i18nCrumb MsgMenuMailHtml $ Just MailCenterR
breadcrumb MailPlainR{} = i18nCrumb MsgMenuMailPlain $ Just MailCenterR
breadcrumb (MailAttachmentR mid _) = i18nCrumb MsgMenuMailAttachment $ Just $ MailHtmlR mid
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc $ Just CommCenterR
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR

102
src/Handler/Admin/Avs.hs
View File

@ -266,33 +266,103 @@ postAdminAvsR = do
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
mbQryLic <- case qryLicRes of
Nothing -> return Nothing
(mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
Nothing -> return mempty
(Just BtnCheckLicences) -> do
res <- try $ do
allLicences <- avsQueryNoCache AvsQueryGetAllLicences
computeDifferingLicences allLicences
case res of
basediffs <- case res of
(Right diffs) -> do
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
r_grant = showLics AvsLicenceRollfeld
f_set = showLics AvsLicenceVorfeld
revoke = showLics AvsNoLicence
let showLics l =
let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
in if Set.null chgs
then ("[ ]", 0)
else (Text.intercalate ", " (tshow . avsLicencePersonID <$> Set.toList chgs), Set.size chgs)
(r_grant, rg_size) = showLics AvsLicenceRollfeld
(f_set , fs_size) = showLics AvsLicenceVorfeld
(revoke , rv_size) = showLics AvsNoLicence
return $ Just [whamlet|
<h2>Licence check differences:
<h3>Grant R:
<p>
#{r_grant}
<h3>Set to F:
<p>
#{f_set}
<h3>Revoke licence:
<p>
#{revoke}
<dl .deflist>
<dt .deflist__dt>Grant R (#{rg_size}):
<dd .deflist__dd>#{r_grant}
<dt .deflist__dt>Set to F (#{fs_size}):
<dd .deflist__dd>#{f_set}
<dt .deflist__dt>Revoke licence (#{rv_size}):
<dd .deflist__dd>#{revoke}
|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
autoDiffs <- do
-- what follows is copy of the code from Jobs.Handler.SynchroniseAvs.dispatchJobSynchroniseAvsLicences modified to not do anything actually
AvsLicenceSynchConf
{ avsLicenceSynchLevel = synchLevel -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
, avsLicenceSynchReasonFilter = reasonFilter
, avsLicenceSynchMaxChanges = maxChanges
} <- getsYesod $ view _appAvsLicenceSynchConf
guardMonoidM (synchLevel > 0) $ do
let showApids apids
| null apids = "[ ]"
| otherwise = Text.intercalate ", " (tshow <$> Set.toList apids)
procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Html
procLic aLic up apids
| n <- Set.size apids, n > 0 =
let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
in if NTop (Just n) <= NTop maxChanges
then
[shamlet|
<dt .deflist__dt>#{subtype} (#{n}):
<dd .deflist__dd>#{showApids apids}
|]
else
[shamlet|
<dt .deflist__dt>#{subtype} (#{n}):
<dd .deflist__dd>Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}
|]
| otherwise = mempty
(AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
-- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
now <- liftIO getCurrentTime
firmBlocks <- runDBRead $ E.select $ do
(uavs :& _qualUser :& qblock) <- X.from $ E.table @UserAvs
`E.innerJoin` E.table @QualificationUser `X.on` (\( uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
`E.innerJoin` E.table @QualificationUserBlock `X.on` (\(_uavs :& qualUser :& qblock) ->
qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
E.&&. qblock `isLatestBlockBefore'` E.val now)
E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
return $ uavs E.^. UserAvsPersonId
return $ Set.fromList $ map E.unValue firmBlocks
let fltrIds
| synchLevel >= 5 = id
| synchLevel >= 3 = flip Set.difference reasonFltrdIds
| otherwise = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
l1 = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence False $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
l2 = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
l3 = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
l4 = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
return $ Just [shamlet|
<h3>
Next automatic AVS licence synchronisation:
<dl .deflist>
^{l4}
^{l3}
^{l2}
^{l1}
$maybe reason <- reasonFilter
<dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
<dd .deflist__dd>#{showApids reasonFltrdIds}
|]
return (basediffs, autoDiffs)
-- (Just BtnSynchLicences) -> do
-- res <- try synchAvsLicences
-- case res of

91
src/Handler/MailCenter.hs
View File

@ -8,6 +8,7 @@ module Handler.MailCenter
( getMailCenterR, postMailCenterR
, getMailHtmlR
, getMailPlainR
, getMailAttachmentR
) where
import Import
@ -163,6 +164,27 @@ postMailCenterR = do
$(widgetFile "mail-center")
typePDF :: ContentType
typePDF = "application/pdf"
getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
getMailAttachmentR cusm attdisp = do
smid <- decrypt cusm
(sm,cn) <- runDBRead $ do
sm <- get404 smid
cn <- get404 $ sm ^. _sentMailContentRef
return (sm,cn)
let mcontent = getMailContent (sentMailContentContent cn)
getAttm alts = case selectAlternative [typePDF] alts of
(Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
| t == attdisp
-> Just pc
_ -> Nothing
attm = firstJust getAttm mcontent
case attm of
(Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
_ -> notFound
getMailHtmlR :: CryptoUUIDSentMail -> Handler Html
getMailHtmlR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml]) [typeHtml,typePlain]
@ -180,6 +202,7 @@ handleMailShow hdr prefTypes cusm = do
setTitleI hdr
let mcontent = getMailContent (sentMailContentContent cn)
getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent
[whamlet|
<section>
<dl .deflist>
@ -214,10 +237,8 @@ handleMailShow hdr prefTypes cusm = do
#{decodeEncodedWord r}
<section>
$forall mc <- mcontent
$maybe pt <- selectAlternative prefTypes mc
<p>
^{part2widget pt}
$forall pt <- mparts
^{part2widget cusm pt}
|]
-- Include for Debugging:
-- <section>
@ -237,24 +258,36 @@ selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
aux [] (pt:_) = Just pt
aux _ [] = Nothing
reorderParts :: [Part] -> [Part]
reorderParts = sortBy pOrder
where
pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2
dispoOrder DefaultDisposition DefaultDisposition = EQ
dispoOrder DefaultDisposition _ = LT
dispoOrder _ DefaultDisposition = GT
dispoOrder (InlineDisposition t1) (InlineDisposition t2) = compare t1 t2
dispoOrder (InlineDisposition _) _ = LT
dispoOrder _ (InlineDisposition _) = GT
dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2
disposition2widget :: Disposition -> Widget
disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
disposition2widget (InlineDisposition n) = [whamlet|<h3>#{n}|]
disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
disposition2widget (InlineDisposition n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
disposition2widget DefaultDisposition = mempty
part2widget :: Part -> Widget
part2widget Part{partContent=NestedParts ps} =
part2widget :: CryptoUUIDSentMail -> Part -> Widget
part2widget cusm Part{partContent=NestedParts ps} =
[whamlet|
<section>
$forall p <- ps
<p>
^{part2widget p}
^{part2widget cusm p}
|]
part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
[whamlet|
<section>
^{disposition2widget dispo}
^{showBody}
^{showPass}
|]
where
showBody
@ -263,8 +296,38 @@ part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partD
| pt == decodeUtf8 typeJson =
let jw :: Aeson.Value -> Widget = jsonWidget
in either str2widget jw $ Aeson.eitherDecodeStrict' pc
| otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
| pt == decodeUtf8 typePDF
, AttachmentDisposition t <- dispo
= [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
| otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
showPass
| pt == decodeUtf8 typePlain
, let cw = T.words $ decodeUtf8 pc
, Just name <- listBracket ("Inhaber","Gültig") cw -- heursitic for dirving licence renewal letters only; improve
<|> listBracket ("Licensee","Valid") cw
= let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
[whamlet|
<section>
$maybe pw <- mbpw
<details>
<summary>
_{MsgAdminUserPinPassword}
<p>
<dl .deflist>
<dt .deflist__dt>
^{userWidget u}
<dd .deflist__dd>
<b>
#{pw}
<p>
_{MsgAdminUserPinPassNotIncluded}
$nothing
_{MsgAdminUserNoPassword}
|]
| otherwise = mempty
------------------------------
-- Decode MIME Encoded Word

104
src/Handler/Utils/Avs.hs
View File

@ -381,7 +381,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
]
-- update company association & supervision
Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
let oldCompanyId = entityKey <$> oldCompanyEnt
@ -445,6 +445,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
-- return pst_up
upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo [usrId] -- ensure firmInfo superior is supervisor for this user
update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2)
update usrId usr_up1 -- update user eventually
update uaId avs_ups -- update stored avsinfo for future updates
@ -587,7 +588,7 @@ upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name
$logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
cmpEnt <- case (mbFirmEnt, mbOldAvsFirmInfo) of
case (mbFirmEnt, mbOldAvsFirmInfo) of
(Nothing, _) -> do -- insert new company, neither AvsId nor Shorthand exist in DB
afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
then return $ newAvsFirmInfo ^. _avsFirmFirmNo
@ -630,8 +631,6 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
_otherwise -> return res_cmp
$logInfoS "AVS" "Update company completed."
return res_cmp2
void $ upsertCompanySuperior cmpEnt newAvsFirmInfo mbOldAvsFirmInfo -- ensure firmInfo superior is supervisor
return cmpEnt
where
firmInfo2key =
CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
@ -644,9 +643,10 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
-- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
]
-- upsert company supervisor from AvsFirmEMailSuperior
upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> DB () -- (Maybe UserId) possibly return superior, but currently not needed
upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi = do
-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> [UserId] -> DB () -- may return superior (Maybe UserId), but currently not needed
upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrs =
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
newAvsNo = newAfi ^. _avsFirmFirmNo
@ -657,49 +657,55 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi =
getOldId = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
unchangedCompany = oldAvsNo == Just newAvsNo
changedSuperior = mbSupEmail /= mbOldEmail -- beware, both could be Nothing
mbSupId <- getSupId
-- delete old superiors, if any
when (unchangedCompany && changedSuperior) $
deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
[ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
-- ensure superior supervision
case mbSupId of
Just supId -> do
-- ensure association between company and superior at equal-to-top priority
prio <- getCompanyUserMaxPrio supId
void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
-- ensure all company associates are irregularly supervised by the superior
E.insertSelectWithConflict UniqueUserSupervisor
(do
usr <- E.from $ E.table @UserCompany
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-- E.&&. E.notExists (do -- restrict to primary company only
-- othr <- E.from $ E.table @UserCompany
-- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
-- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
-- )
return $ UserSupervisor
E.<# E.val supId
E.<&> (usr E.^. UserCompanyUser)
E.<&> E.false
E.<&> E.justVal cid
E.<&> E.val reasonSuperior
)
(\_old _new -> [] -- do not change exisitng supervision
-- [ UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason
-- , UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-- ]
)
when (unchangedCompany && changedSuperior) $ do
oldSupId <- getOldId
reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
Nothing ->
when (unchangedCompany && changedSuperior) $ do
oldSupId <- getOldId
reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
-- 1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
-- 2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
-- 3. unchangedCompany && changedSuperior: update superior for all users
in unless (unchangedCompany && not changedSuperior) $ do -- do nothing if (unchangedCompany && not changedSuperior).
mbSupId <- getSupId
-- delete old superiors, if any
when (unchangedCompany && changedSuperior) $
deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
[ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
unless unchangedCompany $
deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser <-. usrs ]
-- ensure superior supervision
case mbSupId of
Just supId -> do
-- ensure association between company and superior at equal-to-top priority
prio <- getCompanyUserMaxPrio supId
void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
-- ensure all company associates are irregularly supervised by the superior
E.insertSelectWithConflict UniqueUserSupervisor
(do
usr <- E.from $ E.table @UserCompany
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-- E.&&. E.notExists (do -- restrict to primary company only
-- othr <- E.from $ E.table @UserCompany
-- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
-- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
-- )
return $ UserSupervisor
E.<# E.val supId
E.<&> (usr E.^. UserCompanyUser)
E.<&> E.false
E.<&> E.justVal cid
E.<&> E.val reasonSuperior
)
(\_old _new -> [] -- do not change exisitng supervision
-- [ UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason
-- , UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-- ]
)
when (unchangedCompany && changedSuperior) $ do
oldSupId <- getOldId
reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
Nothing ->
when (unchangedCompany && changedSuperior) $ do
oldSupId <- getOldId
reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User) (E.^. UserId) (\usr -> usr E.^. UserId `E.in_` E.vals uids)

16
src/Jobs/Handler/SynchroniseAvs.hs
View File

@ -14,7 +14,7 @@ import Import
import qualified Data.Text as Text
import qualified Data.Set as Set
import qualified Data.Map as Map
-- import qualified Data.Map as Map
import qualified Data.Conduit.List as C
import Database.Esqueleto.Experimental ((:&)(..))
@ -151,7 +151,7 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
procLic aLic up apids
| n <- Set.size apids, n > 0 =
let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
logit errm = runDB $ logInterface' "AVS" subtype False (isJust errm) (Just n) (fromMaybe "Automatic synch" errm)
logit errm = runDB $ logInterface' "AVS" subtype False (isNothing errm) (Just n) (fromMaybe "Automatic synch" errm)
catchAllAvs = flip catch (\err -> logit (Just $ tshow (err :: SomeException)) >> return (-1))
in if NTop (Just n) <= NTop maxChanges
then do
@ -163,7 +163,7 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
(AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
-- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
multiFirmBlocks <- ifNothingM reasonFilter mempty $ \reasons -> do
reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
now <- liftIO getCurrentTime
firmBlocks <- runDBRead $ E.select $ do
(uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs
@ -172,16 +172,14 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
E.&&. qblock `isLatestBlockBefore'` E.val now)
E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (avsLicenceDiffRevokeAll `Set.union` avsLicenceDiffRevokeRollfeld)
E.&&. E.not_ (qblock E.^. QualificationUserBlockUnblock)
E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
return $ uavs E.^. UserAvsPersonId
firmBlockData <- lookupAvsUsers $ Set.fromList $ map E.unValue firmBlocks -- may throw, but we need to abort then
return $ Map.keysSet $ Map.filter hasMultipleFirms firmBlockData
return $ Set.fromList $ map E.unValue firmBlocks
let fltrIds
| synchLevel >= 5 = id
| synchLevel >= 3 = flip Set.difference multiFirmBlocks
| otherwise = flip Set.difference $ multiFirmBlocks `Set.union` rsChanged
| synchLevel >= 3 = flip Set.difference reasonFltrdIds
| otherwise = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
when (synchLevel >= 1) $ procLic AvsNoLicence False $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
when (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld

2
src/Model/Types/Avs.hs
View File

@ -501,9 +501,11 @@ deriveJSON defaultOptions
} ''AvsDataPerson
-}
{- Did not work as intended! Verify, if needed again.
hasMultipleFirms :: AvsDataPerson -> Bool
hasMultipleFirms AvsDataPerson{avsPersonPersonCards=crds} =
1 < Set.size (Set.filter isJust $ Set.map avsDataFirm crds)
-}
data AvsPersonLicence = AvsPersonLicence
{ avsLicenceRampLicence :: AvsLicence

2
src/Model/Types/Misc.hs
View File

@ -69,7 +69,7 @@ data SupervisorReason
-- so do not change values here without a proper migration
instance Show SupervisorReason where
show SupervisorReasonCompanyDefault = "Firmenstandard"
show SupervisorReasonAvsSuperior = "Vorgesetzer"
show SupervisorReasonAvsSuperior = "Vorgesetzter"
show SupervisorReasonUnknown = "Unbekannt"

13
src/Utils.hs
View File

@ -813,6 +813,19 @@ checkAsc :: Ord a => [a] -> Bool
checkAsc (x:r@(y:_)) = x<=y && checkAsc r
checkAsc _ = True
-- return a part of a list between two given elements, if it exists
listBracket :: Eq a => (a,a) -> [a] -> Maybe [a]
listBracket _ [] = Nothing
listBracket b@(s,e) (h:t)
| s == h = listUntil [] t
| otherwise = listBracket b t
where
listUntil _ [] = Nothing
listUntil l1 (h1:t1)
| e == h1 = Just $ reverse l1
| otherwise = listUntil (h1:l1) t1
----------
-- Sets --
----------

3
templates/avs.hamlet
View File

@ -35,6 +35,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$maybe answer <- mbQryLic
<p>
^{answer}
$maybe autodiffs <- mbAutoDiffs
<p>
#{autodiffs}
<section>
<p>

28
templates/i18n/avs-synchronisation/de-de-formal.hamlet
View File

@ -50,27 +50,27 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$if notNull avsLicenceSynchTimes
<section>
<h2>
Automatische AVS Fahrlizen Sychronisation
Automatische AVS Fahrlizenzen Sychronisation
<p>
<dl .deflist>
<dt .deflist__dt>
Uhrzeiten Synchronisation
<dd .deflist__dd>
Werktags, weniger Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
Werktags, wenige Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
<dt .deflist__dt>
Synchronisationslevel
<dd .deflist__dd>
#{avsLicenceSynchLevel} #
$case avsLicenceSynchLevel
$of 1
Nur Vorfeld-Fahrberechtigungen entziehen
$of 2
Vorfeld-Fahrberechtigungen entziehen und gewähren
$of 3
Vorfeld-Fahrberechtigungen entziehen und gewähren, #
so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen
$of _
Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren
<strong>#{avsLicenceSynchLevel}: #
$case avsLicenceSynchLevel
$of 1
Nur Vorfeld-Fahrberechtigungen entziehen
$of 2
Vorfeld-Fahrberechtigungen entziehen und gewähren
$of 3
Vorfeld-Fahrberechtigungen entziehen und gewähren, #
so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen
$of _
Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren
$maybe reasons <- avsLicenceSynchReasonFilter
<dt .deflist__dt>
Ausnahmen
@ -80,4 +80,4 @@ $if notNull avsLicenceSynchTimes
<dt .deflist__dt>
Maximal Änderungen
<dd .deflist__dd>
Keine Synchronisation durchführen, wenn es mehr als #{maxChange} Änderungen pro Level wären
Keine Synchronisation eines Levels durchführen, welches mehr als #{maxChange} Änderungen hätte

22
templates/i18n/avs-synchronisation/en-eu.hamlet
View File

@ -60,16 +60,16 @@ $if notNull avsLicenceSynchTimes
<dt .deflist__dt>
Synchronisation level
<dd .deflist__dd>
#{avsLicenceSynchLevel} #
$case avsLicenceSynchLevel
$of 1
Revoke apron driving licences only
$of 2
Grant and revoke apron driving licences only
$of 3
Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences
$of _
Grant and revoke all driving licences automatically
<strong>#{avsLicenceSynchLevel}: #
$case avsLicenceSynchLevel
$of 1
Revoke apron driving licences only
$of 2
Grant and revoke apron driving licences only
$of 3
Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences
$of _
Grant and revoke all driving licences automatically
$maybe reasons <- avsLicenceSynchReasonFilter
<dt .deflist__dt>
Exemptions
@ -79,4 +79,4 @@ $if notNull avsLicenceSynchTimes
<dt .deflist__dt>
Max changes
<dd .deflist__dd>
Do not synchronize a licence if the number of changes exceeds #{maxChange}
Do not synchronize a licence level if the number of changes exceeds #{maxChange}

8
test/Database/Fill.hs
View File

@ -113,10 +113,10 @@ fillDb = do
, userMobile = Nothing
, userCompanyPersonalNumber = Just "00000"
, userCompanyDepartment = Nothing
, userPinPassword = Nothing
, userPinPassword = Just "1234.5"
, userPostAddress = Just $ markdownToStoredMarkup ("Büro 127 \nMathematisches Institut der Ludwig-Maximilians-Universität München \nTheresienstr. 39 \nD-80333 München"::Text)
, userPostLastUpdate = Nothing
, userPrefersPostal = True
, userPrefersPostal = False
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
}
@ -202,7 +202,7 @@ fillDb = do
, userPinPassword = Nothing
, userPostAddress = Nothing
, userPostLastUpdate = Nothing
, userPrefersPostal = True
, userPrefersPostal = False
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
}
@ -766,7 +766,7 @@ fillDb = do
void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) True (n_day' $ -9) -- TODO: better dates!
void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
void . insert' $ QualificationUser jost qid_rp (n_day 999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day 33) (n_day $ -4) (n_day $ -20) True (n_day' $ -9)
qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day 10) (n_day $ -40) (n_day $ -120) True (n_day' $ -20)
void . insert $ QualificationUserBlock qfkleen False (n_day' 1) "Future block" (Just svaupel)
void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) False (n_day' $ -1)
qfvaupel <- insert' $ QualificationUser svaupel qid_f (n_day 2) (n_day $ -1) (n_day $ -2) True (n_day' $ -9)