From a1272e38b72d146b881492341a86e1fc544ab0ff Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Sep 2022 18:00:28 +0200 Subject: [PATCH] feat(avs): add SetRampDrivingLicence and InfoRampDrivingLicence to AVS interface --- src/Model/Types/Avs.hs | 67 ++++++++++++++++++++++++++++++++++-------- src/Utils/Avs.hs | 28 +++++++++++------- 2 files changed, 72 insertions(+), 23 deletions(-) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 237803524..aca992367 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -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 diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 0b52818ea..0f82e470f 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -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 + -} \ No newline at end of file