feat(avs): add SetRampDrivingLicence and InfoRampDrivingLicence to AVS interface
This commit is contained in:
Steffen Jost
parent
227970e4b1
commit
a1272e38b7
@ -8,7 +8,7 @@ module Model.Types.Avs
|
||||
) where
|
||||
|
||||
import Import.NoModel hiding ((.=))
|
||||
--import Utils.Lens hiding ((.=))
|
||||
import Utils.Lens.TH
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
@ -34,7 +34,7 @@ o .:?~ key = o .: key <|> maybe empty parseJSON go
|
||||
|
||||
-- | `SloppyBool` successfully parses different variations of true/false
|
||||
newtype SloppyBool = SloppyBool { sloppyBool :: Bool }
|
||||
deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving (Bounded, Enum, Eq, Ord, Generic, Typeable)
|
||||
|
||||
instance ToJSON SloppyBool where
|
||||
toJSON (SloppyBool True) = "true"
|
||||
@ -53,18 +53,34 @@ instance FromJSON SloppyBool where
|
||||
parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid
|
||||
|
||||
|
||||
type AvsPersonId = Int
|
||||
-- AVS Datatypes
|
||||
type AvsPersonId = Int -- Could be a newtype, but then toJSON/fromJSON might be a pain?
|
||||
|
||||
|
||||
type AvsLicence = Char
|
||||
licenceVorfeld :: AvsLicence
|
||||
licenceVorfeld = 'F'
|
||||
licenceRollfeld :: AvsLicence
|
||||
licenceRollfeld = 'R'
|
||||
data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld
|
||||
deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON AvsLicence where
|
||||
toJSON AvsNoLicence = Number 0
|
||||
toJSON AvsLicenceVorfeld = Number 1
|
||||
toJSON AvsLicenceRollfeld = Number 2
|
||||
|
||||
instance FromJSON AvsLicence where
|
||||
parseJSON (Number n) | n == 0 = pure AvsNoLicence
|
||||
| n == 1 = pure AvsLicenceVorfeld
|
||||
| n == 2 = pure AvsLicenceRollfeld
|
||||
parseJSON invalid = prependFailure "parsing AvsLicence failed, " $ fail $ "expected Int value being 0, 1 or 2. Found " ++ show invalid
|
||||
|
||||
-- | Ought to be identical to QualificationShortname!
|
||||
licence2char :: AvsLicence -> Char
|
||||
licence2char AvsNoLicence = '0'
|
||||
licence2char AvsLicenceVorfeld = 'F'
|
||||
licence2char AvsLicenceRollfeld = 'R'
|
||||
|
||||
|
||||
data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (NFData)
|
||||
|
||||
instance ToJSON AvsDataCardColor where
|
||||
toJSON AvsCardColorGrün = "Grün"
|
||||
@ -82,6 +98,7 @@ instance FromJSON AvsDataCardColor where
|
||||
_ -> pure $ AvsCardColorMisc t
|
||||
parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid)
|
||||
|
||||
|
||||
data AvsDataPersonCard = AvsDataPersonCard
|
||||
{ avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans
|
||||
, avsDataValidTo :: Maybe Day -- always Nothing if returned with AvsResponseStatus
|
||||
@ -96,6 +113,7 @@ data AvsDataPersonCard = AvsDataPersonCard
|
||||
, avsDataVersionNo :: Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (NFData)
|
||||
|
||||
{- Automatically derived Ord instance should prioritize avsDataValid and avsDataValidTo. Checked in test/Model.TypesSpec
|
||||
instance Ord AvsDataPersonCard where
|
||||
@ -139,6 +157,10 @@ instance ToJSON AvsDataPersonCard where
|
||||
, "PostalCode" .= avsDataPostalCode
|
||||
]
|
||||
|
||||
derivePersistFieldJSON ''AvsDataPersonCard
|
||||
makeLenses_ ''AvsDataPersonCard -- not possible here due to module import cycle
|
||||
|
||||
|
||||
data AvsStatusPerson = AvsStatusPerson
|
||||
{ avsStatusPersonID :: AvsPersonId
|
||||
, avsStatusPersonCardStatus :: Set AvsDataPersonCard
|
||||
@ -171,6 +193,19 @@ deriveJSON defaultOptions
|
||||
} ''AvsDataPerson
|
||||
|
||||
|
||||
data AvsDataLicence = AvsDataLicence
|
||||
{ avsLicencePersonId :: AvsPersonId
|
||||
, avsLicenceLicence :: AvsLicence
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 2
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsDataLicence
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
-- Responses --
|
||||
@ -221,6 +256,11 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
|
||||
deriveJSON defaultOptions ''AvsQueryStatus
|
||||
|
||||
|
||||
newtype AvsGetLicences = AvsGetLicences (Set AvsDataLicence)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions ''AvsGetLicences
|
||||
|
||||
|
||||
-----------------------
|
||||
-- Utility Functions --
|
||||
-----------------------
|
||||
@ -229,20 +269,21 @@ deriveJSON defaultOptions ''AvsQueryStatus
|
||||
-- first argument is a lower bound for avsDataValidTo, usually current day
|
||||
-- Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case)
|
||||
getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
|
||||
getValidLicence cutoff licence cards = Set.lookupMax validLicenceCards
|
||||
getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
|
||||
where
|
||||
licence = licence2char licence'
|
||||
validLicenceCards = Set.filter cardMatch cards
|
||||
cardMatch AvsDataPersonCard{..} =
|
||||
avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
|
||||
|
||||
guessLicencseAddress :: Set AvsDataPersonCard -> Maybe Text
|
||||
guessLicencseAddress cards
|
||||
guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text)
|
||||
guessLicenceAddress cards
|
||||
| Just c <- Set.lookupMax cards
|
||||
, AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
|
||||
, Just street <- avsDataStreet
|
||||
, Just pcode <- avsDataPostalCode
|
||||
, Just city <- avsDataCity
|
||||
= Just $ Text.unlines [street, Text.unwords [pcode, city]]
|
||||
= Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]])
|
||||
| otherwise = Nothing
|
||||
|
||||
hasAddress :: AvsDataPersonCard -> Bool
|
||||
@ -264,6 +305,8 @@ pickLicenceAddress a b
|
||||
where
|
||||
pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
|
||||
pickBetter' = pickBetter a b
|
||||
licenceRollfeld = licence2char AvsLicenceRollfeld
|
||||
licenceVorfeld = licence2char AvsLicenceVorfeld
|
||||
|
||||
{- Note:
|
||||
For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this can be conveniently be used like so
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
module Utils.Avs where
|
||||
|
||||
import Import.NoModel hiding ((.=))
|
||||
import Utils.Lens hiding ((.=))
|
||||
import Import.NoModel
|
||||
import Utils.Lens
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
@ -13,9 +13,11 @@ import Model.Types.Avs
|
||||
-------------
|
||||
-- AVS API --
|
||||
-------------
|
||||
type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus)
|
||||
type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
|
||||
type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
|
||||
type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSSetRampLicence :<|> AVSGetRampLicences)
|
||||
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
|
||||
|
||||
avsApi :: Proxy AVS
|
||||
avsApi = Proxy
|
||||
@ -30,20 +32,23 @@ 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)
|
||||
{ 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)
|
||||
}
|
||||
|
||||
|
||||
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
|
||||
{ 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
|
||||
}
|
||||
where
|
||||
(rawQueryPerson :<|> rawQueryStatus) = client avsApi basicAuth
|
||||
(rawQueryPerson :<|> rawQueryStatus :<|> rawQuerySetLicence :<|> rawQueryGetLicences) = 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!
|
||||
@ -55,4 +60,5 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
|
||||
- add query to Auth.LDAP.campusUserMatr
|
||||
- add query to Auth.LDAP.campusLogin
|
||||
- jobs.Handler.dispatchJobSynchroniseLdap
|
||||
|
||||
-}
|
||||
Loading…
Reference in New Issue
Block a user