chore(avs): adjust to newly refined VSM specifications (DONE)
This commit is contained in:
Steffen Jost
parent
df559fead1
commit
734eb8927e
@ -7,7 +7,7 @@ module Handler.Utils.Avs
|
||||
, getLicence, getLicenceDB
|
||||
, setLicence, setLicenceAvs, setLicencesAvs
|
||||
, checkLicences
|
||||
, lookupAvsUser, lookupAvsUsers
|
||||
, lookupAvsUser, lookupAvsUsers
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -32,13 +32,13 @@ import Handler.Users.Add
|
||||
--------------------
|
||||
|
||||
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
|
||||
|
||||
= 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
|
||||
|
||||
@ -92,11 +92,16 @@ setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
|
||||
Set AvsPersonLicence -> m ()
|
||||
setLicencesAvs pls = do
|
||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
AvsResponseSetLicences responses <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls
|
||||
forM_ responses $ \AvsLicenceResponse{..} ->
|
||||
unless (sloppyBool avsResponseSuccess) $
|
||||
-- TODO: create an Admin Problems overview page
|
||||
$logErrorS "AVS" $ "Set licence failed for " <> tshow avsResponsePersonID <> " due to " <> cropText avsResponseMessage
|
||||
response <- throwLeftM . avsQuerySetLicences $ AvsQuerySetLicences pls
|
||||
case response of
|
||||
AvsResponseSetLicencesError{..} -> do
|
||||
$logErrorS "AVS" $ "Set licence failed completely: " <> avsResponseSetLicencesStatus <> ". Details: " <> avsResponseSetLicencesMessage
|
||||
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
|
||||
@ -123,21 +128,21 @@ upsertAvsUser _someid = error "TODO" -- TODO STUB
|
||||
-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created.
|
||||
-- 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
|
||||
upsertAvsUserById api = do
|
||||
mbapd <- lookupAvsUser api
|
||||
mbuid <- runDB $ do
|
||||
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
|
||||
| Just persNo <- avsPersonInternalPersonalNo -> do
|
||||
candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] []
|
||||
case candidates of
|
||||
[uid] -> insertUniqueEntity $ UserAvs api uid
|
||||
(_:_) -> throwM AvsUserAmbiguous
|
||||
[] -> do
|
||||
upsRes :: Either CampusUserConversionException (Entity User)
|
||||
upsRes :: Either CampusUserConversionException (Entity User)
|
||||
<- try $ upsertCampusUserByCn persNo
|
||||
case upsRes of
|
||||
case upsRes of
|
||||
Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid
|
||||
_other -> return mbuid -- ==Nothing -- user could not be created somehow
|
||||
_other -> return mbuid
|
||||
@ -148,14 +153,14 @@ upsertAvsUserById api = do
|
||||
mbCompany = firmAddress ^? _Just . _1 . _Just
|
||||
bestCard = Set.lookupMax avsPersonPersonCards
|
||||
fakeIdent = CI.mk $ tshow api
|
||||
newUsr = AdminUserForm
|
||||
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
|
||||
, aufSex = Nothing
|
||||
, aufMobile = Nothing
|
||||
, aufTelephone = Nothing
|
||||
, aufFPersonalNumber = avsPersonInternalPersonalNo
|
||||
@ -168,62 +173,62 @@ upsertAvsUserById api = do
|
||||
, 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 -- trigger JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
|
||||
case (mbCompany, mbUid) of
|
||||
(Just cpy, Just uid) -> runDB $ do
|
||||
case (mbCompany, mbUid) of
|
||||
(Just cpy, Just uid) -> runDB $ do
|
||||
cid <- upsertCompany cpy
|
||||
insert_ $ UserCompany cid uid False
|
||||
_ -> return ()
|
||||
|
||||
|
||||
|
||||
-- _newAvs = UserAvs avsPersonPersonID uid
|
||||
-- _newAvsCards = UserAvsCard
|
||||
error "TODO" -- CONTINUE HERE
|
||||
(Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates
|
||||
-- _newAvsCards = UserAvsCard
|
||||
error "TODO" -- CONTINUE HERE
|
||||
(Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates
|
||||
error "TODO" -- CONTINUE HERE
|
||||
|
||||
|
||||
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible.
|
||||
-- | 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 :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
--upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
-- upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m )
|
||||
upsertAvsUserByCard ::
|
||||
upsertAvsUserByCard ::
|
||||
Either (AvsCardNo,AvsVersionNo) AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
|
||||
upsertAvsUserByCard persNo = do
|
||||
let qry = case persNo of
|
||||
let qry = case persNo of
|
||||
Left (acn,avn) -> def{ avsPersonQueryCardNo = Just acn, avsPersonQueryVersionNo = Just avn }
|
||||
Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn }
|
||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry
|
||||
case Set.elems adps of
|
||||
case Set.elems adps of
|
||||
[] -> throwM AvsPersonSearchEmpty
|
||||
(_:_:_) -> throwM AvsPersonSearchAmbiguous
|
||||
[AvsDataPerson{avsPersonPersonID=appi}] -> do
|
||||
(_:_:_) -> throwM AvsPersonSearchAmbiguous
|
||||
[AvsDataPerson{avsPersonPersonID=appi}] -> do
|
||||
mbuid <- runDB $ getBy $ UniqueUserAvsId appi
|
||||
case mbuid of
|
||||
case mbuid of
|
||||
(Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
|
||||
Nothing -> upsertAvsUserById appi
|
||||
|
||||
|
||||
|
||||
lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
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
|
||||
-- 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 ) =>
|
||||
lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
|
||||
lookupAvsUsers apis = do
|
||||
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 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
|
||||
|
||||
|
||||
|
||||
@ -331,17 +331,12 @@ data AvsLicenceResponse = AvsLicenceResponse
|
||||
, avsResponseSuccess :: SloppyBool
|
||||
, avsResponseMessage :: Text
|
||||
}
|
||||
| AvsErrorResponse
|
||||
{ avsResponseStatus :: Text
|
||||
, avsResponseMessage :: Text
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 2
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
, sumEncoding = UntaggedValue
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsLicenceResponse
|
||||
|
||||
|
||||
@ -376,13 +371,18 @@ deriveJSON defaultOptions
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsResponseGetLicences
|
||||
|
||||
newtype AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse)
|
||||
data AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse)
|
||||
| AvsResponseSetLicencesError
|
||||
{ avsResponseSetLicencesStatus :: Text
|
||||
, avsResponseSetLicencesMessage :: Text
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 2
|
||||
{ fieldLabelModifier = dropCamel 4
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
, sumEncoding = UntaggedValue
|
||||
} ''AvsResponseSetLicences
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user