From 9d09ec676a8f222679264661ebf8f25543f8253b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 21 Sep 2022 18:55:51 +0200 Subject: [PATCH] chore(avs): adjust avs interface to latest spec and improve upon --- models/avs.model | 5 +- src/Handler/Utils/Avs.hs | 86 ++++++++++++++++++++++++++++++---- src/Model/Types/Avs.hs | 99 +++++++++++++++++++++++++++++++++++----- src/Model/Types/Lms.hs | 4 +- src/Utils/Avs.hs | 54 ++++++++-------------- 5 files changed, 189 insertions(+), 59 deletions(-) diff --git a/models/avs.model b/models/avs.model index c5978553a..5ce175d1a 100644 --- a/models/avs.model +++ b/models/avs.model @@ -3,12 +3,13 @@ UserAvs personId AvsPersonId -- unique identifier for user throughout avs user UserId - UniqueUserAvs user personId + UniqueUserAvsUser user + UniqueUserAvsId personId deriving Generic UserAvsCard personId AvsPersonId - cardNo Text + cardNo AvsCardNo card AvsDataPersonCard lastSynch UTCTime UniqueAvsCard cardNo diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 720bed254..377e22514 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -1,6 +1,8 @@ module Handler.Utils.Avs - ( checkLicences - , setLicence + ( -- upsertAvsUser + --, checkLicences + getLicence, getLicenceDB + , setLicence, setLicenceAvs, setLicencesAvs ) where import Import @@ -10,21 +12,85 @@ import Import import Utils.Avs +import qualified Data.Set as Set + + +-------------------- +-- AVS Exceptions -- +-------------------- + +data AvsException + = AvsInterfaceUnavailable + | AvsUserUnknown UserId + deriving (Show, Generic, Typeable) +instance Exception 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) +getLicence uid = do + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ runDB $ 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 (AvsUserUnknown 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 -> Handler () +setLicence uid lic = do + Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ runDB $ getBy $ UniqueUserAvsUser uid + setLicenceAvs userAvsPersonId lic + +setLicenceAvs :: AvsPersonId -> AvsLicence -> Handler () +setLicenceAvs apid lic = do + let req = Set.singleton $ AvsPersonLicence apid lic + setLicencesAvs req + +setLicencesAvs :: Set AvsPersonLicence -> Handler () +setLicencesAvs pls = do + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + AvsResponseSetLicences responses <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls + forM_ responses $ \AvsLicenceResponse{} -> + error "CONTINUE HERE" -- TODO STUB + +{- -- | 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 - AvsGetLicences _licences <- throwLeftM avsQueryGetLicences + AvsResponseGetLicences _licences <- throwLeftM avsQueryGetAllLicences --TODO this must be chunked into separate jobs/tasks - --forM licences $ \AvsDataLicence{..} -> do + --forM licences $ \AvsPersonLicence{..} -> do error "CONTINUE HERE" -- TODO STUB +-} --- Do we need this? --- getLicence :: UserId -> Handler AvsLicence +{- +upsertAvsUser :: AvsStatusPerson -> --- -setLicence :: UserId -> AvsLicence -> Handler () -setLicence _uid _al = do - error "CONTINUE HERE" -- TODO STUB \ No newline at end of file +or + +upsertAvsUser :: AvsPersonId -> +-} \ No newline at end of file diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 7f84fa578..a4a251279 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -8,8 +8,13 @@ module Model.Types.Avs ) where import Import.NoModel hiding ((.=)) +import Database.Persist.Sql +import qualified Database.Esqueleto.Experimental as E +import qualified Data.Csv as Csv import Utils.Lens.TH +import Text.Read (Read(..)) + import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.HashMap.Lazy as HM @@ -36,6 +41,14 @@ o .:?~ key = o .: key <|> maybe empty parseJSON go newtype SloppyBool = SloppyBool { sloppyBool :: Bool } deriving (Bounded, Enum, Eq, Ord, Generic, Typeable) +-- Cannot tell difference between SloppyBool and Bool through Show and Read. A good or a bad idea? +instance Show SloppyBool where + show = show . sloppyBool + +instance Read SloppyBool where + readPrec = fmap SloppyBool readPrec + -- readsPrec n s = first SloppyBool <$> readsPrec n s + instance ToJSON SloppyBool where toJSON (SloppyBool True) = "true" toJSON _ = "false" @@ -54,7 +67,26 @@ instance FromJSON SloppyBool where -- AVS Datatypes -type AvsPersonId = Int -- Could be a newtype, but then toJSON/fromJSON might be a pain? +newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) +instance E.SqlString AvsPersonId +-- AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API +instance FromJSON AvsPersonId where + parseJSON x = AvsPersonId <$> parseJSON x +instance ToJSON AvsPersonId where + toJSON (AvsPersonId pid) = toJSON pid + +newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) +instance E.SqlString AvsCardNo +-- AvsCardNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API +instance FromJSON AvsCardNo where + parseJSON x = AvsCardNo <$> parseJSON x +instance ToJSON AvsCardNo where + toJSON (AvsCardNo cno) = toJSON cno + data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld @@ -110,7 +142,7 @@ data AvsDataPersonCard = AvsDataPersonCard , avsDataPostalCode:: Maybe Text -- always Nothing if returned with AvsResponseStatus , avsDataCity :: Maybe Text -- always Nothing if returned with AvsResponseStatus , avsDataFirm :: Maybe Text -- always Nothing if returned with AvsResponseStatus - , avsDataCardNo :: Text -- always 8 digits + , avsDataCardNo :: AvsCardNo -- always 8 digits , avsDataVersionNo :: Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -161,6 +193,19 @@ instance ToJSON AvsDataPersonCard where derivePersistFieldJSON ''AvsDataPersonCard makeLenses_ ''AvsDataPersonCard -- not possible here due to module import cycle +-- The AVS API sometimes requests PersonIds as numbers and sometimes as objects. +newtype AvsObjPersonId = AvsObjPersonId + { avsObjPersonID :: AvsPersonId + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = dropCamel 2 + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsObjPersonId + data AvsStatusPerson = AvsStatusPerson { avsStatusPersonID :: AvsPersonId @@ -168,7 +213,6 @@ data AvsStatusPerson = AvsStatusPerson } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriveJSON defaultOptions { fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others } , omitNothingFields = True @@ -194,9 +238,23 @@ deriveJSON defaultOptions } ''AvsDataPerson -data AvsDataLicence = AvsDataLicence - { avsLicencePersonId :: AvsPersonId - , avsLicenceLicence :: AvsLicence +data AvsPersonLicence = AvsPersonLicence + { avsLicencePersonID :: AvsPersonId + , avsLicenceRampLicence :: AvsLicence -- Schnittstelle unklar: RampDrivingLicence oder RampLicence + --, avsLicenceRampDrivingLicence :: AvsLicence + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = dropCamel 2 + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsPersonLicence + +data AvsLicenceResponse = AvsLicenceResponse + { avsResponsePersonID :: AvsPersonId + , avsResponseSuccess :: SloppyBool + , avsResponseMessage :: Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions @@ -204,8 +262,7 @@ deriveJSON defaultOptions , omitNothingFields = True , tagSingleConstructors = False , rejectUnknownFields = False - } ''AvsDataLicence - + } ''AvsLicenceResponse -------------- @@ -230,6 +287,23 @@ deriveJSON defaultOptions , rejectUnknownFields = False } ''AvsResponsePerson +newtype AvsResponseGetLicences = AvsResponseGetLicences (Set AvsPersonLicence) + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = dropCamel 2 + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsResponseGetLicences + +newtype AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse) + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = dropCamel 2 + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsResponseSetLicences ------------- @@ -258,10 +332,13 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions ''AvsQueryStatus - -newtype AvsGetLicences = AvsGetLicences (Set AvsDataLicence) +newtype AvsQueryGetLicences = AvsQueryGetLicences (Set AvsObjPersonId) deriving (Eq, Ord, Read, Show, Generic, Typeable) -deriveJSON defaultOptions ''AvsGetLicences +deriveJSON defaultOptions ''AvsQueryGetLicences + +newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence) + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions ''AvsQuerySetLicences ----------------------- diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 3bc7b2a64..e468e7ede 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -9,7 +9,7 @@ module Model.Types.Lms import Import.NoModel import Database.Persist.Sql -import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Experimental as E import qualified Data.Csv as Csv import qualified Data.Time.Format as Time import Data.Time.Format.ISO8601 (iso8601ParseM) @@ -18,7 +18,7 @@ import Utils.Lens.TH newtype LmsIdent = LmsIdent { getLmsIdent :: Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) -instance E.SqlString LmsIdent where +instance E.SqlString LmsIdent makeLenses_ ''LmsIdent deriveJSON defaultOptions diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 8926c25d5..eda22e863 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -3,6 +3,8 @@ module Utils.Avs where import Import.NoModel import Utils.Lens +import qualified Data.Set as Set + import Servant import Servant.Client import Servant.Client.Core (requestPath) @@ -13,11 +15,12 @@ import Model.Types.Avs ------------- -- AVS API -- ------------- -type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSSetRampLicence :<|> AVSGetRampLicences) +type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSGetRampLicences :<|> AVSSetRampLicences) type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus -type AVSSetRampLicence = "SetRampDrivingLicence" :> ReqBody '[JSON] AvsDataLicence :> Post '[JSON] () -type AVSGetRampLicences = "InfoRampDrivingLicence" :> Post '[JSON] AvsGetLicences +type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences +type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences + avsApi :: Proxy AVS avsApi = Proxy @@ -32,46 +35,29 @@ data AvsQuery where -} data AvsQuery = AvsQuery - { avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson) - , avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus) - , avsQuerySetLicence :: forall m. MonadIO m => AvsDataLicence -> m (Either ClientError ()) - , avsQueryGetLicences :: forall m. MonadIO m => m (Either ClientError AvsGetLicences) + { avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson) + , avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus) + , avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences) + , avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) + , avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences) } makeLenses_ ''AvsQuery mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery - { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv - , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv - , avsQuerySetLicence = \q -> liftIO $ runClientM (rawQuerySetLicence q) cliEnv - , avsQueryGetLicences = liftIO $ runClientM rawQueryGetLicences cliEnv + { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv + , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv + , avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences allPersonIds) cliEnv + , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv + , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv } where - (rawQueryPerson :<|> rawQueryStatus :<|> rawQuerySetLicence :<|> rawQueryGetLicences) = client avsApi basicAuth + (rawQueryPerson :<|> rawQueryStatus :<|> rawQueryGetLicences :<|> rawQuerySetLicences) = client avsApi basicAuth catch404toEmpty :: Either ClientError AvsResponsePerson -> Either ClientError AvsResponsePerson catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404))) | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! - catch404toEmpty other = other + catch404toEmpty other = other - - --------------------- --- AVS Exceptions -- --------------------- - -data AvsException - = AvsInterfaceUnavailable - deriving (Show, Generic, Typeable) -instance Exception AvsException - - - -{- - 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 - --} \ No newline at end of file + allPersonIds :: AvsQueryGetLicences + allPersonIds = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId 0