-- SPDX-FileCopyrightText: 2022 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications #-} module Handler.Utils.Avs ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard , getLicence, getLicenceDB , setLicence, setLicenceAvs, setLicencesAvs , checkLicences , lookupAvsUser, lookupAvsUsers ) where import Import -- import Handler.Utils -- import qualified Database.Esqueleto.Legacy as E import Utils.Avs import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.CaseInsensitive as CI -- import Auth.LDAP (ldapUserPrincipalName) import Foundation.Yesod.Auth (upsertCampusUserByCn,CampusUserConversionException()) import Handler.Utils.Company import Handler.Users.Add --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 -- AvsPersionId not (or no longer) found in AVS DB | AvsUserAmbiguous -- 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, Generic, Typeable) 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.dispatchJobSynchroniseLdap -} -- 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) setLicence :: UserId -> AvsLicence -> DB () setLicence uid lic = do Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid setLicenceAvs userAvsPersonId lic setLicenceAvs :: AvsPersonId -> AvsLicence -> DB () setLicenceAvs apid lic = do let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid } setLicencesAvs req -- setLicencesAvs :: Set AvsPersonLicence -> DB () setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => Set AvsPersonLicence -> m () setLicencesAvs pls = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery response <- throwLeftM . avsQuerySetLicences $ AvsQuerySetLicences pls case response of AvsResponseSetLicencesError{..} -> do let msg = "Set licence failed completely: " <> avsResponseSetLicencesStatus <> ". Details: " <> avsResponseSetLicencesMessage $logErrorS "AVS" msg throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus AvsResponseSetLicences responses -> forM_ responses $ \AvsLicenceResponse{..} -> unless (sloppyBool avsResponseSuccess) $ do -- TODO: create an Admin Problems overview page $logErrorS "AVS" $ "Set licence failed for " <> tshow avsResponsePersonID <> " due to " <> cropText avsResponseMessage -- | 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: turn into a job, once the interface is actually available checkLicences :: Handler () checkLicences = do {- AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld let (noOrVorfeld, rollfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) licences (_nolicence , vorfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) noOrVorfeld now <- liftIO getCurrentTime runDB $ do E.select $ do -} --TODO this must be chunked into separate jobs/tasks --forM licences $ \AvsPersonLicence{..} -> do error "CONTINUE HERE" -- TODO STUB upsertAvsUser :: Text -> Handler (Maybe UserId) upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now {- maybe this code helps? upsRes :: Either CampusUserConversionException (Entity User) <- try $ upsertCampusUserByOther persNo case upsRes of Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid _other -> return mbuid -- ==Nothing -- user could not be created somehow -} -- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. -- 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=appi}] -> do mbuid <- runDB $ getBy $ UniqueUserAvsId appi case mbuid of (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau Nothing -> upsertAvsUserById appi -- | 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 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 persNo <- avsPersonInternalPersonalNo -> do candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] [] case candidates of [uid] -> insertUniqueEntity $ UserAvs api uid (_:_) -> throwM AvsUserAmbiguous [] -> do upsRes :: Either CampusUserConversionException (Entity User) <- try $ upsertCampusUserByCn persNo case upsRes of Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid -- pin/addr are updated in next step anyway _other -> return mbuid -- ==Nothing -- user could not be created somehow _other -> return mbuid 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{..}) -> do -- No LDAP User, but found in AVS; create new user let firmAddress = guessLicenceAddress avsPersonPersonCards mbCompany = firmAddress ^? _Just . _1 . _Just userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress addrCard = firmAddress ^? _Just . _3 pinCard = Set.lookupMax avsPersonPersonCards userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard fakeIdent = CI.mk $ "AVSID:" <> tshow api newUsr = AdminUserForm { aufTitle = Nothing , aufFirstName = avsPersonFirstName , aufSurname = avsPersonLastName , aufDisplayName = avsPersonFirstName <> " " <> avsPersonLastName , aufDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , aufMatriculation = Nothing , aufSex = Nothing , aufMobile = Nothing , aufTelephone = Nothing , aufFPersonalNumber = avsPersonInternalPersonalNo , aufFDepartment = Nothing , aufPostAddress = userFirmAddr , aufPrefersPostal = isJust firmAddress , aufPinPassword = userPin , aufEmail = fakeIdent -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , aufIdent = fakeIdent -- use AvsPersonId instead , aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known } mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe whenIsJust mbUid $ \uid -> runDB $ do now <- liftIO getCurrentTime insert_ $ UserAvs avsPersonPersonID uid -- forM_ avsPersonPersonCards $ -- save all cards for later 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 (avsDataCardNo avsCard) avsCard now upsertUserCompany uid mbCompany return mbUid (Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword let firmAddress = guessLicenceAddress avsPersonPersonCards mbCompany = firmAddress ^? _Just . _1 . _Just userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress addrCard = firmAddress ^? _Just . _3 pinCard = Set.lookupMax avsPersonPersonCards userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard runDB $ do now <- liftIO getCurrentTime upsertUserCompany uid mbCompany whenIsJust addrCard $ \aCard -> getBy (UniqueAvsCard $ avsDataCardNo aCard) >>= \case (Just (Entity uac UserAvsCard{..})) | aCard == userAvsCardCard -> -- address seen before, no change update uac [UserAvsCardLastSynch =. now] _ -> do -- possibly new address data void $ upsert UserAvsCard { userAvsCardPersonId = api , userAvsCardCardNo = avsDataCardNo aCard , userAvsCardCard = aCard , userAvsCardLastSynch= now } [ UserAvsCardCard =. aCard , UserAvsCardLastSynch =. now ] when (isJust userFirmAddr) $ updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr] whenIsJust pinCard $ \pCard -> unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do -- update pin, but only if it was unset or set to the value of an old card oldCards <- selectList [UserAvsCardPersonId ==. api] [] let oldPins = Just . tshowAvsFullCardNo . getFullCardNo . userAvsCardCard . entityVal <$> oldCards updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins] [UserPinPassword =. userPin] insert_ $ UserAvsCard api (avsDataCardNo pCard) pCard 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