Steffen
a52c8a6ad7
- See notes in #158 for details on update change policy - fieldLensVal was not working - create index for deleted table prevented start - some hlint errors
839 lines
50 KiB
Haskell
839 lines
50 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE TypeApplications, ExistentialQuantification #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
|
|
|
-- Module for functions directly related to the AVS interface,
|
|
-- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification
|
|
-- NOTE: Several ifdef DEVELOPMENT used, so UNSET DEVELOPMENT and build before comitting.
|
|
|
|
module Handler.Utils.Avs
|
|
( guessAvsUser
|
|
, upsertAvsUserById, upsertAvsUserByCard
|
|
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
|
|
, AvsLicenceDifferences(..)
|
|
, setLicence, setLicenceAvs, setLicencesAvs
|
|
, retrieveDifferingLicences, retrieveDifferingLicencesStatus
|
|
, computeDifferingLicences
|
|
-- , synchAvsLicences
|
|
, lookupAvsUser, lookupAvsUsers
|
|
, AvsException(..)
|
|
, updateReceivers
|
|
, AvsPersonIdMapPersonCard
|
|
-- CR3
|
|
, SomeAvsQuery(..)
|
|
, queryAvsCardNo, queryAvsCardNos
|
|
) where
|
|
|
|
import Import
|
|
|
|
-- import Handler.Utils
|
|
-- import qualified Database.Esqueleto.Legacy as E
|
|
|
|
|
|
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 qualified Control.Monad.Catch as Catch
|
|
|
|
-- import Auth.LDAP (ldapUserPrincipalName)
|
|
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
|
|
|
|
import Utils.Avs
|
|
import Utils.Mail (pickValidEmail)
|
|
import Utils.Users
|
|
import Handler.Utils.Users
|
|
import Handler.Utils.Profile (validPostAddressText)
|
|
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
|
|
-- import qualified Database.Esqueleto.PostgreSQL as E
|
|
|
|
import Servant.Client.Core.ClientError (ClientError)
|
|
|
|
|
|
|
|
--------------------
|
|
-- AVS Exceptions --
|
|
--------------------
|
|
|
|
data AvsException
|
|
= AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond
|
|
| AvsUserUnassociated Text -- Manipulating AVS Data for a user that is not linked to AVS yet
|
|
| AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS
|
|
| AvsUserAmbiguous AvsPersonId -- Multiple matching existing users found for a query in AVS or DB
|
|
| AvsPersonSearchEmpty -- AvsPersonSearch returned empty result
|
|
| AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result
|
|
| AvsSetLicencesFailed Text -- AvsSetLicence total failure
|
|
| AvsIdMismatch AvsPersonId AvsPersonId -- First AVS Id was requested, but second one was returned for that query
|
|
| AvsUserCreationFailed AvsPersonId
|
|
deriving (Show, Eq, Ord, Generic)
|
|
instance Exception AvsException
|
|
embedRenderMessage ''UniWorX ''AvsException id -- display as feedback for user initiated actions -- moved to Foundation.I18n
|
|
|
|
{-
|
|
Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
|
|
-}
|
|
|
|
-- | Catch AVS exceptions and display them as messages
|
|
-- catchAVS2message :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
|
|
catchAVS2message :: Handler (Maybe a) -> Handler (Maybe a)
|
|
catchAVS2message act = act `catches` handlers
|
|
where
|
|
handlers =
|
|
[ Catch.Handler (\(exc::AvsException) -> addMessageI Warning exc >> return Nothing)
|
|
, Catch.Handler (\(exc::ClientError ) -> do
|
|
let msg = "AVS fatal communicaton failure: " <> tshow exc
|
|
$logErrorS "AVS" msg
|
|
addMessage Warning $ toHtml msg
|
|
return Nothing
|
|
)
|
|
]
|
|
|
|
|
|
------------------
|
|
-- AVS Handlers --
|
|
------------------
|
|
|
|
|
|
-- TODO: delete lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored!
|
|
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
|
|
AvsResponseStatus statuses <- avsQuery $ 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 <- avsQuery $ 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 $ Just <$> 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 . fmap Just . 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))
|
|
|
|
|
|
------------------
|
|
-- CR3 Functions
|
|
|
|
|
|
-- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
|
|
class SomeAvsQuery q where
|
|
type SomeAvsResponse q :: Type
|
|
pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q))
|
|
-- | send query to AVS or maybe look it up within cache, depending on the type of the query
|
|
avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
|
avsQuery = avsQueryNoCache
|
|
-- | send query to AVS directly, never cached
|
|
avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
|
avsQueryNoCache = avsQueryNoCacheDefault
|
|
|
|
avsQueryNoCacheDefault :: (SomeAvsQuery q
|
|
, MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
|
avsQueryNoCacheDefault qry = do
|
|
qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
|
|
throwLeftM $ qfun qry
|
|
|
|
avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q)
|
|
, MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
|
avsQueryCached qry =
|
|
getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case
|
|
Just t | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry
|
|
_ -> avsQueryNoCache qry
|
|
|
|
instance SomeAvsQuery AvsQueryPerson where
|
|
type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
|
|
pickQuery = avsQueryPerson
|
|
avsQuery = avsQueryCached
|
|
|
|
instance SomeAvsQuery AvsQueryStatus where
|
|
type SomeAvsResponse AvsQueryStatus = AvsResponseStatus
|
|
pickQuery = avsQueryStatus
|
|
avsQuery = avsQueryCached
|
|
|
|
instance SomeAvsQuery AvsQueryContact where
|
|
type SomeAvsResponse AvsQueryContact = AvsResponseContact
|
|
pickQuery = avsQueryContact
|
|
avsQuery = avsQueryCached
|
|
|
|
instance SomeAvsQuery AvsQuerySetLicences where
|
|
type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences
|
|
pickQuery = avsQuerySetLicences
|
|
-- NOTE: avsQuery = avsQueryCached -- should not and indeed does not compile
|
|
avsQueryNoCache qry = avsQueryNoCacheDefault qry
|
|
<* memcachedInvalidate (Proxy @AvsResponseContact) -- invalidate all AvsResponseContact which may contain RampLicence info, since keys may comprise several ids
|
|
|
|
instance SomeAvsQuery AvsQueryGetAllLicences where
|
|
type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences
|
|
pickQuery = const . avsQueryGetAllLicences
|
|
|
|
|
|
|
|
queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId)
|
|
queryAvsCardNos = foldMapM queryAvsCardNo
|
|
|
|
queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId)
|
|
queryAvsCardNo crd = do
|
|
AvsResponsePerson adps <- avsQuery $ qry crd
|
|
return $ Set.map avsPersonPersonID adps
|
|
where
|
|
qry (Left acno) = def{ avsPersonQueryCardNo = Just acno }
|
|
qry (Right AvsFullCardNo{..}) = def{ avsPersonQueryCardNo = Just avsFullCardNo
|
|
, avsPersonQueryVersionNo = Just avsFullCardVersion
|
|
}
|
|
|
|
-- | Queries AVS Status to retrieve primary card (heursitic)
|
|
queryAvsPrimaryCard :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard)
|
|
queryAvsPrimaryCard api = runMaybeT $ do
|
|
AvsResponseStatus res <- MaybeT . maybeCatchAll . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api
|
|
pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res
|
|
hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus
|
|
|
|
-- | Queries AVS to retrieve CardNo from primary card (heursitic)
|
|
queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo)
|
|
queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard
|
|
|
|
_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
|
|
_avsFirmPostAddress = to mkPost
|
|
where
|
|
mkPost afi@AvsFirmInfo{avsFirmFirm} =
|
|
let someAddr = afi ^. _avsFirmPostAddressSimple
|
|
prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n'
|
|
in prefAddr <$> someAddr
|
|
|
|
-- | company post address without company name, better suited for comparisons
|
|
_avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
|
|
_avsFirmPostAddressSimple = to mkPost
|
|
where
|
|
mkPost AvsFirmInfo{..} =
|
|
let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry
|
|
commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
|
|
in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
|
|
|
|
_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
|
|
_avsFirmPrimaryEmail = to mkEmail
|
|
where
|
|
mkEmail afi =
|
|
let candidates = catMaybes
|
|
[ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
|
|
, afi ^. _avsFirmEMailSuperior
|
|
, afi ^. _avsFirmEMail
|
|
]
|
|
in pickValidEmail candidates -- should we return an invalid email rather than none?
|
|
|
|
-- | Not sure this is useful, since postal is ignored if there is no post address anyway
|
|
_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
|
|
_avsFirmPrefersPostal = to mkPostPref
|
|
where
|
|
mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
|
|
|
|
|
|
-- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
|
|
data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) (Getting typ iavs typ) -- A persistent record field and fitting getting
|
|
|
|
-- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value,
|
|
-- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query
|
|
mkUpdate :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
|
|
mkUpdate ent new (Just old) (CheckAvsUpdate up l)
|
|
| let newval = new ^. l
|
|
, let oldval = old ^. l
|
|
, let entval = ent ^. fieldLensVal up
|
|
, newval /= entval
|
|
, oldval == entval
|
|
= Just (up =. newval)
|
|
mkUpdate _ _ _ _ = Nothing
|
|
|
|
-- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited
|
|
mkUpdate' :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
|
|
mkUpdate' ent new Nothing = mkUpdateDirect ent new
|
|
mkUpdate' ent new just = mkUpdate ent new just
|
|
|
|
mkUpdateDirect :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
|
|
mkUpdateDirect ent new (CheckAvsUpdate up l)
|
|
| let newval = new ^. l
|
|
, let entval = ent ^. fieldLensVal up
|
|
, newval /= entval
|
|
= Just (up =. newval)
|
|
mkUpdateDirect _ _ _ = Nothing
|
|
|
|
-- | Unconditionally update a record through CheckAvsU
|
|
updateRecord :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> record
|
|
updateRecord ent new (CheckAvsUpdate up l) =
|
|
let newval = new ^. l
|
|
lensRec = fieldLensVal up
|
|
in ent & lensRec .~ newval
|
|
|
|
-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism, but single query may throw
|
|
updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId))
|
|
updateAvsUserByIds apids0 = do
|
|
apids <- Set.fromList <$> E.filterExists UserAvsPersonId apids0
|
|
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched
|
|
let requestedAnswers = Set.filter (view (_avsContactPersonID . to (`Set.member` apids))) adcs -- should not occur, neither should one apid occur multiple times within the response (if so, all responses processed here in random order)
|
|
res <- foldMapM procResp requestedAnswers
|
|
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"] -- all others were already marked as updated
|
|
return res
|
|
where
|
|
procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . runMaybeT $ do
|
|
(Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid
|
|
let usrId = userAvsUser usravs
|
|
usr <- MaybeT $ get usrId
|
|
lift $ do -- maybeT no longer needed from here onwards
|
|
newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here, does not throw
|
|
now <- liftIO getCurrentTime
|
|
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here
|
|
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
|
|
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
|
|
per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo)
|
|
[ CheckAvsUpdate UserFirstName _avsInfoFirstName
|
|
, CheckAvsUpdate UserSurname _avsInfoLastName
|
|
, CheckAvsUpdate UserDisplayName _avsInfoDisplayName
|
|
, CheckAvsUpdate UserBirthday _avsInfoDateOfBirth
|
|
, CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo
|
|
, 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
|
|
]
|
|
em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $
|
|
CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User
|
|
em_f_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
|
|
CheckAvsUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI
|
|
eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type
|
|
frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users,
|
|
CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead
|
|
pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card
|
|
CheckAvsUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
|
|
usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups))
|
|
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
|
|
[ UserAvsLastSynch =. now
|
|
, UserAvsLastSynchError =. Nothing
|
|
, UserAvsLastPersonInfo =. Just newAvsPersonInfo
|
|
, UserAvsLastFirmInfo =. Just newAvsFirmInfo
|
|
, UserAvsLastCardNo =. newAvsCardNo
|
|
]
|
|
-- update company association & supervision
|
|
Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
|
|
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
|
|
primaryCompanyId <- getUserPrimaryCompany usrId (Just . CompanyKey . companyShorthand)
|
|
let oldCompanyId = entityKey <$> oldCompanyEnt
|
|
oldCompanyMb = entityVal <$> oldCompanyEnt
|
|
pst_up = if
|
|
-- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
|
|
-- -> mkUpdate' usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
|
| isNothing oldCompanyMb
|
|
-> mkUpdateDirect usr newCompany $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
|
| oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
|
|
-> mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
|
|
| otherwise
|
|
-> Nothing
|
|
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
|
newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
|
|
|
|
|
|
usr_up2 <- case oldAvsFirmInfo of
|
|
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
|
|
-> return Nothing -- => do nothing
|
|
(Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR
|
|
|| ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged
|
|
-> do -- => just update user company association, keeping supervision privileges
|
|
case oldCompanyId of
|
|
Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
|
|
Just ocid -> do
|
|
void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings
|
|
void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
|
|
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
|
|
, UserSupervisorReason ==. Just superReasonComDef] -- user
|
|
[ UserSupervisorCompany =. Just newCompanyId]
|
|
return Nothing
|
|
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
|
|
-> do
|
|
whenIsJust oldCompanyId $ \oldCid -> do
|
|
deleteBy $ UniqueUserCompany usrId oldCid
|
|
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
|
|
return Nothing
|
|
_ -- company changed completely
|
|
-> do
|
|
-- switch user company, keeping old priority
|
|
(getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
|
|
Nothing ->
|
|
void $ insertUnique newUserComp
|
|
Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
|
|
when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
|
|
delete ucidOld
|
|
void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
|
|
-- adjust supervison
|
|
oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
|
|
addCompanySupervisors newCompanyId usrId
|
|
newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
|
when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
|
return pst_up
|
|
repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors
|
|
update usrId $ usr_up2 `mcons` usr_up1 -- update user eventually
|
|
update uaId avs_ups -- update stored avsinfo for future updates
|
|
return $ Set.singleton (apid, usrId)
|
|
|
|
-- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ???
|
|
-- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints
|
|
createAvsUserById :: AvsPersonId -> Handler UserId
|
|
createAvsUserById api = do
|
|
AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
|
|
case Set.toList contactRes of
|
|
[] -> throwM $ AvsUserUnknownByAvs api
|
|
(_:_:_) -> throwM $ AvsUserAmbiguous api
|
|
[AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
|
|
| avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
|
|
| otherwise -> do
|
|
-- check for matching existing user
|
|
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
|
|
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
|
|
oldUsr <- runDB $ do
|
|
mbUid <- firstJustM $ catMaybes
|
|
[ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
|
|
, persMail <&> guessUserByEmail
|
|
]
|
|
mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
|
|
return (mbUid, mbUAvs)
|
|
usrCardNo <- queryAvsFullCardNo api
|
|
now <- liftIO getCurrentTime
|
|
let usrAvs uid mbFirmInfo = UserAvs
|
|
{ userAvsPersonId = api
|
|
, userAvsUser = uid
|
|
, userAvsNoPerson = fromMaybe (negate $ avsPersonId api) $ readMay $ cpi ^. _avsInfoPersonNo -- negative personId as fallback, but readMay should never fail
|
|
, userAvsLastSynch = now
|
|
, userAvsLastSynchError = Nothing
|
|
, userAvsLastPersonInfo = Just cpi
|
|
, userAvsLastFirmInfo = mbFirmInfo
|
|
, userAvsLastCardNo = usrCardNo
|
|
}
|
|
case oldUsr of
|
|
(_ , Just Entity{entityVal=UserAvs{userAvsPersonId=api'}})
|
|
| api /= api' -> throwM $ AvsIdMismatch api api'
|
|
| otherwise -> throwM $ AvsUserUnknownByAvs api
|
|
(Just uid, Nothing) -> runDB $ do -- link with matching exisitng user
|
|
insert_ $ usrAvs uid Nothing -- company info should cause the user to be associated with the company during the update
|
|
updRes <- updateAvsUserByIds $ Set.singleton api -- no loop, since updateAvsUserByIds does not call createAvsUserById
|
|
case Set.toList updRes of
|
|
[(api',uid')] | api == api' -> return uid' -- && uid == uid' -> return uid
|
|
| otherwise -> throwM $ AvsIdMismatch api api'
|
|
[] -> throwM $ AvsUserUnknownByAvs api
|
|
_ -> throwM $ AvsUserAmbiguous api
|
|
(Nothing, Nothing) -> do
|
|
Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
|
|
let pinPass = avsFullCardNo2pin <$> usrCardNo
|
|
newUserData = AddUserData
|
|
{ audTitle = Nothing
|
|
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip
|
|
, audSurname = cpi ^. _avsInfoLastName & Text.strip
|
|
, audDisplayName = cpi ^. _avsInfoDisplayName
|
|
, audDisplayEmail = persMail & fromMaybe mempty
|
|
, audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
|
|
, audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api )
|
|
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
|
|
, audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow
|
|
, audSex = Nothing
|
|
, audBirthday = cpi ^. _avsInfoDateOfBirth
|
|
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
|
|
, audTelephone = Nothing
|
|
, audFPersonalNumber = internalPersNo
|
|
, audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
|
|
, audPostAddress = Nothing -- always use company address indirectly
|
|
, audPrefersPostal = cmp ^. _companyPrefersPostal
|
|
, audPinPassword = pinPass
|
|
}
|
|
runDB $ do -- any failure must rollback all DB write transactions here
|
|
uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData
|
|
let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
|
|
void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
|
|
-- Supervision
|
|
addCompanySupervisors cid uid
|
|
repsertSuperiorSupervisor (Just cid) firmInfo uid
|
|
-- Save AVS data for future updates
|
|
insert_ $ usrAvs uid $ Just firmInfo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
|
|
return uid
|
|
|
|
|
|
-- | upsert superior by eMail through LDAP only (currently no email search available in AVS)
|
|
repsertSuperiorSupervisor :: Maybe CompanyId -> AvsFirmInfo -> UserId -> DB ()
|
|
repsertSuperiorSupervisor cid afi uid =
|
|
whenIsJust (afi ^. _avsFirmEMailSuperior) $ \supemail -> forMM_
|
|
(altM (guessUserByEmail $ stripCI supemail)
|
|
(maybeCatchAll $ Just . entityKey <$> ldapLookupAndUpsert supemail)
|
|
) $ \supid -> do
|
|
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
|
deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior]
|
|
void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior
|
|
|
|
|
|
-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
|
|
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
|
|
getAvsCompany afi =
|
|
let compName :: CompanyName
|
|
compName = afi ^. _avsFirmFirm . from _CI
|
|
compShorthand :: CompanyShorthand
|
|
compShorthand = afi ^. _avsFirmAbbreviation . from _CI
|
|
compAvsId = afi ^. _avsFirmFirmNo
|
|
in firstJustM $
|
|
bcons (compAvsId > 0)
|
|
( getBy $ UniqueCompanyAvsId compAvsId )
|
|
[ getEntity $ CompanyKey compShorthand
|
|
, getBy $ UniqueCompanyName compName
|
|
]
|
|
|
|
-- | insert a company from AVS firm info or update an existing one based on previous values
|
|
upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
|
|
upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
|
mbFirmEnt <- getAvsCompany newAvsFirmInfo
|
|
case (mbFirmEnt, mbOldAvsFirmInfo) of
|
|
(Nothing, _) -> do -- insert new company
|
|
let upd = flip updateRecord newAvsFirmInfo
|
|
dmy = Company -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency
|
|
{ companyName = newAvsFirmInfo ^. _avsFirmFirm . from _CI
|
|
, companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI
|
|
, companyAvsId = newAvsFirmInfo ^. _avsFirmFirmNo
|
|
, companyPrefersPostal = True
|
|
, companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress
|
|
, companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI
|
|
}
|
|
newCmp <- insertEntity $ foldl' upd dmy firmInfo2company
|
|
reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
|
|
return newCmp
|
|
|
|
(Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
|
|
let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
|
|
Entity firmid <$> updateGet firmid cmp_ups
|
|
|
|
where
|
|
firmInfo2company =
|
|
[ CheckAvsUpdate CompanyName $ _avsFirmFirm . from _CI
|
|
, CheckAvsUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI
|
|
, CheckAvsUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade
|
|
-- , CheckAvsUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
|
|
, CheckAvsUpdate CompanyPostAddress _avsFirmPostAddress
|
|
, CheckAvsUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
|
|
]
|
|
|
|
|
|
|
|
|
|
-- | 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 update query is executed
|
|
guessAvsUser :: Text -> Handler (Maybe UserId)
|
|
guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
|
|
| prefix=="AVSID:" =
|
|
let avsid = AvsPersonId nr in
|
|
runDB (getBy $ UniqueUserAvsId avsid) >>= \case
|
|
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
|
|
Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
|
|
| prefix=="AVSNO:" =
|
|
runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
|
|
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
|
|
catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
|
|
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
|
|
runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
|
|
other -> return other
|
|
guessAvsUser someid = do
|
|
try (runDB $ ldapLookupAndUpsert someid) >>= \case
|
|
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> -- ensure internal user is linked to avs, if possible
|
|
catchAVS2message (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case
|
|
Nothing -> Just uid
|
|
other -> other
|
|
Right Entity{entityKey=uid} -> return $ Just uid
|
|
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
|
|
runDB . runMaybeT $
|
|
MaybeT (guessUserByEmail $ stripCI someid) -- recall that monadic actions are only executed until first success here
|
|
<|> MaybeT (getKeyByFilter [UserDisplayName ==. someid])
|
|
|
|
|
|
-- | 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 AvsInternalPersonalNo AvsFullCardNo -> Handler (Maybe UserId)
|
|
upsertAvsUserByCard persNo = do
|
|
let qry = case persNo of
|
|
Left fpn
|
|
-> def{ avsPersonQueryInternalPersonalNo = Just fpn } -- recall: default has all fields set to nothing
|
|
Right AvsFullCardNo{..}
|
|
-> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
|
|
-- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB!
|
|
AvsResponsePerson adps <- avsQuery qry
|
|
case Set.elems adps of
|
|
[] -> return Nothing
|
|
(_:_:_) -> throwM AvsPersonSearchAmbiguous
|
|
[AvsDataPerson{avsPersonPersonID=api}] -> Just <$> upsertAvsUserById api -- always triggers an update
|
|
|
|
|
|
-- | 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 new user would violate uniqueness constraints
|
|
upsertAvsUserById :: AvsPersonId -> Handler UserId
|
|
upsertAvsUserById api = do
|
|
upd <- runDB (updateAvsUserByIds $ Set.singleton api)
|
|
case Set.toList upd of
|
|
[] -> createAvsUserById api
|
|
[(api',uid)]
|
|
| api == api' -> return uid
|
|
| otherwise -> throwM $ AvsIdMismatch api api'
|
|
-- error $ "Handler.Utils.Avs.updateAvsUserByIds returned unasked user with AvsPersonId " <> show api' <> " for queried AvsPersonId " <> show api <> "."
|
|
(_:_:_) -> throwM $ AvsUserAmbiguous api
|
|
|
|
|
|
-- Licences
|
|
setLicence :: (PersistUniqueRead backend, MonadThrow m,
|
|
MonadHandler m, HandlerSite m ~ UniWorX,
|
|
BaseBackend backend ~ SqlBackend) =>
|
|
UserId -> AvsLicence -> ReaderT backend m Bool
|
|
setLicence uid lic =
|
|
getBy (UniqueUserAvsUser uid) >>= \case
|
|
Just Entity{entityVal=UserAvs{userAvsPersonId=api}} -> setLicenceAvs api lic
|
|
Nothing -> do
|
|
uname <- userDisplayName <<$>> get uid
|
|
throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname
|
|
|
|
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)
|
|
|
|
#ifndef DEVELOPMENT
|
|
-- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build
|
|
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 avsQueryNoCache (AvsQueryStatus statQry)
|
|
-- `catch` handler
|
|
-- let handler _exception = do
|
|
-- addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry
|
|
-- return $ AvsResponseStatus mempty
|
|
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)
|
|
-}
|