571 lines
34 KiB
Haskell
571 lines
34 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
|
|
-- Module for functions directly related to the AVS interface,
|
|
-- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification
|
|
|
|
module Handler.Utils.Avs
|
|
( guessAvsUser
|
|
, upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
|
|
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
|
|
, AvsLicenceDifferences(..)
|
|
, setLicence, setLicenceAvs, setLicencesAvs
|
|
, retrieveDifferingLicences, retrieveDifferingLicencesStatus
|
|
, computeDifferingLicences
|
|
, synchAvsLicences
|
|
, lookupAvsUser, lookupAvsUsers
|
|
, AvsException(..)
|
|
, updateReceivers
|
|
, AvsPersonIdMapPersonCard
|
|
) where
|
|
|
|
import Import
|
|
|
|
-- import Handler.Utils
|
|
-- import qualified Database.Esqueleto.Legacy as E
|
|
|
|
import Utils.Avs
|
|
import Utils.Users
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as Text
|
|
import qualified Data.CaseInsensitive as CI
|
|
import Foundation.Yesod.Auth (userLookupAndUpsert)
|
|
|
|
import Handler.Utils.Company
|
|
import Handler.Utils.Qualification
|
|
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
|
|
|
|
|
|
--------------------
|
|
-- AVS Exceptions --
|
|
--------------------
|
|
|
|
data AvsException
|
|
= AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond
|
|
| AvsUserUnassociated UserId -- Manipulating AVS Data for a user that is not linked to AVS yet
|
|
| AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS DB
|
|
| AvsUserAmbiguous AvsPersonId -- Multiple matching existing users found in our DB
|
|
| AvsPersonSearchEmpty -- AvsPersonSearch returned empty result
|
|
| AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result
|
|
| AvsSetLicencesFailed Text -- AvsSetLicence total failure
|
|
deriving (Show, Eq, Ord, Generic)
|
|
instance Exception AvsException
|
|
|
|
{-
|
|
Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an 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.dispatchJobSynchroniseUserdb
|
|
|
|
-}
|
|
|
|
{- 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
|
|
-- TODO: run in a background job, once the interface is actually available
|
|
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
|
|
guessAvsUser :: Text -> Handler (Maybe UserId)
|
|
guessAvsUser (Text.splitAt 6 -> ("AVSID:", avsidTxt)) = ifMaybeM (readMay avsidTxt) Nothing $ \avsidNr ->
|
|
let avsid = AvsPersonId avsidNr
|
|
maybeAvsUpsert = maybeCatchAll $ upsertAvsUserById avsid
|
|
extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
|
|
in maybeM maybeAvsUpsert extractUid $ runDB $ getBy $ UniqueUserAvsId avsid
|
|
guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoTxt) Nothing $ \avsno ->
|
|
runDB (selectList [UserAvsNoPerson ==. avsno] []) <&> \case
|
|
[Entity _ UserAvs{userAvsUser=uid}] -> Just uid
|
|
_ -> Nothing
|
|
guessAvsUser someid = do
|
|
let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard
|
|
case discernAvsCardPersonalNo someid of
|
|
Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid
|
|
-- NOTE: card validity might be outdated, so we must always check with avs
|
|
-- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do
|
|
-- let extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
|
|
-- extractUidCard UserAvsCard{userAvsCardPersonId=avid} = getBy $ UniqueUserAvsId avid
|
|
-- cards <- selectList [UserAvsCardCardNo ==. cardNo] []
|
|
-- case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of
|
|
-- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard)
|
|
-- _ -> return Nothing
|
|
Just cid@(Right _wholeNumber) ->
|
|
maybeUpsertAvsUserByCard cid >>= \case
|
|
Nothing ->
|
|
runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) >>= \case
|
|
[Entity uid _] -> return $ Just uid
|
|
_ -> return Nothing
|
|
uid -> return uid
|
|
Nothing -> try (runDB $ userLookupAndUpsert someid UpsertUserGuessUser) >>= \case
|
|
Right (Just Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}}) ->
|
|
maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo))
|
|
Right (Just Entity{entityKey=uid}) -> return $ Just uid
|
|
other -> do -- attempt to recover by trying other ids
|
|
whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser external error " <> tshow err) -- this line primarily forces exception type to catch-all
|
|
runDB . runMaybeT $
|
|
let someIdent = stripCI someid
|
|
in MaybeT (getKeyBy $ UniqueEmail someIdent)
|
|
<|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
|
|
|
|
-- | Always update AVS Data, accepts AvsCardId (with dot), Fraport PersonalNumber or Fraport Email-Address
|
|
upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
|
|
upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
|
|
upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
|
|
try (runDB $ userLookupAndUpsert otherId UpsertUserGuessUser) >>= \case
|
|
Right (Just Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
|
|
other -> do -- attempt to recover by trying other ids
|
|
whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
|
|
apid <- runDB . runMaybeT $ do
|
|
let someIdent = stripCI otherId
|
|
uid <- MaybeT (getKeyBy $ UniqueEmail someIdent)
|
|
<|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
|
|
MaybeT $ view (_entityVal . _userAvsPersonId) <<$>> getBy (UniqueUserAvsUser uid)
|
|
ifMaybeM apid Nothing upsertAvsUserById
|
|
|
|
|
|
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
|
|
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
|
|
upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
|
|
upsertAvsUserByCard persNo = do
|
|
let qry = case persNo of
|
|
Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
|
|
Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn }
|
|
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
|
AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry
|
|
case Set.elems adps of
|
|
[] -> throwM AvsPersonSearchEmpty
|
|
(_:_:_) -> throwM AvsPersonSearchAmbiguous
|
|
[AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update
|
|
-- do
|
|
-- mbuid <- runDB $ getBy $ UniqueUserAvsId api
|
|
-- case mbuid of
|
|
-- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
|
|
-- Nothing -> upsertAvsUserById api
|
|
|
|
|
|
|
|
-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS Licence status! Updates Company, Address, PinPassword
|
|
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen).
|
|
upsertAvsUserById :: AvsPersonId -> Handler (Maybe UserId)
|
|
upsertAvsUserById api = do
|
|
mbapd <- lookupAvsUser api
|
|
now <- liftIO getCurrentTime
|
|
mbuid <- runDB $ do
|
|
mbuid <- getBy (UniqueUserAvsId api)
|
|
case (mbuid, mbapd) of
|
|
(Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
|
|
| Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do
|
|
$logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo
|
|
candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] []
|
|
case candidates of
|
|
[uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing)
|
|
(_:_) -> throwM $ AvsUserAmbiguous api
|
|
[] -> do
|
|
upsRes :: Either SomeException (Maybe (Entity User))
|
|
<- try $ userLookupAndUpsert persNo UpsertUserGuessUser -- TODO: do azure lookup and upsert if appropriate
|
|
$logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes
|
|
case upsRes of
|
|
Right (Just Entity{entityKey=uid}) -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
|
|
Right Nothing -> do
|
|
$logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases"
|
|
return mbuid -- == Nothing -- user could not be created somehow
|
|
Left err -> do
|
|
$logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases: " <> tshow err
|
|
return mbuid -- == Nothing -- user could not be created somehow
|
|
(Just Entity{ entityKey = uaid }, _) -> do
|
|
update uaid [ UserAvsLastSynch =. now, UserAvsLastSynchError =. Nothing ] -- mark as updated early, to prevent failed users to clog the synch
|
|
return mbuid
|
|
_other -> return mbuid
|
|
$logInfoS "AVS" $ "upsert prestep result: " <> tshow mbuid <> " --- " <> tshow mbapd
|
|
case (mbuid, mbapd) of
|
|
( _ , Nothing ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet
|
|
(Nothing, Just AvsDataPerson{avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname, ..}) -> do -- No LDAP User, but found in AVS; create new user
|
|
let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards
|
|
userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr
|
|
pinCard = Set.lookupMax avsPersonPersonCards
|
|
userPin = personCard2pin <$> pinCard
|
|
fakeIdent = CI.mk $ "AVSID:" <> tshow api
|
|
fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo
|
|
newUsr = AddUserData
|
|
{ audTitle = Nothing
|
|
, audFirstName = avsFirstName
|
|
, audSurname = avsSurname
|
|
, audDisplayName = avsFirstName <> Text.cons ' ' avsSurname
|
|
, audDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
|
|
, audMatriculation = Just $ tshow avsPersonPersonNo
|
|
, audSex = Nothing
|
|
, audBirthday = Nothing
|
|
, audMobile = Nothing
|
|
, audTelephone = Nothing
|
|
, audFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
|
|
, audFDepartment = Nothing
|
|
, audPostAddress = userFirmAddr
|
|
, audPrefersPostal = True
|
|
, audPinPassword = userPin
|
|
, audEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
|
|
, audIdent = fakeIdent -- use AvsPersonId instead
|
|
, audPassword = Nothing
|
|
--, audAuth = maybe AuthKindNoLogin (const AuthKindAzure) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
|
|
}
|
|
mbUid <- addNewUser newUsr -- triggers JobSynchroniseUserdbUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
|
|
whenIsJust mbUid $ \uid -> runDB $ do
|
|
insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing
|
|
forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred
|
|
-- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
|
|
-- forM_ cs $ -- only save used cards for the postal address update detection
|
|
\avsCard -> insert_ $ UserAvsCard avsPersonPersonID (getFullCardNo avsCard) avsCard now
|
|
upsertUserCompany uid mbCompany userFirmAddr
|
|
return mbUid
|
|
|
|
(Just (Entity _ UserAvs{userAvsUser=uid})
|
|
, Just AvsDataPerson{avsPersonPersonCards, avsPersonInternalPersonalNo, avsPersonPersonNo, avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname}) -> do -- known user, update address and pinPassword
|
|
let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards
|
|
userFirmAddr = plaintextToStoredMarkup <$> mbCoFirmAddr
|
|
pinCard = Set.lookupMax avsPersonPersonCards
|
|
userPin = personCard2pin <$> pinCard
|
|
runDB $ do
|
|
update uid [ UserFirstName =. avsFirstName -- update in case of name changes via AVS; might be changed again through LDAP
|
|
, UserSurname =. avsSurname
|
|
, UserDisplayName =. avsFirstName <> Text.cons ' ' avsSurname
|
|
, UserMatrikelnummer =. Just (tshow avsPersonPersonNo) -- TODO: Deactivate this update after Q2/2023; this is only needed since UserMatrikelnummer was used for AVSNO later
|
|
, UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
|
|
]
|
|
oldCards <- selectList [UserAvsCardPersonId ==. api] []
|
|
let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards
|
|
unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before
|
|
encRecipient :: CryptoUUIDUser <- encrypt uid
|
|
$logInfoS "AVS" $ "Postal address updated for" <> tshow encRecipient
|
|
updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr, UserPostLastUpdate =. Just now]
|
|
whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card
|
|
unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do
|
|
let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards
|
|
updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged
|
|
[UserPinPassword =. userPin]
|
|
insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now
|
|
upsertUserCompany uid mbCompany userFirmAddr
|
|
forM_ avsPersonPersonCards $ \aCard -> do
|
|
let fcn = getFullCardNo aCard
|
|
-- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused
|
|
deleteWhere [UserAvsCardCardNo ==. fcn]
|
|
insert_ $ UserAvsCard
|
|
{ userAvsCardPersonId = api
|
|
, userAvsCardCardNo = fcn
|
|
, userAvsCardCard = aCard
|
|
, userAvsCardLastSynch = now
|
|
}
|
|
return $ Just uid
|
|
|
|
|
|
lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
|
AvsPersonId -> m (Maybe AvsDataPerson)
|
|
lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
|
|
|
|
-- | retrieves complete avs user records for given AvsPersonIds.
|
|
-- Note that this requires several AVS-API queries, since
|
|
-- - avsQueryPerson does not support querying an AvsPersonId directly
|
|
-- - avsQueryStatus only provides limited information
|
|
-- avsQuery is used to obtain all card numbers, which are then queried separately an merged
|
|
-- May throw Servant.ClientError or AvsExceptions
|
|
-- Does not write to our own DB!
|
|
lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
|
Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
|
|
lookupAvsUsers apis = do
|
|
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
|
AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ AvsQueryStatus apis
|
|
let forFoldlM = $(permuteFun [3,2,1]) foldlM
|
|
forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
|
|
forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
|
|
AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
|
|
return $ mergeByPersonId adps acc2
|
|
|
|
|
|
-- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date
|
|
updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
|
|
updateReceivers uid = do
|
|
-- First perform AVS update for receiver
|
|
runDB (getBy (UniqueUserAvsUser uid)) >>= \case
|
|
Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ upsertAvsUserById apid
|
|
Nothing -> return ()
|
|
-- Retrieve updated user and supervisors now
|
|
(underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
|
|
<$> getJustEntity uid
|
|
<*> (E.select $ do
|
|
(usrSuper :& usrAvs) <-
|
|
E.from $ E.table @UserSupervisor
|
|
`E.leftJoin` E.table @UserAvs
|
|
`E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser)
|
|
E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid)
|
|
E.&&. (usrSuper E.^. UserSupervisorRerouteNotifications)
|
|
pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId)
|
|
)
|
|
let (superVs, avsIds) = unzip avsSupers
|
|
receiverIDs :: [UserId] = E.unValue <$> superVs
|
|
toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
|
|
directResult = return (underling, pure underling, True) -- already contains updated address
|
|
forM_ toUpdate (void . maybeCatchAll . upsertAvsUserById) -- attempt to update postaddress from AVS
|
|
if null receiverIDs
|
|
then directResult
|
|
else do
|
|
receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
|
|
if null receivers
|
|
then directResult
|
|
else return (underling, receivers, uid `elem` (entityKey <$> receivers))
|