chore(avs): adjust avs interface to latest spec and improve upon
This commit is contained in:
Steffen Jost
parent
a2f22b389a
commit
9d09ec676a
@ -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
|
||||
|
||||
@ -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
|
||||
or
|
||||
|
||||
upsertAvsUser :: AvsPersonId ->
|
||||
-}
|
||||
@ -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
|
||||
|
||||
|
||||
-----------------------
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
-}
|
||||
allPersonIds :: AvsQueryGetLicences
|
||||
allPersonIds = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId 0
|
||||
|
||||
Loading…
Reference in New Issue
Block a user