refactor(user): empty postal uses high priority company address instead (WIP)
This commit is contained in:
parent
c179c03f9d
commit
9985151002
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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)
|
||||
-}
|
||||
|
||||
@ -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 ->
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
<li>
|
||||
#{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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user