diff --git a/src/Utils.hs b/src/Utils.hs index d7f9badf4..fbd57f6d2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -314,6 +314,10 @@ msg2widget msg = [whamlet|_{msg}|] withFragment :: Monad m => MForm m (a, WidgetFor site ()) -> Markup -> MForm m (a, WidgetFor site ()) withFragment form html = flip fmap form $ over _2 (toWidget html >>) +-- | Burst Text into an unordered set of letters +charSet :: Text -> Set Char +charSet = Text.foldl (flip Set.insert) mempty + -- | Convert `part` and `whole` into percentage including symbol -- showing trailing zeroes and to decimal digits textPercent :: Real a => a -> a -> Text diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index bf174bbd6..1976ea25f 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -20,16 +20,17 @@ import qualified Network.HTTP.Client as HTTP (newManager, defaultManagerSettings + -- | Like (.:) but attempts parsing with case-insensitve keys as fallback. -- Taken from Data.Aeson.Filthy, which could somehow not be added as a dependency. {- -(.:~) :: FromJSON a => Object -> Text -> Parser a -- would be useful for AvsDataPerson, where Case is inconsistently encoded +(.:~) :: FromJSON a => Object -> Text -> Parser a -- would be useful for AvsDataPersonStatus, where Case is inconsistently encoded o .:~ key = o .: key <|> maybe empty parseJSON go where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o] -} newtype SloppyBool = SloppyBool { sloppyBool :: Bool } - deriving (Bounded, Enum, Eq, Ord, Read, Show, Ix, Generic) + deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable) instance ToJSON SloppyBool where toJSON (SloppyBool True) = "true" @@ -41,8 +42,10 @@ instance FromJSON SloppyBool where | Text.toLower t == "true" = pure $ SloppyBool True parseJSON _ = pure $ SloppyBool False +type AvsPersonId = Int + data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Read, Show, Generic, Typeable) instance ToJSON AvsDataCardColor where toJSON AvsCardColorGrün = "Grün" @@ -60,9 +63,113 @@ instance FromJSON AvsDataCardColor where _ -> pure $ AvsCardColorMisc t parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid) -type AvsPersonResponse = Value -type AvsStatusResponse = Value +data AvsStatusPerson = AvsStatusPerson + { avsStatusPersonID :: AvsPersonId + , avsStatusPersonCardStatus :: Set AvsDataPersonCard + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +data AvsDataPersonCard = AvsDataPersonCard + { avsDataCardAreas :: Set Char -- logically a set of upper-case letters + , avsDataCardColor :: AvsDataCardColor + , 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 + , avsDataFirm :: Maybe Text + , avsDataCity :: Maybe Text + , avsDataStreet :: Maybe Text + , avsDataPostalCode:: Maybe Text + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +{- Instead of programming entirely by hand, why not dump splices and adjust? -} +instance FromJSON AvsDataPersonCard where + parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard + <$> ((v .: "CardAreas") <&> charSet) + <*> v .: "CardColor" + <*> v .: "CardNo" + <*> v .: "VersionNo" + <*> ((v .: "Valid") <&> sloppyBool) + <*> v .:? "ValidTo" + <*> v .:? "IssueDate" + <*> v .:? "Firm" + <*> v .:? "City" + <*> v .:? "Street" + <*> v .:? "PostalCode" + + +instance ToJSON AvsDataPersonCard where + toJSON AvsDataPersonCard{..} = object + [ "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas + , "CardColor" .= avsDataCardColor + , "CardNo" .= avsDataCardNo + , "VersionNo" .= avsDataVersionNo + , "Valid" .= show avsDataValid + , "ValidTo" .= avsDataValidTo + , "IssueDate" .= avsDataIssueDate + , "Firm" .= avsDataFirm + , "City" .= avsDataCity + , "Street" .= avsDataStreet + , "PostalCode" .= avsDataPostalCode + ] + +deriveJSON defaultOptions + { fieldLabelModifier = \case { "avsDataPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others } + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsStatusPerson + +data AvsDataPerson = AvsDataPerson + { avsPersonFirstName :: Text + , avsPersonLastName :: Text + , avsPersonInternalPersonalNo :: Maybe Text -- Fraport Personalnummer + , avsPersonPersonNo :: AvsPersonId -- AVS Personennummer + , avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle! + , avsPersonPersonCards :: Set AvsDataPersonCard + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = \case { "avsPersonPersonCards" -> "personCards"; others -> dropCamel 2 others } + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsDataPerson + + + +-------------- +-- Responses -- +--------------- + +newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = dropCamel 2 + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsResponseStatus + +newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = dropCamel 2 + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsResponsePerson + + + +------------- +-- Queries -- +------------- data AvsPersonQuery = AvsPersonQuery { avsPersonQueryCardNo :: Maybe Text , avsPersonQueryFirstName :: Maybe Text @@ -82,60 +189,16 @@ deriveJSON defaultOptions , rejectUnknownFields = False } ''AvsPersonQuery -newtype AvsStatusQuery = AvsStatusQuery (Set Int) +newtype AvsStatusQuery = AvsStatusQuery (Set AvsPersonId) deriveJSON defaultOptions ''AvsStatusQuery -newtype AvsResponseStatus = AvsResponseStatus (Set AvsDataPerson) - deriving (Eq, Ord, Read, Show, Generic, Typeable) -data AvsDataPerson = AvsDataPerson - { avsDataPersonID :: Int - , avsDataPersonCardStatus :: Set AvsDataPersonCard - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) -data AvsDataPersonCard = AvsDataPersonCard - { avsDataCardAreas :: Maybe String - , avsDataCardColor :: AvsDataCardColor - , avsDataCardNo :: String - , avsDataValid :: Bool -- unfortunately, AVS encodes Booleans as JSON String "true" and "false" and not as JSON Booleans - , avsDataVersionNo :: String - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -{- Instead of programming entirely by hand, why not dump splices and adjust? -} -instance FromJSON AvsDataPersonCard where - parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard - <$> v .:? "CardAreas" - <*> v .: "CardColor" - <*> v .: "CardNo" - <*> (sloppyBool <$> (v .: "Valid")) - <*> v .: "VersionNo" - -instance ToJSON AvsDataPersonCard where - toJSON AvsDataPersonCard{..} = object - [ "CardAreas" .= avsDataCardAreas - , "CardColor" .= avsDataCardColor - , "CardNo" .= avsDataCardNo - , "Valid" .= show avsDataValid - , "VersionNo" .= avsDataVersionNo - ] - -deriveJSON defaultOptions - { fieldLabelModifier = \case { "avsDataPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others } - , omitNothingFields = True - , tagSingleConstructors = False - , rejectUnknownFields = False - } ''AvsDataPerson - -deriveJSON defaultOptions - { fieldLabelModifier = dropCamel 2 - , omitNothingFields = True - , tagSingleConstructors = False - , rejectUnknownFields = False - } ''AvsResponseStatus +------------- +-- AVS API -- +------------- type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus) -type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsPersonResponse +type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsResponsePerson type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsResponseStatus avsApi :: Proxy AVS @@ -143,14 +206,14 @@ 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 AvsPersonResponse) + AvsQuery :: { avsQueryPerson :: MonadIO m => AvsPersonQuery -> m (Either ClientError AvsResponsePerson) , avsQueryStatus :: MonadIO m => AvsStatusQuery -> m (Either ClientError AvsResponseStatus) } -> AvsQuery -} data AvsQuery = AvsQuery - { avsQueryPerson :: forall m. MonadIO m => AvsPersonQuery -> m (Either ClientError AvsPersonResponse) + { avsQueryPerson :: forall m. MonadIO m => AvsPersonQuery -> m (Either ClientError AvsResponsePerson) , avsQueryStatus :: forall m. MonadIO m => AvsStatusQuery -> m (Either ClientError AvsResponseStatus) } diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index fa6a7d530..8f487ca30 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -54,6 +54,7 @@ import qualified Data.SemVer.Constraint as SemVer.Constraint import qualified Data.HashSet as HashSet +import Utils.Avs -- not sure that this belongs here {- instance Arbitrary Day where @@ -400,6 +401,25 @@ 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 parallel $ do @@ -513,6 +533,8 @@ 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] diff --git a/testdata/avs_json.hs b/testdata/avs_json.hs index 0251c7640..4c71d4844 100644 --- a/testdata/avs_json.hs +++ b/testdata/avs_json.hs @@ -1,4 +1,6 @@ - +-- usage: +-- > npm run build +-- > stack ghci -- testdata/avs_json.hs import Prelude import Data.String