69 lines
3.3 KiB
Haskell
69 lines
3.3 KiB
Haskell
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)
|
|
|
|
import Model.Types.Avs
|
|
|
|
|
|
-------------
|
|
-- AVS API --
|
|
-------------
|
|
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 AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
|
|
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
|
|
|
|
|
|
avsApi :: Proxy AVS
|
|
avsApi = Proxy
|
|
|
|
{-
|
|
-- Somehow the GADT-style declaration is not flexible enough to compile at the location of the function call
|
|
data AvsQuery where
|
|
AvsQuery :: { avsQueryPerson :: MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
|
|
, avsQueryStatus :: MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
|
|
...
|
|
}
|
|
-> AvsQuery
|
|
-}
|
|
|
|
data AvsQuery = AvsQuery
|
|
{ avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
|
|
, avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
|
|
, avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
|
|
, avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences)
|
|
, avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences)
|
|
}
|
|
|
|
makeLenses_ ''AvsQuery
|
|
|
|
-- | To query all active licences, a special argument must be prepared
|
|
avsQueryAllLicences :: AvsQueryGetLicences
|
|
avsQueryAllLicences = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId $ AvsPersonId 0
|
|
|
|
|
|
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
|
|
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv
|
|
, avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
|
|
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
|
|
}
|
|
where
|
|
(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
|
|
|
|
|