356 lines
18 KiB
Haskell
356 lines
18 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO: remove this line, once the module is completed
|
|
{-# OPTIONS_GHC -Wno-error=unused-local-binds #-} -- TODO: remove this line, once the module is completed
|
|
|
|
|
|
|
|
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 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
|
|
|
|
|
|
--------------------
|
|
-- 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 -- 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
|
|
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 nowaday = utctDay now
|
|
noOne = AvsPersonId 0
|
|
vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences
|
|
rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
|
|
vorORrollfeld = set2NonEmpty noOne (Set.map avsLicencePersonID vorORrollfeld')
|
|
rollfeld = set2NonEmpty noOne (Set.map avsLicencePersonID rollfeld' )
|
|
|
|
|
|
-- we get a weird type error so we try a simple demo here:
|
|
(_res :: [(E.Value AvsPersonId, E.Value AvsPersonId )]) <- runDB $ E.select $ do
|
|
(usrAvs E.:& excl) <-
|
|
E.from $ E.table @UserAvs `E.innerJoin` E.toValues rollfeld
|
|
`E.on` (\(usrAvs E.:& excl) -> excl E.==. usrAvs E.^. UserAvsPersonId)
|
|
return (usrAvs E.^. UserAvsPersonId, excl)
|
|
-- > Looks like we need te Type NonEmpty (SqlExpr (Value typ)) i.e. we need to wrap everything with E.val?!
|
|
|
|
{-
|
|
Cases to consider (AVS_Licence,has_valid_F, has_valid_R):
|
|
(0,0,0) -> ok; avs_id not returned from queries, no problem
|
|
(0,0,1) -> do nothing -- CHECK since id is returned by roll-query
|
|
(0,1,0) -> set F for id
|
|
(0,1,1) -> set R for id
|
|
(1,0,0) -> unset F for id
|
|
(1,0,1) -> unset F for id
|
|
(1,1,0) -> ok
|
|
(1,1,1) -> set R for id
|
|
(2,0,0) -> unset R for id
|
|
(2,0,1) -> unset R for id -- CHECK
|
|
(2,1,0) -> set F for id
|
|
(2,1,1) -> ok
|
|
-}
|
|
|
|
antijoinAvsLicences :: AvsLicence -> NonEmpty AvsPersonId -> DB [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))]
|
|
antijoinAvsLicences lic avsLics = --fmap (fmap $(E.unValueN 2)) $
|
|
E.select $ do
|
|
((_qauli E.:& _qualUser E.:& usrAvs) E.:& excl) <-
|
|
E.from $ ( E.table @Qualification
|
|
`E.innerJoin` E.table @QualificationUser
|
|
`E.on` ( \(quali E.:& 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.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
|
|
,qualUser E.^. QualificationUserValidUntil)) -- currently valid
|
|
E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- no blocked
|
|
)
|
|
`E.innerJoin` E.table @UserAvs
|
|
`E.on` (\(_ E.:& qualUser E.:& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
|
|
) `E.fullOuterJoin` E.toValues avsLics -- left-hand side produces all currently valid matching qualifications
|
|
`E.on` (\((_ E.:& _ E.:& usrAvs) E.:& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl)
|
|
E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join
|
|
return (usrAvs E.?. UserAvsPersonId, excl)
|
|
|
|
-- (_rollDelta, _vorfDelta) <- runDB $ (,)
|
|
-- <$> antijoinAvsLicences AvsLicenceRollfeld rollfeld
|
|
-- <*> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld
|
|
|
|
-- let roll2zero = Set.fromList rollRevoke
|
|
-- roll2roll = Set.fromList rollGrant
|
|
-- vorf2vorf = Set.fromList vorfGrant
|
|
-- vorf2zero = Set.fromList vorfRevoke
|
|
-- cases to consider:
|
|
-- aID is either in lhs or rhs of vorfDelta, rollDelta or both.
|
|
-- The case
|
|
|
|
|
|
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 AvsCardNumber 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
|
|
|