diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 2f5b7b4bb..737e627bf 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index e4ec93fff..67ae441d8 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -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 diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 523db3d2d..535db4979 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -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) diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 0dd276ff8..d316e7812 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -153,6 +153,7 @@ MenuCommCenter: Notifications MenuMailCenter: Email MenuMailHtml: Html MenuMailPlain: Text +MenuMailAttachment: Attachment MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 84478dbb9..166aa413a 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 5a30b858b..7c417bb4c 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -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 diff --git a/routes b/routes index 21518dfa5..905e9f817 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 6c33958e3..52e0566f0 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index c3bf0c3f7..916a6158d 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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|

Licence check differences: -

Grant R: -

- #{r_grant} -

Set to F: -

- #{f_set} -

Revoke licence: -

- #{revoke} +

+
Grant R (#{rg_size}): +
#{r_grant} + +
Set to F (#{fs_size}): +
#{f_set} + +
Revoke licence (#{rv_size}): +
#{revoke} |] (Left e) -> do let msg = tshow (e :: SomeException) return $ Just [whamlet|

Licence check error:

#{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| +
#{subtype} (#{n}): +
#{showApids apids} + |] + else + [shamlet| +
#{subtype} (#{n}): +
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| +

+ Next automatic AVS licence synchronisation: +
+ ^{l4} + ^{l3} + ^{l2} + ^{l1} + $maybe reason <- reasonFilter +
Filtered "#{reason}" (#{Set.size reasonFltrdIds}): +
#{showApids reasonFltrdIds} + |] + return (basediffs, autoDiffs) + -- (Just BtnSynchLicences) -> do -- res <- try synchAvsLicences -- case res of diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index 021860b76..f84cf4ec7 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -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|
@@ -214,10 +237,8 @@ handleMailShow hdr prefTypes cusm = do #{decodeEncodedWord r}
- $forall mc <- mcontent - $maybe pt <- selectAlternative prefTypes mc -

- ^{part2widget pt} + $forall pt <- mparts + ^{part2widget cusm pt} |] -- Include for Debugging: --

@@ -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|

Attachment #{n}|] -disposition2widget (InlineDisposition n) = [whamlet|

#{n}|] +disposition2widget (AttachmentDisposition _) = [whamlet|

_{MsgMailFileAttachment}|] +disposition2widget (InlineDisposition n) = [whamlet|

_{MsgMenuMailAttachment} #{n}|] disposition2widget DefaultDisposition = mempty -part2widget :: Part -> Widget -part2widget Part{partContent=NestedParts ps} = +part2widget :: CryptoUUIDSentMail -> Part -> Widget +part2widget cusm Part{partContent=NestedParts ps} = [whamlet| -
$forall p <- ps -

- ^{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|

^{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|#{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|

Not found: #{sdn}|] + Just Entity{entityVal = u@User{userPinPassword=mbpw}} -> + [whamlet| +
+ $maybe pw <- mbpw +
+ + _{MsgAdminUserPinPassword} +

+

+
+ ^{userWidget u} +
+ + #{pw} +

+ _{MsgAdminUserPinPassNotIncluded} + $nothing + _{MsgAdminUserNoPassword} + |] + | otherwise = mempty ------------------------------ -- Decode MIME Encoded Word diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 292fad0df..845874f64 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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) diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 1a3ed10ab..5651f9558 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -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 diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 0c50360be..26c0aad49 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -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 diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index c830bd0f5..91538ff04 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -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" diff --git a/src/Utils.hs b/src/Utils.hs index ceac5a618..201fd54de 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 -- ---------- diff --git a/templates/avs.hamlet b/templates/avs.hamlet index f3c84153f..d52e32446 100644 --- a/templates/avs.hamlet +++ b/templates/avs.hamlet @@ -35,6 +35,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $maybe answer <- mbQryLic

^{answer} + $maybe autodiffs <- mbAutoDiffs +

+ #{autodiffs}

diff --git a/templates/i18n/avs-synchronisation/de-de-formal.hamlet b/templates/i18n/avs-synchronisation/de-de-formal.hamlet index 0c5117f01..502789afc 100644 --- a/templates/i18n/avs-synchronisation/de-de-formal.hamlet +++ b/templates/i18n/avs-synchronisation/de-de-formal.hamlet @@ -50,27 +50,27 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $if notNull avsLicenceSynchTimes

- Automatische AVS Fahrlizen Sychronisation + Automatische AVS Fahrlizenzen Sychronisation

Uhrzeiten Synchronisation
- Werktags, weniger Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes} + Werktags, wenige Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
Synchronisationslevel
- #{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 + #{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
Ausnahmen @@ -80,4 +80,4 @@ $if notNull avsLicenceSynchTimes
Maximal Änderungen
- 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 diff --git a/templates/i18n/avs-synchronisation/en-eu.hamlet b/templates/i18n/avs-synchronisation/en-eu.hamlet index 0eba07f77..06bb9561f 100644 --- a/templates/i18n/avs-synchronisation/en-eu.hamlet +++ b/templates/i18n/avs-synchronisation/en-eu.hamlet @@ -60,16 +60,16 @@ $if notNull avsLicenceSynchTimes
Synchronisation level
- #{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 + #{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
Exemptions @@ -79,4 +79,4 @@ $if notNull avsLicenceSynchTimes
Max changes
- 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} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 268c56c97..6827257e6 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -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)