chore(avs): formalize all avs responses to proper datatypes
This commit is contained in:
Steffen Jost
parent
a8dc8f6d90
commit
7a717923b2
@ -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
|
||||
|
||||
175
src/Utils/Avs.hs
175
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)
|
||||
}
|
||||
|
||||
|
||||
@ -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]
|
||||
|
||||
|
||||
4
testdata/avs_json.hs
vendored
4
testdata/avs_json.hs
vendored
@ -1,4 +1,6 @@
|
||||
|
||||
-- usage:
|
||||
-- > npm run build
|
||||
-- > stack ghci -- testdata/avs_json.hs
|
||||
|
||||
import Prelude
|
||||
import Data.String
|
||||
|
||||
Loading…
Reference in New Issue
Block a user