From 7a6ea92063384c7814ae1036ea3a9b04384f2477 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Jul 2022 16:15:17 +0200 Subject: [PATCH] refactor(avs): account for 404 response instead of empty search results, more quickcheck tests --- .../uniworx/categories/avs/de-de-formal.msg | 2 +- messages/uniworx/categories/avs/en-eu.msg | 2 +- .../utils/navigation/menu/de-de-formal.msg | 4 +- src/Application.hs | 2 +- src/Handler/Admin/Apc.hs | 32 ++-- src/Handler/Admin/Avs.hs | 32 ++-- src/Utils/Avs.hs | 143 ++++++++---------- src/Utils/Form.hs | 4 +- test/Model/TypesSpec.hs | 22 --- test/Utils/TypesSpec.hs | 51 +++++++ 10 files changed, 157 insertions(+), 137 deletions(-) create mode 100644 test/Utils/TypesSpec.hs diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 2f01736a0..b76926886 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -4,4 +4,4 @@ AvsLastName: Nachname AvsInternalPersonalNo: Personalnummer (nur Fraport AG) AvsVersionNo: Versionsnummer AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! -AvsStatusQueryInvalid t@Text: Nur numerische IDs eingeben, durch Komma! #{show t} \ No newline at end of file +AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma! #{show t} \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index f5e5f158d..8b73a8dee 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -4,4 +4,4 @@ AvsLastName: Last name AvsInternalPersonalNo: Personnel number (Fraport AG only) AvsVersionNo: Version number AvsQueryEmpty: At least one query field must be filled! -AvsStatusQueryInvalid t: Numeric IDs only, comma seperated! #{show t} \ No newline at end of file +AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t} \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index d3d7fface..2866ab4fa 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -132,8 +132,8 @@ MenuLmsResult: Melden Ergebnisse E-Lernen MenuLmsUpload: Hochladen MenuLmsDirect: Direkter Upload -MenuAvs: Schnitstelle AVS -MenuApc: Schnitstelle Druckerei +MenuAvs: Schnittstelle AVS +MenuApc: Schnittstelle Druckerei MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index a75e8b8bb..44a0c2f37 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -364,7 +364,7 @@ makeFoundation appSettings''@AppSettings{..} = do { basicAuthUsername = avsUser avsConf , basicAuthPassword = avsPass avsConf } - return . Just $ mkAvsQuery avsAuth avsEnv + return . Just $ mkAvsQuery avsServer avsAuth avsEnv $logDebugS "Runtime configuration" $ tshow appSettings' diff --git a/src/Handler/Admin/Apc.hs b/src/Handler/Admin/Apc.hs index 540c28acb..0f6e2881d 100644 --- a/src/Handler/Admin/Apc.hs +++ b/src/Handler/Admin/Apc.hs @@ -27,18 +27,18 @@ data MetaPinRenewal = MetaPinRenewal -} {- -makePrintForm :: Maybe AvsPersonQuery -> Form AvsPersonQuery -makeAvsPersonForm tmpl = identifyForm FIDAvsPersonQuery . validateForm validateAvsPersonQuery $ \html -> - flip (renderAForm FormStandard) html $ AvsPersonQuery +makePrintForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson +makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> + flip (renderAForm FormStandard) html $ AvsQueryPerson <$> aopt textField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> tmpl) <*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl) <*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl) <*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl) <*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl) -validateAvsPersonQuery :: FormValidator AvsPersonQuery Handler () -validateAvsPersonQuery = do - AvsPersonQuery{..} <- State.get +validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler () +validateAvsQueryPerson = do + AvsQueryPerson{..} <- State.get guardValidation MsgAvsQueryEmpty $ is _Just avsPersonQueryCardNo || is _Just avsPersonQueryFirstName || @@ -46,23 +46,23 @@ validateAvsPersonQuery = do is _Just avsPersonQueryInternalPersonalNo || is _Just avsPersonQueryVersionNo -makeAvsStatusForm :: Maybe AvsStatusQuery -> Form AvsStatusQuery -makeAvsStatusForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html -> +makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus +makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html -> flip (renderAForm FormStandard) html $ parseAvsIds <$> areq textField (fslI MsgAvsCardNo) (unparseAvsIds <$> tmpl) where - parseAvsIds :: Text -> AvsStatusQuery - parseAvsIds txt = AvsStatusQuery $ Set.fromList ids + parseAvsIds :: Text -> AvsQueryStatus + parseAvsIds txt = AvsQueryStatus $ Set.fromList ids where nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt ids = catMaybes $ readMay <$> nonemptys - unparseAvsIds :: AvsStatusQuery -> Text - unparseAvsIds (AvsStatusQuery ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids + unparseAvsIds :: AvsQueryStatus -> Text + unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids -validateAvsStatusQuery :: FormValidator AvsStatusQuery Handler () -validateAvsStatusQuery = do - AvsStatusQuery ids <- State.get - guardValidation (MsgAvsStatusQueryInvalid $ tshow ids) $ not (null ids) +validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler () +validateAvsQueryStatus = do + AvsQueryStatus ids <- State.get + guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids) -} getAdminApcR, postAdminApcR :: Handler Html getAdminApcR = postAdminApcR diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 0d9f708a1..2c0a2367e 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -14,18 +14,18 @@ import Handler.Utils import Utils.Avs -makeAvsPersonForm :: Maybe AvsPersonQuery -> Form AvsPersonQuery -makeAvsPersonForm tmpl = identifyForm FIDAvsPersonQuery . validateForm validateAvsPersonQuery $ \html -> - flip (renderAForm FormStandard) html $ AvsPersonQuery +makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson +makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> + flip (renderAForm FormStandard) html $ AvsQueryPerson <$> aopt textField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> tmpl) <*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl) <*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl) <*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl) <*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl) -validateAvsPersonQuery :: FormValidator AvsPersonQuery Handler () -validateAvsPersonQuery = do - AvsPersonQuery{..} <- State.get +validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler () +validateAvsQueryPerson = do + AvsQueryPerson{..} <- State.get guardValidation MsgAvsQueryEmpty $ is _Just avsPersonQueryCardNo || is _Just avsPersonQueryFirstName || @@ -33,23 +33,23 @@ validateAvsPersonQuery = do is _Just avsPersonQueryInternalPersonalNo || is _Just avsPersonQueryVersionNo -makeAvsStatusForm :: Maybe AvsStatusQuery -> Form AvsStatusQuery -makeAvsStatusForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html -> +makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus +makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html -> flip (renderAForm FormStandard) html $ parseAvsIds <$> areq textField (fslI MsgAvsCardNo) (unparseAvsIds <$> tmpl) where - parseAvsIds :: Text -> AvsStatusQuery - parseAvsIds txt = AvsStatusQuery $ Set.fromList ids + parseAvsIds :: Text -> AvsQueryStatus + parseAvsIds txt = AvsQueryStatus $ Set.fromList ids where nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt ids = catMaybes $ readMay <$> nonemptys - unparseAvsIds :: AvsStatusQuery -> Text - unparseAvsIds (AvsStatusQuery ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids + unparseAvsIds :: AvsQueryStatus -> Text + unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids -validateAvsStatusQuery :: FormValidator AvsStatusQuery Handler () -validateAvsStatusQuery = do - AvsStatusQuery ids <- State.get - guardValidation (MsgAvsStatusQueryInvalid $ tshow ids) $ not (null ids) +validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler () +validateAvsQueryStatus = do + AvsQueryStatus ids <- State.get + guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids) getAdminAvsR, postAdminAvsR :: Handler Html getAdminAvsR = postAdminAvsR diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index fe94de9c3..0c5f93544 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} - module Utils.Avs where import Import.NoModel hiding ((.=)) @@ -14,15 +12,14 @@ import Data.Aeson.Types import Servant import Servant.Client - --- import qualified Network.HTTP.Client as HTTP (newManager, defaultManagerSettings) -- just to speed up type checking +import Servant.Client.Core (requestPath) -- | Like (.:) but attempts parsing with case-insensitve keys as fallback. --- Note that the type also works for optional Field +-- Note that the type also works for an optional field -- Taken from Data.Aeson.Filthy, which could somehow not be added as a dependency. -(.:~) :: FromJSON a => Object -> Text -> Parser a +(.:~) :: FromJSON a => Object -> Text -> Parser a o .:~ key = o .: key <|> maybe empty parseJSON go where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o] @@ -41,10 +38,16 @@ instance ToJSON SloppyBool where toJSON _ = "false" instance FromJSON SloppyBool where - parseJSON (Bool b) = pure $ SloppyBool b + parseJSON (Bool b) = pure $ SloppyBool b parseJSON (String t) - | Text.toLower t == "true" = pure $ SloppyBool True - parseJSON _ = pure $ SloppyBool False + | lowb == "true" = true + | lowb == "t" = true + | lowb == "f" = false + | lowb == "false" = false + where lowb = Text.toLower $ Text.strip t + true = pure $ SloppyBool True + false = pure $ SloppyBool False + parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid type AvsPersonId = Int @@ -58,24 +61,24 @@ instance ToJSON AvsDataCardColor where toJSON AvsCardColorGelb = "Gelb" toJSON (AvsCardColorMisc t) = String t -instance FromJSON AvsDataCardColor where - parseJSON (String t) = case Text.toLower t of - "grün" -> pure AvsCardColorGrün +instance FromJSON AvsDataCardColor where + parseJSON (String t) = case Text.toLower t of + "grün" -> pure AvsCardColorGrün "blau" -> pure AvsCardColorBlau - "rot" -> pure AvsCardColorRot + "rot" -> pure AvsCardColorRot "gelb" -> pure AvsCardColorGelb _ -> pure $ AvsCardColorMisc t parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid) -data AvsDataPersonCard = AvsDataPersonCard +data AvsDataPersonCard = AvsDataPersonCard { avsDataCardAreas :: Set Char -- logically a set of upper-case letters , avsDataCardColor :: AvsDataCardColor - , avsDataCardNo :: Text -- always 8 digits + , avsDataCardNo :: Text -- always 8 digits , avsDataVersionNo :: Text , avsDataValid :: Bool -- unfortunately, AVS encodes Booleans as JSON String "true" and "false" and not as JSON Booleans -- only the above are contained in AvsResponseStatus - , avsDataValidTo :: Maybe Day - , avsDataIssueDate :: Maybe Day + , avsDataValidTo :: Maybe Day + , avsDataIssueDate :: Maybe Day , avsDataFirm :: Maybe Text , avsDataCity :: Maybe Text , avsDataStreet :: Maybe Text @@ -84,12 +87,12 @@ data AvsDataPersonCard = AvsDataPersonCard deriving (Eq, Ord, Read, Show, Generic, Typeable) {- Instead of programming entirely by hand, why not dump splices and adjust? -} -instance FromJSON AvsDataPersonCard where +instance FromJSON AvsDataPersonCard where parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard <$> ((v .: "CardAreas") <&> charSet) <*> v .: "CardColor" - <*> v .: "CardNo" - <*> v .: "VersionNo" + <*> v .: "CardNo" + <*> v .: "VersionNo" <*> ((v .: "Valid") <&> sloppyBool) <*> v .:? "ValidTo" <*> v .:? "IssueDate" @@ -100,7 +103,7 @@ instance FromJSON AvsDataPersonCard where instance ToJSON AvsDataPersonCard where - toJSON AvsDataPersonCard{..} = object + toJSON AvsDataPersonCard{..} = object [ "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas , "CardColor" .= avsDataCardColor , "CardNo" .= avsDataCardNo @@ -125,14 +128,14 @@ deriveJSON defaultOptions { fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others } , omitNothingFields = True , tagSingleConstructors = False - , rejectUnknownFields = False + , rejectUnknownFields = False } ''AvsStatusPerson data AvsDataPerson = AvsDataPerson - { avsPersonFirstName :: Text - , avsPersonLastName :: Text + { avsPersonFirstName :: Text + , avsPersonLastName :: Text , avsPersonInternalPersonalNo :: Maybe Text -- Fraport Personalnummer - , avsPersonPersonNo :: AvsPersonId -- AVS Personennummer + , avsPersonPersonNo :: AvsPersonId -- AVS Personennummer , avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle! , avsPersonPersonCards :: Set AvsDataPersonCard } @@ -142,7 +145,7 @@ deriveJSON defaultOptions { fieldLabelModifier = \case { "avsPersonPersonCards" -> "personCards"; others -> dropCamel 2 others } , omitNothingFields = True , tagSingleConstructors = False - , rejectUnknownFields = False + , rejectUnknownFields = False } ''AvsDataPerson @@ -157,16 +160,16 @@ deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True , tagSingleConstructors = False - , rejectUnknownFields = False + , rejectUnknownFields = False } ''AvsResponseStatus newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) deriving (Eq, Ord, Read, Show, Generic, Typeable) -deriveJSON defaultOptions +deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True , tagSingleConstructors = False - , rejectUnknownFields = False + , rejectUnknownFields = False } ''AvsResponsePerson @@ -174,7 +177,7 @@ deriveJSON defaultOptions ------------- -- Queries -- ------------- -data AvsPersonQuery = AvsPersonQuery +data AvsQueryPerson = AvsQueryPerson { avsPersonQueryCardNo :: Maybe Text , avsPersonQueryFirstName :: Maybe Text , avsPersonQueryLastName :: Maybe Text @@ -183,18 +186,19 @@ data AvsPersonQuery = AvsPersonQuery } deriving (Eq, Ord, Read, Show, Generic, Typeable) -instance Default AvsPersonQuery where - def = AvsPersonQuery Nothing Nothing Nothing Nothing Nothing +instance Default AvsQueryPerson where + def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing -deriveJSON defaultOptions +deriveJSON defaultOptions { fieldLabelModifier = dropCamel 3 , omitNothingFields = True , tagSingleConstructors = False - , rejectUnknownFields = False - } ''AvsPersonQuery + , rejectUnknownFields = False + } ''AvsQueryPerson -newtype AvsStatusQuery = AvsStatusQuery (Set AvsPersonId) -deriveJSON defaultOptions ''AvsStatusQuery +newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions ''AvsQueryStatus @@ -202,58 +206,45 @@ deriveJSON defaultOptions ''AvsStatusQuery -- AVS API -- ------------- type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus) -type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsResponsePerson -type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsResponseStatus +type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson +type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus 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 => AvsPersonQuery -> m (Either ClientError AvsResponsePerson) - , avsQueryStatus :: MonadIO m => AvsStatusQuery -> m (Either ClientError AvsResponseStatus) - } +{- +-- 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 => AvsPersonQuery -> m (Either ClientError AvsResponsePerson) - , avsQueryStatus :: forall m. MonadIO m => AvsStatusQuery -> m (Either ClientError AvsResponseStatus) + { avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson) + , avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus) } makeLenses_ ''AvsQuery -mkAvsQuery :: BasicAuthData -> ClientEnv -> AvsQuery -mkAvsQuery basicAuth cliEnv = AvsQuery - { avsQueryPerson = \q -> liftIO $ runClientM (rawQueryPerson q) cliEnv - , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv +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 } - where - (rawQueryPerson :<|> rawQueryStatus) = client avsApi basicAuth + where + (rawQueryPerson :<|> rawQueryStatus) = 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 - -{- --- DEMO to check that it types here instead of waiting for Application to be compiled -run :: IO () -run = do - let (_avsPersonSearch :<|> avsPersonStatus) = client avsApi avsAuth - manager' <- HTTP.newManager HTTP.defaultManagerSettings - let query = avsPersonStatus $ AvsStatusQuery $ Set.singleton 123 - res <- runClientM query (mkClientEnv manager' avsServer) - case res of - Left err -> putStrLn $ "Error: " ++ tshow err - --Right resp -> do - Right (AvsResponseStatus resp) -> do - print resp - where - avsServer :: BaseUrl - avsServer = BaseUrl - { baseUrlScheme = Https - , baseUrlHost = "skytest.fra.fraport.de" - , baseUrlPort = 80 - , baseUrlPath = "" - } - - avsAuth = BasicAuthData "foo" "bar" +{- + 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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 5528d88eb..8b4497dcf 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -295,8 +295,8 @@ data FormIdentifier | FIDTestDownload | FIDAllocationRegister | FIDAllocationNotification - | FIDAvsPersonQuery - | FIDAvsStatusQuery + | FIDAvsQueryPerson + | FIDAvsQueryStatus deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 8f487ca30..57febf387 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -401,24 +401,6 @@ instance Arbitrary SheetAuthorshipStatementMode where instance Arbitrary LmsStatus where arbitrary = genericArbitrary -instance Arbitrary AvsDataCardColor where - arbitrary = genericArbitrary - -instance Arbitrary AvsDataPersonCard where - arbitrary = genericArbitrary - -instance Arbitrary AvsStatusPerson where - arbitrary = genericArbitrary - -instance Arbitrary AvsDataPerson where - arbitrary = genericArbitrary - -instance Arbitrary AvsResponsePerson where - arbitrary = genericArbitrary - -instance Arbitrary AvsResponseStatus where - arbitrary = genericArbitrary - spec :: Spec spec = do @@ -533,10 +515,6 @@ spec = do [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ] lawsCheckHspec (Proxy @LmsStatus) [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ] - lawsCheckHspec (Proxy @AvsResponsePerson) - [ eqLaws, showLaws, showReadLaws, jsonLaws] - lawsCheckHspec (Proxy @AvsResponseStatus) - [ eqLaws, showLaws, showReadLaws, jsonLaws] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs new file mode 100644 index 000000000..12432f194 --- /dev/null +++ b/test/Utils/TypesSpec.hs @@ -0,0 +1,51 @@ +module Utils.TypesSpec where + +import TestImport + +import Utils.Avs + + +instance Arbitrary AvsDataCardColor where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsDataPersonCard where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsStatusPerson where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsDataPerson where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsResponsePerson where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsResponseStatus where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsQueryStatus where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsQueryPerson where + arbitrary = genericArbitrary + shrink = genericShrink + + +spec :: Spec +spec = do + parallel $ do + lawsCheckHspec (Proxy @AvsResponsePerson) + [ eqLaws, showLaws, showReadLaws, jsonLaws] + lawsCheckHspec (Proxy @AvsResponseStatus) + [ eqLaws, showLaws, showReadLaws, jsonLaws] + lawsCheckHspec (Proxy @AvsQueryPerson) + [ eqLaws, showLaws, showReadLaws, jsonLaws] + lawsCheckHspec (Proxy @AvsQueryStatus) + [ eqLaws, showLaws, showReadLaws, jsonLaws]