diff --git a/models/users.model b/models/users.model index d01e7d1dc..9b19db75f 100644 --- a/models/users.model +++ b/models/users.model @@ -14,7 +14,7 @@ User json -- Each Uni2work user has a corresponding row in this table; created upon first login. surname UserSurname -- Display user names always through 'nameWidget displayName surname' displayName UserDisplayName - displayEmail UserEmail -- Case-insensitive eMail address, used for sending + displayEmail UserEmail -- Case-insensitive eMail address, used for sending; leave empty for using auto-update CompanyEmail via UserCompany email UserEmail -- Case-insensitive eMail address, used for identification and fallback for sending TODO: make this nullable ident UserIdent -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) @@ -45,8 +45,8 @@ User json -- Each Uni2work user has a corresponding row in this table; create companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available pinPassword Text Maybe -- used to encrypt pins within emails - postAddress StoredMarkup Maybe -- including company name, if any - postLastUpdate UTCTime Maybe -- record postal address updates + postAddress StoredMarkup Maybe -- including company name, if any, but excluding username; leave empty for using auto-update CompanyPostAddress via UserCompany + postLastUpdate UTCTime Maybe -- record postal address updates prefersPostal Bool default=false -- user prefers letters by post instead of email examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default @@ -91,6 +91,8 @@ UserCompany company CompanyId OnDeleteCascade OnUpdateCascade supervisor Bool default=false -- should this user be made supervisor for all _new_ users associated with this company? supervisorReroute Bool default=false -- if supervisor is true, should this supervisor receive email for _new_ company users? + priority Int default=0 -- higher number, higher priority + useCompanyAddress Bool default=true -- if true, CompanyPostalAddress is used if UserPostalAddress is Nothing, respects priority UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once deriving Generic UserSupervisor diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index b00d2dbf9..65d3bbdf7 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -603,7 +603,7 @@ max, min :: PersistField a max a b = bool a b $ b E.>. a min a b = bool a b $ b E.<. a --- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least +-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least; for Bool: t > f greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index aa1893d25..bdf1a3fd5 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -17,7 +17,7 @@ module Handler.Utils.Avs , setLicence, setLicenceAvs, setLicencesAvs , retrieveDifferingLicences, retrieveDifferingLicencesStatus , computeDifferingLicences - , synchAvsLicences + -- , synchAvsLicences , lookupAvsUser, lookupAvsUsers , AvsException(..) , updateReceivers @@ -45,6 +45,7 @@ import Handler.Utils.Company import Handler.Utils.Qualification import Handler.Utils.Memcached +import Database.Persist.Sql (deleteWhereCount) --, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E @@ -76,259 +77,9 @@ instance Exception AvsException -} - - ------------------ -- AVS Handlers -- ------------------ -{- - TODOs - Connect AVS query to LDAP queries for automatic synchronisation: - - add query to Auth.LDAP.campusUserMatr - - add query to Auth.LDAP.campusLogin - - jobs.Handler.dispatchJobSynchroniseLdap - --} - -{- AVS interface only allows collecting all licences at once, thus getLicence should be avoided, see getLicenceByAvsId including a workaround --- Do we need this? --- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB -getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence) -getLicence uid = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ useRunDB $ getBy $ UniqueUserAvsUser uid - AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId - let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences - return (avsLicenceRampLicence <$> ulicence) - -getLicenceDB :: UserId -> DB (Maybe AvsLicence) -getLicenceDB uid = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery - Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid - AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId - let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences - return (avsLicenceRampLicence <$> ulicence) - - --- | Should be avoided, since all licences must be requested at once. -getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => - Set AvsPersonId -> m (Set AvsPersonLicence) -getLicenceByAvsId aids = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery - AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences - return $ Set.filter (\x -> avsLicencePersonID x `Set.member` aids) licences --} - --- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool -setLicence :: (PersistUniqueRead backend, MonadThrow m, - MonadHandler m, HandlerSite m ~ UniWorX, - BaseBackend backend ~ SqlBackend) => - UserId -> AvsLicence -> ReaderT backend m Bool -setLicence uid lic = do - Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid - setLicenceAvs userAvsPersonId lic - -setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => - AvsPersonId -> AvsLicence -> m Bool -setLicenceAvs apid lic = do - let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid } - (1 ==) <$> setLicencesAvs req - - ---setLicencesAvs :: Set AvsPersonLicence -> Handler Bool -setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => - Set AvsPersonLicence -> m Int -setLicencesAvs persLics = do -- exceptT (return 0 <$ addMessage Error . text2Html . tshow) return $ do - AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - aux aqsl 0 persLics - where - aux aqsl batch0_ok pls - | Set.null pls = return batch0_ok - | otherwise = do - let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls - response <- throwLeftM $ aqsl $ AvsQuerySetLicences batch1 - case response of - AvsResponseSetLicencesError{..} -> do - let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage - $logErrorS "AVS" msg - throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus - - AvsResponseSetLicences msgs -> do - let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs - ok_ids = Set.map avsResponsePersonID ok - bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient - batch1_ok = Set.size ok - forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} -> - $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg - -- TODO: Admin Error page - aux aqsl (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?) - - --- | Retrieve all currently valid driving licences and check against our database --- Only react to changes as compared to last seen status in avs.model -synchAvsLicences :: Handler Bool -synchAvsLicences = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - allLicences <- throwLeftM avsQueryGetAllLicences - deltaLicences <- computeDifferingLicences allLicences - setResponse <- setLicencesAvs deltaLicences - let setOk = setResponse == Set.size deltaLicences - if setOk - then $logInfoS "AVS" "FRADrive Licences written to AVS successfully." - else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete." - return setOk - -data AvsLicenceDifferences = AvsLicenceDifferences - { avsLicenceDiffRevokeAll :: Set AvsPersonId -- revoke all driving licences in AVS (set 0) - , avsLicenceDiffGrantVorfeld :: Set AvsPersonId -- grant apron driving licence in AVS (set 1, upgrade from 0) - , avsLicenceDiffRevokeRollfeld :: Set AvsPersonId -- revoke maneuvering area driving licence, but retain apron driving licence (set 1, downgrade from 2) - , avsLicenceDiffGrantRollfeld :: Set AvsPersonId -- grant maneuvering area driving licence (set 2) - } - deriving (Show) - -#ifdef DEVELOPMENT --- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build -#else -avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId -avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions - [ avsLicenceDiffRevokeAll - , avsLicenceDiffGrantVorfeld - , avsLicenceDiffRevokeRollfeld - , avsLicenceDiffGrantRollfeld - ] -#endif - -avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence -avsLicenceDifferences2personLicences AvsLicenceDifferences{..} = - Set.map (AvsPersonLicence AvsNoLicence) avsLicenceDiffRevokeAll - <> Set.map (AvsPersonLicence AvsLicenceVorfeld) avsLicenceDiffGrantVorfeld - <> Set.map (AvsPersonLicence AvsLicenceVorfeld) avsLicenceDiffRevokeRollfeld - <> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld - -computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence) -computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences - -type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard) - -avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard -avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status] - -retrieveDifferingLicences :: Handler AvsLicenceDifferences -retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False - -retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) -retrieveDifferingLicencesStatus = retrieveDifferingLicences' True - -retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) -retrieveDifferingLicences' getStatus = do -#ifdef DEVELOPMENT - avsUsrs <- runDB $ selectList [] [LimitTo 444] - let allLicences = AvsResponseGetLicences $ Set.fromList $ - [ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2 - , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1 - , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts) - , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig) - -- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1 - ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs] -#else - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - allLicences <- throwLeftM avsQueryGetAllLicences -#endif - lDiff <- getDifferingLicences allLicences -#ifdef DEVELOPMENT - let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5" - lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error - fakes = Set.fromList $ - [ AvsStatusPerson (AvsPersonId 77 ) $ Set.singleton $ mkAdpc True AvsCardColorGelb - , AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"] - , AvsStatusPerson (AvsPersonId 5 ) $ Set.fromList [mkAdpc True AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"] - , AvsStatusPerson (AvsPersonId 2 ) $ Set.singleton $ mkAdpc True AvsCardColorGrün - ] <> - [ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ] -#else - let statQry = avsLicenceDifferences2LicenceIds lDiff - lStat <- if getStatus && notNull statQry - then -- throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry -- don't throw up here, licence differences are too important! TODO: Warn in Problem-Handler - avsQueryStatus (AvsQueryStatus statQry) >>= \case - Left err -> do - addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry - return $ AvsResponseStatus mempty - Right res -> return res - else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls -#endif - return (lDiff, avsResponseStatusMap lStat) - - -getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences -getDifferingLicences (AvsResponseGetLicences licences) = do - now <- liftIO getCurrentTime - --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences - -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld - -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either - let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences - rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' - vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' - rollfeld = Set.map avsLicencePersonID rollfeld' - - antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId) - antijoinAvsLicences lic avsLics = fmap unwrapIds $ - E.select $ do - ((_qauli :& _qualUser :& usrAvs) :& excl) <- - E.from $ ( E.table @Qualification - `E.innerJoin` E.table @QualificationUser - `E.on` ( \(quali :& qualUser) -> - (quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) - -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work! - E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence - E.&&. (now `validQualification` qualUser) -- currently valid and not blocked - ) - `E.innerJoin` E.table @UserAvs - `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) - ) `E.fullOuterJoin` E.toValues (set2NonEmpty avsPersonIdZero avsLics) -- left-hand side produces all currently valid matching qualifications - `E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl) - E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join - return (usrAvs E.?. UserAvsPersonId, excl) - - unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId) - unwrapIds = mapBoth (Set.delete avsPersonIdZero) . foldr aux mempty - where - aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor - aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r) - aux _ acc = acc -- should never occur - - ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,) - <$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld - <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld - let setTo0 = vorfRevoke -- revoke driving licences - setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence - setTo1down = rollRevoke Set.\\ vorfRevoke -- revoke maneuvering area licence, but retain apron driving licence - setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence - return AvsLicenceDifferences - { avsLicenceDiffRevokeAll = setTo0 - , avsLicenceDiffGrantVorfeld = setTo1up - , avsLicenceDiffRevokeRollfeld = setTo1down - , avsLicenceDiffGrantRollfeld = setTo2 - } - {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) : - A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem - B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query - C (0,1,0) -> ((x,_),(_,_)) : set F for id - D (0,1,1) -> ((x,_),(x,_)) : set R for id - E (1,0,0) -> ((_,x),(_,_)) : set 0 for id - F (1,0,1) -> ((_,x),(x,_)) : set 0 for id - G (1,1,0) -> ((_,_),(_,_)) : nop - H (1,1,1) -> ((_,_),(x,_)) : set R for id - I (2,0,0) -> ((_,x),(_,x)) : set 0 for id - J (2,0,1) -> ((_,x),(_,_)) : set 0 for id - K (2,1,0) -> ((_,_),(_,x)) : set F for id - L (2,1,1) -> ((_,_),(_,_)) : nop - - PROBLEM: B & H in conflict! (Note that nop is automatic except for case B) - Results: - set to 0: determined by vorfeld-unset -- zuerst - set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset - set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld) - -} -- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; fail-safe, may or may not update existing users, may insert new users -- If an existing User with internal number is found, an AVS query is executed @@ -719,7 +470,7 @@ updateAvsUserByIds apids = do let missing = Set.toList $ Set.difference apids $ Set.map fst res unless (null missing) $ do now <- liftIO getCurrentTime - updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] + updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] -- TODO: last successfull synch return res where procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . runMaybeT $ do @@ -738,7 +489,7 @@ updateAvsUserByIds apids = do , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo ] - eml_up = let -- Comm > Superior > Company > Personal; NOTE: Email update depends simultaneosuly on AvsFirmInfo and AvsPersonInfo + eml_up = let -- Comm > Superior > Company > Personal; NOTE: Email update depends simultaneously on AvsFirmInfo and AvsPersonInfo eml_old = (oldAvsFirmInfo ^. _Just . _avsFirmPrimaryEmail) <|> (oldAvsPersonInfo ^. _Just . _avsInfoPersonEMail) eml_new = (newAvsFirmInfo ^. _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^. _avsInfoPersonEMail) in mkUpdate usr eml_new eml_old $ @@ -753,6 +504,7 @@ updateAvsUserByIds apids = do , UserAvsLastPersonInfo =. Just newAvsPersonInfo , UserAvsLastFirmInfo =. Just newAvsFirmInfo ] + -- lift $ do -- no more maybe here update usrId usr_ups oldCompanyMb <- join <$> (getAvsCompany `traverse` oldAvsFirmInfo) @@ -763,7 +515,12 @@ updateAvsUserByIds apids = do -- case (oldAvsFirmInfo, oldCompanyMb, newCompanyMb) of case oldAvsFirmInfo of _ | oldCompanyId == Just newCompanyId -- company unchanged entirely - -> return () + -> return () + -- TODO: Update UserCompany too + -- TODO #124 Add an old default supervisor to an Admin TODO-List + -- Add function to use a secondary company post address that won't be updated + -- TODO #76 -- aktuelle Firmen löschen + -- TODO #36 (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged -> return () (Just oafi) | ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged @@ -771,9 +528,9 @@ updateAvsUserByIds apids = do _ -- company changed completely -> do let superReasonComDef = tshow SupervisorReasonCompanyDefault - superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.) oldCompanyId - deleteWhere $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter, UserSupervisorReason ~=. superReasonComDef] - E.insertSelectWithConflict + superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.) + _oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter oldCompanyId, UserSupervisorReason ~=. superReasonComDef] + E.insertSelectWithConflict UniqueUserSupervisor ( do userCompany <- E.from $ E.table @UserCompany @@ -787,10 +544,13 @@ updateAvsUserByIds apids = do E.<&> E.justVal superReasonComDef ) (\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists - [ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] + [ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?! , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ] ] ) + _newAPs <- count $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~=. newCompanyId, UserSupervisorReason ~=. superReasonComDef] + -- when (oldAPs > 0 && newAPs <= 0) $ -- TODO: notify admins + -- TODO continue here return () update uaId avs_ups return $ Set.singleton (apid, usrId) @@ -843,3 +603,213 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do , CheckAvsUpdate CompanyPostAddress _avsFirmPostAddress , CheckAvsUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just ] + + +-- Licences +setLicence :: (PersistUniqueRead backend, MonadThrow m, + MonadHandler m, HandlerSite m ~ UniWorX, + BaseBackend backend ~ SqlBackend) => + UserId -> AvsLicence -> ReaderT backend m Bool +setLicence uid lic = do + Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid + setLicenceAvs userAvsPersonId lic + +setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => + AvsPersonId -> AvsLicence -> m Bool +setLicenceAvs apid lic = do + let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid } + (1 ==) <$> setLicencesAvs req + + +--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool +setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => + Set AvsPersonLicence -> m Int +setLicencesAvs = aux 0 + where + aux batch0_ok pls + | Set.null pls = return batch0_ok + | otherwise = do + let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls + response <- avsQueryNoCache $ AvsQuerySetLicences batch1 + case response of + AvsResponseSetLicencesError{..} -> do + let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage + $logErrorS "AVS" msg + throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus + + AvsResponseSetLicences msgs -> do + let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs + ok_ids = Set.map avsResponsePersonID ok + bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient + batch1_ok = Set.size ok + forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} -> + $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg + -- TODO: Admin Error page + aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?) + +{- NOT USED ANYWHERE: +-- Retrieve all currently valid driving licences and check against our database +-- Only react to changes as compared to last seen status in avs.model +synchAvsLicences :: Handler Bool +synchAvsLicences = do + allLicences <- avsQueryNoCache AvsQueryGetAllLicences + deltaLicences <- computeDifferingLicences allLicences + setResponse <- setLicencesAvs deltaLicences + let setOk = setResponse == Set.size deltaLicences + if setOk + then $logInfoS "AVS" "FRADrive Licences written to AVS successfully." + else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete." + return setOk +-} + + +data AvsLicenceDifferences = AvsLicenceDifferences + { avsLicenceDiffRevokeAll :: Set AvsPersonId -- revoke all driving licences in AVS (set 0) + , avsLicenceDiffGrantVorfeld :: Set AvsPersonId -- grant apron driving licence in AVS (set 1, upgrade from 0) + , avsLicenceDiffRevokeRollfeld :: Set AvsPersonId -- revoke maneuvering area driving licence, but retain apron driving licence (set 1, downgrade from 2) + , avsLicenceDiffGrantRollfeld :: Set AvsPersonId -- grant maneuvering area driving licence (set 2) + } + deriving (Show) + +#ifdef DEVELOPMENT +-- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build +#else +avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId +avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions + [ avsLicenceDiffRevokeAll + , avsLicenceDiffGrantVorfeld + , avsLicenceDiffRevokeRollfeld + , avsLicenceDiffGrantRollfeld + ] +#endif + +avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence +avsLicenceDifferences2personLicences AvsLicenceDifferences{..} = + Set.map (AvsPersonLicence AvsNoLicence) avsLicenceDiffRevokeAll + <> Set.map (AvsPersonLicence AvsLicenceVorfeld) avsLicenceDiffGrantVorfeld + <> Set.map (AvsPersonLicence AvsLicenceVorfeld) avsLicenceDiffRevokeRollfeld + <> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld + +computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence) +computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences + +type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard) + +avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard +avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status] + +retrieveDifferingLicences :: Handler AvsLicenceDifferences +retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False + +retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) +retrieveDifferingLicencesStatus = retrieveDifferingLicences' True + +retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) +retrieveDifferingLicences' getStatus = do +#ifdef DEVELOPMENT + avsUsrs <- runDB $ selectList [] [LimitTo 444] + let allLicences = AvsResponseGetLicences $ Set.fromList $ + [ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2 + , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1 + , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts) + , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig) + -- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1 + ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs] +#else + allLicences <- avsQuery AvsQueryGetAllLicences +#endif + lDiff <- getDifferingLicences allLicences +#ifdef DEVELOPMENT + let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5" + lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error + fakes = Set.fromList $ + [ AvsStatusPerson (AvsPersonId 77 ) $ Set.singleton $ mkAdpc True AvsCardColorGelb + , AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"] + , AvsStatusPerson (AvsPersonId 5 ) $ Set.fromList [mkAdpc True AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"] + , AvsStatusPerson (AvsPersonId 2 ) $ Set.singleton $ mkAdpc True AvsCardColorGrün + ] <> + [ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ] +#else + let statQry = avsLicenceDifferences2LicenceIds lDiff + lStat <- if getStatus && notNull statQry + then -- throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry -- don't throw up here, licence differences are too important! TODO: Warn in Problem-Handler + avsQueryStatus (AvsQueryStatus statQry) >>= \case + Left err -> do + addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry + return $ AvsResponseStatus mempty + Right res -> return res + else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls +#endif + return (lDiff, avsResponseStatusMap lStat) + + +getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences +getDifferingLicences (AvsResponseGetLicences licences) = do + now <- liftIO getCurrentTime + --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences + -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld + -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either + let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences + rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' + vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' + rollfeld = Set.map avsLicencePersonID rollfeld' + + antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId) + antijoinAvsLicences lic avsLics = fmap unwrapIds $ + E.select $ do + ((_qauli :& _qualUser :& usrAvs) :& excl) <- + E.from $ ( E.table @Qualification + `E.innerJoin` E.table @QualificationUser + `E.on` ( \(quali :& qualUser) -> + (quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) + -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work! + E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence + E.&&. (now `validQualification` qualUser) -- currently valid and not blocked + ) + `E.innerJoin` E.table @UserAvs + `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) + ) `E.fullOuterJoin` E.toValues (set2NonEmpty avsPersonIdZero avsLics) -- left-hand side produces all currently valid matching qualifications + `E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl) + E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join + return (usrAvs E.?. UserAvsPersonId, excl) + + unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId) + unwrapIds = mapBoth (Set.delete avsPersonIdZero) . foldr aux mempty + where + aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor + aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r) + aux _ acc = acc -- should never occur + + ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,) + <$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld + <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld + let setTo0 = vorfRevoke -- revoke driving licences + setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence + setTo1down = rollRevoke Set.\\ vorfRevoke -- revoke maneuvering area licence, but retain apron driving licence + setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence + return AvsLicenceDifferences + { avsLicenceDiffRevokeAll = setTo0 + , avsLicenceDiffGrantVorfeld = setTo1up + , avsLicenceDiffRevokeRollfeld = setTo1down + , avsLicenceDiffGrantRollfeld = setTo2 + } + {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) : + A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem + B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query + C (0,1,0) -> ((x,_),(_,_)) : set F for id + D (0,1,1) -> ((x,_),(x,_)) : set R for id + E (1,0,0) -> ((_,x),(_,_)) : set 0 for id + F (1,0,1) -> ((_,x),(x,_)) : set 0 for id + G (1,1,0) -> ((_,_),(_,_)) : nop + H (1,1,1) -> ((_,_),(x,_)) : set R for id + I (2,0,0) -> ((_,x),(_,x)) : set 0 for id + J (2,0,1) -> ((_,x),(_,_)) : set 0 for id + K (2,1,0) -> ((_,_),(_,x)) : set F for id + L (2,1,1) -> ((_,_),(_,_)) : nop + + PROBLEM: B & H in conflict! (Note that nop is automatic except for case B) + Results: + set to 0: determined by vorfeld-unset -- zuerst + set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset + set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld) + -} diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 3783ba0aa..6aab48225 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -102,7 +102,7 @@ crJobsCourseCommunication jCourse Communication{..} = do adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails netReceiverAddresses <- lift $ do netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email - (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] + (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] -- TODO -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) forM_ jAllRecipientAddresses $ \raddr -> diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index c5451ac11..e396bb093 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -19,7 +19,7 @@ oldUpsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- T oldUpsertUserCompany uid (Just cName) cAddr | notNull cName = do cid <- oldUpsertCompany cName cAddr void $ upsertBy (UniqueUserCompany uid cid) - (UserCompany uid cid False False) + (UserCompany uid cid False False 0 False) [] superVs <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] upsertManyWhere [ UserSupervisor super uid reroute (Just cid) Nothing diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 7511a9673..114b8b0c9 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -16,7 +16,7 @@ import Import import Handler.Utils.Pandoc import Handler.Utils.Files import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here? -import Handler.Utils.Users (getReceivers) +import Handler.Utils.Users (getReceivers, getEmailAddress) import Handler.Utils.Profile import qualified Data.CaseInsensitive as CI @@ -46,6 +46,8 @@ userAddressFrom :: User -> Address -- Uses `userDisplayEmail` only userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail + +-- TODO: Check that these functions can be used or are replaced, since they ignore company emails addresses userAddress :: User -> Address -- ^ Format an e-mail address suitable for usage as a recipient -- @@ -58,16 +60,19 @@ userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address userAddress' userEmail userDisplayEmail userDisplayName = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail -userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address) -userAddressError User{userEmail, userDisplayEmail, userDisplayName} - | Just okEmail <- pickValidUserEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail) - | otherwise = do + +userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX, m ~ HandlerFor UniWorX) => Entity User -> m (Bool, Address) +userAddressError usr@Entity{entityVal=User{userEmail, userDisplayEmail, userDisplayName}} = + runDB (getEmailAddress usr) >>= \case + Just okEmail -> pure (True, Address (Just userDisplayName) $ CI.original okEmail) + Nothing -> do $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow userDisplayEmail <> " / " <> tshow userEmail <> ". Sent to support instead." -- <> " with subject " <> tshow failedSubject (False,) <$> getsYesod (view _appMailSupport) -- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True userMailT :: ( MonadHandler m , HandlerSite m ~ UniWorX + , m ~ HandlerFor UniWorX , MonadThrow m , MonadUnliftIO m ) => UserId -> MailT m () -> m () @@ -84,7 +89,7 @@ userMailT uid mAct = do
  • #{nameHtml' svr} |] - forM_ receivers $ \Entity + forM_ receivers $ \svrEnt@Entity { entityKey = svr , entityVal = supervisor@User{ userLanguages , userDateTimeFormat @@ -111,7 +116,7 @@ userMailT uid mAct = do $else _{MsgMailSupervisorNoCopy} |] - (mailOk, mailtoAddr) <- userAddressError supervisor -- ensures a valid email, logs error and sends to support otherwise + (mailOk, mailtoAddr) <- userAddressError svrEnt -- ensures a valid email, logs error and sends to support otherwise mailT ctx $ do _mailTo .= pure mailtoAddr @@ -126,6 +131,7 @@ userMailT uid mAct = do -- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors userMailTdirect :: ( MonadHandler m , HandlerSite m ~ UniWorX + , m ~ HandlerFor UniWorX , MonadThrow m , MonadUnliftIO m ) => UserId -> MailT m a -> m a @@ -138,6 +144,7 @@ userMailTdirect uid mAct = do , userCsvOptions } <- liftHandler . runDB $ getJust uid let + usrEnt = Entity {entityKey = uid, entityVal = user} ctx = MailContext { mcLanguages = fromMaybe def userLanguages , mcDateTimeFormat = \case @@ -146,7 +153,7 @@ userMailTdirect uid mAct = do SelFormatTime -> userTimeFormat , mcCsvOptions = userCsvOptions } - (mailOk, mailtoAddr) <- userAddressError user -- ensures a valid email, logs error and sends to support otherwise + (mailOk, mailtoAddr) <- userAddressError usrEnt -- ensures a valid email, logs error and sends to support otherwise mailT ctx $ do -- failedSubject <- lookupMailHeader "Subject" -- unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 82fe491ea..73541a394 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -15,7 +15,6 @@ module Handler.Utils.Users , guessUser , UserAssimilateException(..), UserAssimilateExceptionReason(..) , assimilateUser - , userPrefersEmail, userPrefersLetter , getEmailAddress , getPostalAddress, getPostalPreferenceAndAddress , abbrvName @@ -67,36 +66,51 @@ abbrvName User{userDisplayName, userFirstName, userSurname} = assemble = Text.intercalate "." --- deprecated, used getPostalPreferenceAndAddress -userPrefersLetter :: User -> Bool -userPrefersLetter = fst . getPostalPreferenceAndAddress - --- deprecated, used getPostalPreferenceAndAddress -userPrefersEmail :: User -> Bool -userPrefersEmail = not . userPrefersLetter - --- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known -getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text]) -getPostalPreferenceAndAddress usr@User{userPrefersPostal} = - ((userPrefersPostal && postPossible) || not emailPossible, pa) - -- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set - where - pa = getPostalAddress usr - postPossible = isJust pa - emailPossible = isJust $ getEmailAddress usr +-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known +getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail) +getPostalPreferenceAndAddress usr = do + pa <- getPostalAddress usr + em <- getEmailAddress usr + let usrPrefPost = usr ^. _entityVal . _userPrefersPostal + finalPref = (usrPrefPost && isJust pa) || isNothing em + -- finalPref = isJust pa && (usrPrefPost || isNothing em) + return (finalPref, pa, em) + -getEmailAddress :: User -> Maybe UserEmail -getEmailAddress User{userDisplayEmail, userEmail} = pickValidUserEmail' userDisplayEmail userEmail - -getPostalAddress :: User -> Maybe [Text] -getPostalAddress User{..} - | Just pa <- userPostAddress - = Just $ userDisplayName : html2textlines pa - | Just abt <- userCompanyDepartment - = Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] - | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] +getEmailAddress :: Entity User -> DB (Maybe UserEmail) +getEmailAddress Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}} + | validEmail' userDisplayEmail + = return $ Just userDisplayEmail | otherwise - = Nothing + = do + compEmailMb <- runMaybeT $ do + Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] [Desc UserCompanyPriority] + Company{companyEmail} <- MaybeT $ get cid + MaybeT $ return companyEmail + return $ pickValidEmail' $ mcons compEmailMb [userEmail] + + +getPostalAddress :: Entity User -> DB (Maybe [Text]) +getPostalAddress Entity{entityKey=uid, entityVal=User{..}} + | Just pa <- userPostAddress + = prefixMarkupName pa + | otherwise + = do + compAddrMb <- runMaybeT $ do + Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] [Desc UserCompanyPriority] + Company{companyPostAddress} <- MaybeT $ get cid + MaybeT $ return companyPostAddress + case compAddrMb of + (Just pa) + -> prefixMarkupName pa + Nothing + | Just abt <- userCompanyDepartment + -> return $ Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] + | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] + | otherwise -> return Nothing + where + prefixMarkupName = return . Just . (userDisplayName :) . html2textlines + -- | Consider using Handler.Utils.Avs.updateReceivers instead -- Return Entity User and all Supervisors with rerouteNotifications as well as @@ -898,8 +912,15 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> (userCompany E.^. UserCompanyCompany) E.<&> (userCompany E.^. UserCompanySupervisor) E.<&> (userCompany E.^. UserCompanySupervisorReroute) + E.<&> (userCompany E.^. UserCompanyPriority) + E.<&> (userCompany E.^. UserCompanyUseCompanyAddress) + ) + (\current excluded -> + [ UserCompanySupervisor E.=. E.greatest (current E.^. UserCompanySupervisor) (excluded E.^. UserCompanySupervisor) -- t > f + , UserCompanyPriority E.=. E.greatest (current E.^. UserCompanyPriority) (excluded E.^. UserCompanyPriority) + , UserCompanyUseCompanyAddress E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress) + ] ) - (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] ) deleteWhere [ UserCompanyUser ==. oldUserId] mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 6d1d5a317..d6dbb36b9 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -28,7 +28,7 @@ dispatchJobQueueNotification jNotification = JobHandlerAtomic $ runConduit $ yield jNotification .| transPipe (hoist lift) determineNotificationCandidates .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) -> - and2M (return $ isJust $ pickValidUserEmail' userDisplayEmail userEmail) $ + and2M (return $ isJust $ pickValidUserEmail' userDisplayEmail userEmail) $ -- TODO: use getEmailAddress instead - although it is a DB action! or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification')) .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification') .| sinkDBJobs diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 5b40bfbab..53360fb4c 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -38,6 +38,9 @@ avsMaxSetLicenceAtOnce = 80 -- maximum input set size for avsQuerySetLicences avsMaxQueryAtOnce :: Int avsMaxQueryAtOnce = 500 -- maximum input set size for avsQueryStatus as enforced by AVS +avsMaxQueryDelay :: Int +avsMaxQueryDelay = 300000 -- microsecond to wait before sending another AVS query + avsApi :: Proxy AVS avsApi = Proxy @@ -119,6 +122,7 @@ splitQuery rawQuery q -- logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s res1 <- rawQuery $ view _Unwrapped' avsid1 + liftIO $ threadDelay avsMaxQueryDelay res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2 return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped') where diff --git a/src/Utils/Mail.hs b/src/Utils/Mail.hs index 954ef207f..487048f84 100644 --- a/src/Utils/Mail.hs +++ b/src/Utils/Mail.hs @@ -29,6 +29,9 @@ validEmail' = validEmail . CI.original pickValidEmail :: [Text] -> Maybe Text pickValidEmail = find validEmail +-- | returns the first valid Email, if any +pickValidEmail' :: [CI Text] -> Maybe (CI Text) +pickValidEmail' = find validEmail' -- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function pickValidUserEmail :: CI Text -> CI Text -> CI Text diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index d4dc3f882..104be74e6 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -149,8 +149,14 @@ pdfLaTeX lk doc = do renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) renderLetterPDF rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do + rcvrPostal <- runDB $ getPostalAddress rcvrEnt + -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress + renderLetterPDFto $ fromMaybe [rcvr & userDisplayName] rcvrPostal + +renderLetterPDFto :: (MDLetter l) => [Text] -> Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) +renderLetterPDFto rcvrPostal rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do now <- liftIO getCurrentTime - formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr + formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang kind = getLetterKind mdl tmpl = getTemplate mdl @@ -160,8 +166,7 @@ renderLetterPDF rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages toMeta "date" $ format SelFormatDate now , toMeta "rcvr-name" $ rcvr & userDisplayName - , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr - --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise + , toMeta "address" $ rcvrPostal ] e_md <- mdTemplating tmpl meta actRight e_md $ pdfLaTeX kind @@ -171,6 +176,8 @@ renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do now <- liftIO getCurrentTime formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr + rcvrPostal <- runDB $ getPostalAddress rcvrEnt + -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang kind = getLetterKind mdl tmpl = getTemplate mdl @@ -180,8 +187,8 @@ renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages toMeta "date" $ format SelFormatDate now , toMeta "rcvr-name" $ rcvr & userDisplayName - , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr - --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise + , toMeta "address" $ fromMaybe [rcvr & userDisplayName] rcvrPostal + --, toMeta "rcvr-email" $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise ] e_md <- mdTemplating tmpl meta actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do @@ -197,6 +204,8 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent | Just l <- anyone mdls = do now <- liftIO getCurrentTime formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr + rcvrPostal <- runDB $ getPostalAddress rcvrEnt + -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang kind = getLetterKind l @@ -209,8 +218,8 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages toMeta "date" $ format SelFormatDate now , toMeta "rcvr-name" $ rcvr & userDisplayName - , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr - --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise + , toMeta "address" $ fromMaybe [rcvr & userDisplayName] rcvrPostal + --, toMeta "rcvr-email" $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise ] in mdTemplating tmpl meta <&> \case err@Left{} -> err @@ -332,13 +341,14 @@ sendEmailOrLetter recipient letter = do mailSubject = mkMailSubject isSupervised encRecipient :: CryptoUUIDUser <- encrypt svr apcIdent <- letterApcIdent letter encRecipient now - case getPostalPreferenceAndAddress rcvrUsr of - (True, Nothing) -> do -- neither email nor postal is known + postalPrefs <- getPostalPreferenceAndAddress rcvrEnt + case postalPrefs of + (_, Nothing, Nothing) -> do -- neither email nor postal is known let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid $logErrorS "LETTER" msg return False - (True , Just _postal) -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send printed letter + (True , Just postal, _) -> renderLetterPDFto postal rcvrEnt letter apcIdent >>= \case -- send printed letter Left err -> do -- pdf generation failed let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg