feat(avs): add extraction functions for avs datatypes and tests
This commit is contained in:
Steffen Jost
parent
188f101eed
commit
f8afca0598
@ -39,6 +39,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
mobile Text Maybe
|
||||
companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP
|
||||
companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available
|
||||
-- pinPassword Text Maybe -- used to encrypt pins within emails
|
||||
postAddress StoredMarkup Maybe
|
||||
prefersPostal Bool default=false -- user prefers letters by post instead of email
|
||||
examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default
|
||||
|
||||
@ -78,7 +78,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
-- let msgrenewal = $(i18nHamletFile "qualification/renewal") -- :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
|
||||
-- addHtmlMarkdownAlternatives' msgrenewal
|
||||
|
||||
encryptPDF "tomatenmarmelade" pdf >>= \case
|
||||
encryptPDF "tomatenmarmelade" pdf >>= \case -- TODO: replace with user password!
|
||||
Left err -> do
|
||||
let msg = "Notify " <> tshow jRecipient <> " PDF encryption failed with error: " <> err
|
||||
$logErrorS "LMS" msg
|
||||
|
||||
@ -25,5 +25,6 @@ import Model.Types.Room as Types
|
||||
import Model.Types.Csv as Types
|
||||
import Model.Types.Upload as Types
|
||||
import Model.Types.Lms as Types
|
||||
import Model.Types.Avs as Types
|
||||
import Model.Types.Communication as Types
|
||||
import Model.Types.SystemMessage as Types
|
||||
|
||||
281
src/Model/Types/Avs.hs
Normal file
281
src/Model/Types/Avs.hs
Normal file
@ -0,0 +1,281 @@
|
||||
{-|
|
||||
Module: Model.Types.Avs
|
||||
Description: Types for interface to AusweisVerwaltungsSystem (AVS)
|
||||
-}
|
||||
|
||||
module Model.Types.Avs
|
||||
( module Model.Types.Avs
|
||||
) where
|
||||
|
||||
import Import.NoModel hiding ((.=))
|
||||
--import Utils.Lens hiding ((.=))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.HashMap.Lazy as HM
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
|
||||
|
||||
-- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
|
||||
-- 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
|
||||
o .:~ key = o .: key <|> maybe empty parseJSON go
|
||||
where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o]
|
||||
|
||||
{-
|
||||
-- Like (.:?) but attempts parsing with case-insensitve keys as fallback.
|
||||
(.:?~) :: FromJSON a => Object -> Text -> Parser (Maybe a)
|
||||
o .:?~ key = o .: key <|> maybe empty parseJSON go
|
||||
where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o]
|
||||
-}
|
||||
|
||||
-- | `SloppyBool` successfully parses different variations of true/false
|
||||
newtype SloppyBool = SloppyBool { sloppyBool :: Bool }
|
||||
deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON SloppyBool where
|
||||
toJSON (SloppyBool True) = "true"
|
||||
toJSON _ = "false"
|
||||
|
||||
instance FromJSON SloppyBool where
|
||||
parseJSON (Bool b) = pure $ SloppyBool b
|
||||
parseJSON (String t)
|
||||
| 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
|
||||
|
||||
|
||||
type AvsLicence = Char
|
||||
licenceVorfeld :: AvsLicence
|
||||
licenceVorfeld = 'F'
|
||||
licenceRollfeld :: AvsLicence
|
||||
licenceRollfeld = 'R'
|
||||
|
||||
|
||||
data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON AvsDataCardColor where
|
||||
toJSON AvsCardColorGrün = "Grün"
|
||||
toJSON AvsCardColorBlau = "Blau"
|
||||
toJSON AvsCardColorRot = "Rot"
|
||||
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
|
||||
"blau" -> pure AvsCardColorBlau
|
||||
"rot" -> pure AvsCardColorRot
|
||||
"gelb" -> pure AvsCardColorGelb
|
||||
_ -> 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
|
||||
, avsDataIssueDate :: Maybe Day -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataCardAreas :: Set Char -- logically a set of upper-case letters
|
||||
, avsDataStreet :: Maybe Text -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataPostalCode:: Maybe Text -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataCity :: Maybe Text -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataFirm :: Maybe Text -- always Nothing if returned with AvsResponseStatus
|
||||
, avsDataCardColor :: AvsDataCardColor
|
||||
, avsDataCardNo :: Text -- always 8 digits
|
||||
, avsDataVersionNo :: Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
{- Automatically derived Ord instance should prioritize avsDataValid and avsDataValidTo. Checked in test/Model.TypesSpec
|
||||
instance Ord AvsDataPersonCard where
|
||||
compare a b =
|
||||
compareBy avsDataValid
|
||||
<> compareBy avsDataValidTo
|
||||
<> compareBy avsDataIssueDate
|
||||
<> compareBy avsDataCardAreas
|
||||
...
|
||||
where
|
||||
compareBy f = compare `on` f a b
|
||||
-}
|
||||
|
||||
{- Instead of programming entirely by hand, why not dump splices and adjust? -}
|
||||
instance FromJSON AvsDataPersonCard where
|
||||
parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard
|
||||
<$> ((v .: "Valid") <&> sloppyBool)
|
||||
<*> v .:? "ValidTo"
|
||||
<*> v .:? "IssueDate"
|
||||
<*> ((v .: "CardAreas") <&> charSet)
|
||||
<*> v .:? "Street"
|
||||
<*> v .:? "PostalCode"
|
||||
<*> v .:? "City"
|
||||
<*> v .:? "Firm"
|
||||
<*> v .: "CardColor"
|
||||
<*> v .: "CardNo"
|
||||
<*> v .: "VersionNo"
|
||||
|
||||
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
|
||||
]
|
||||
|
||||
data AvsStatusPerson = AvsStatusPerson
|
||||
{ avsStatusPersonID :: AvsPersonId
|
||||
, avsStatusPersonCardStatus :: Set AvsDataPersonCard
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "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 AvsQueryPerson = AvsQueryPerson
|
||||
{ avsPersonQueryCardNo :: Maybe Text
|
||||
, avsPersonQueryFirstName :: Maybe Text
|
||||
, avsPersonQueryLastName :: Maybe Text
|
||||
, avsPersonQueryInternalPersonalNo :: Maybe Text
|
||||
, avsPersonQueryVersionNo :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Default AvsQueryPerson where
|
||||
def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 3
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsQueryPerson
|
||||
|
||||
newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions ''AvsQueryStatus
|
||||
|
||||
|
||||
-----------------------
|
||||
-- Utility Functions --
|
||||
-----------------------
|
||||
|
||||
-- | retrieve AvsDataPersonCard with longest validity for a given licence,
|
||||
-- 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
|
||||
where
|
||||
validLicenceCards = Set.filter cardMatch cards
|
||||
cardMatch AvsDataPersonCard{..} =
|
||||
avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
|
||||
|
||||
guessLicencseAddress :: Set AvsDataPersonCard -> Maybe Text
|
||||
guessLicencseAddress 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]]
|
||||
| otherwise = Nothing
|
||||
|
||||
hasAddress :: AvsDataPersonCard -> Bool
|
||||
hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
|
||||
|
||||
pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
|
||||
pickLicenceAddress a b
|
||||
| Just r <- pickBetter' hasAddress = r -- prefer card with complete address
|
||||
| Just r <- pickBetter' avsDataValid = r -- prefer valid cards
|
||||
| Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
|
||||
| Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
|
||||
| avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
|
||||
| avsDataIssueDate a < avsDataIssueDate b = b
|
||||
| avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
|
||||
| avsDataValidTo a < avsDataValidTo b = b
|
||||
| Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
|
||||
| a <= b = b -- respect natural Ord instance
|
||||
| otherwise = a
|
||||
where
|
||||
pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
|
||||
pickBetter' = pickBetter a b
|
||||
|
||||
{- Note:
|
||||
|
||||
Since Ordering is a Semigroup that ignores the righthand side except for EQ, this can be conveniently be used like so
|
||||
|
||||
bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
|
||||
compare a b =
|
||||
compareBy avsDataValid
|
||||
<> compareBy avsDataValidTo
|
||||
<> compareBy avsDataIssueDate
|
||||
|
||||
where
|
||||
compareBy f = compare `on` f a b
|
||||
|
||||
-}
|
||||
13
src/Utils.hs
13
src/Utils.hs
@ -883,10 +883,6 @@ whenIsRight (Left _) _ = pure ()
|
||||
throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a
|
||||
throwLeft = either throwM return
|
||||
|
||||
throwLeftWith :: (MonadThrow m, Exception e) => e -> Either b a -> m a
|
||||
-- throwLeftWith e = either (const $ throwM e) return
|
||||
throwLeftWith _ (Right x) = return x
|
||||
throwLeftWith e (Left _) = throwM e
|
||||
|
||||
{- Just a reminder for Steffen:
|
||||
mapLeft :: (a -> c) -> Either a b -> Either c b
|
||||
@ -1588,6 +1584,15 @@ maxOn = maxBy . comparing
|
||||
inBetween:: Ord a => a -> (a,a) -> Bool
|
||||
inBetween x (lower,upper) = lower <= x && x <= upper
|
||||
|
||||
-- | Given to values and a criterion, returns the unique argument that fulfills the criterion, if it exists
|
||||
pickBetter :: a -> a -> (a -> Bool) -> Maybe a
|
||||
pickBetter x y crit
|
||||
| cx == cy = Nothing
|
||||
| cx = Just x
|
||||
| otherwise = Just y
|
||||
where
|
||||
cx = crit x
|
||||
cy = crit y
|
||||
|
||||
------------
|
||||
-- Random --
|
||||
|
||||
194
src/Utils/Avs.hs
194
src/Utils/Avs.hs
@ -3,203 +3,11 @@ module Utils.Avs where
|
||||
import Import.NoModel hiding ((.=))
|
||||
import Utils.Lens hiding ((.=))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.HashMap.Lazy as HM
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
import Servant.Client.Core (requestPath)
|
||||
|
||||
|
||||
|
||||
-- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
|
||||
-- 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
|
||||
o .:~ key = o .: key <|> maybe empty parseJSON go
|
||||
where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o]
|
||||
|
||||
{-
|
||||
-- Like (.:?) but attempts parsing with case-insensitve keys as fallback.
|
||||
(.:?~) :: FromJSON a => Object -> Text -> Parser (Maybe a)
|
||||
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, Generic, Typeable)
|
||||
|
||||
instance ToJSON SloppyBool where
|
||||
toJSON (SloppyBool True) = "true"
|
||||
toJSON _ = "false"
|
||||
|
||||
instance FromJSON SloppyBool where
|
||||
parseJSON (Bool b) = pure $ SloppyBool b
|
||||
parseJSON (String t)
|
||||
| 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
|
||||
|
||||
data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON AvsDataCardColor where
|
||||
toJSON AvsCardColorGrün = "Grün"
|
||||
toJSON AvsCardColorBlau = "Blau"
|
||||
toJSON AvsCardColorRot = "Rot"
|
||||
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
|
||||
"blau" -> pure AvsCardColorBlau
|
||||
"rot" -> pure AvsCardColorRot
|
||||
"gelb" -> pure AvsCardColorGelb
|
||||
_ -> pure $ AvsCardColorMisc t
|
||||
parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid)
|
||||
|
||||
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
|
||||
]
|
||||
|
||||
data AvsStatusPerson = AvsStatusPerson
|
||||
{ avsStatusPersonID :: AvsPersonId
|
||||
, avsStatusPersonCardStatus :: Set AvsDataPersonCard
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "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 AvsQueryPerson = AvsQueryPerson
|
||||
{ avsPersonQueryCardNo :: Maybe Text
|
||||
, avsPersonQueryFirstName :: Maybe Text
|
||||
, avsPersonQueryLastName :: Maybe Text
|
||||
, avsPersonQueryInternalPersonalNo :: Maybe Text
|
||||
, avsPersonQueryVersionNo :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Default AvsQueryPerson where
|
||||
def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 3
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsQueryPerson
|
||||
|
||||
newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions ''AvsQueryStatus
|
||||
|
||||
import Model.Types.Avs
|
||||
|
||||
|
||||
-------------
|
||||
|
||||
@ -2,10 +2,8 @@ module Utils.TypesSpec where
|
||||
|
||||
import TestImport
|
||||
|
||||
import Utils.Avs
|
||||
|
||||
|
||||
instance Arbitrary AvsDataCardColor where
|
||||
instance Arbitrary AvsDataCardColor where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
@ -41,6 +39,8 @@ instance Arbitrary AvsQueryPerson where
|
||||
spec :: Spec
|
||||
spec = do
|
||||
parallel $ do
|
||||
lawsCheckHspec (Proxy @AvsDataPersonCard)
|
||||
[ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
|
||||
lawsCheckHspec (Proxy @AvsResponsePerson)
|
||||
[ eqLaws, showLaws, showReadLaws, jsonLaws]
|
||||
lawsCheckHspec (Proxy @AvsResponseStatus)
|
||||
@ -49,3 +49,23 @@ spec = do
|
||||
[ eqLaws, showLaws, showReadLaws, jsonLaws]
|
||||
lawsCheckHspec (Proxy @AvsQueryStatus)
|
||||
[ eqLaws, showLaws, showReadLaws, jsonLaws]
|
||||
|
||||
describe "Ord AvsDataCard" $ do
|
||||
it "prioritises avsDataValid" . property $
|
||||
\p0 p1@AvsDataPersonCard{avsDataValid=v1} ->
|
||||
let p2@AvsDataPersonCard{avsDataValid=v2} = p0 in
|
||||
(v1 /= v2) ==> compare p1 p2 == compare v1 v2
|
||||
it "prioritises avsDataValidTo after avsDataValid" . property $
|
||||
\p0 p1@AvsDataPersonCard{avsDataValid=v1, avsDataValidTo=t1} ->
|
||||
let p2@AvsDataPersonCard{avsDataValidTo=t2} = p0{avsDataValid=v1} in
|
||||
(t1 /= t2) ==> compare p1 p2 == compare t1 t2
|
||||
it "prioritises avsDataIssueDate after avsDataValid and avsDataValidTo" . property $
|
||||
\p0 p1@AvsDataPersonCard{avsDataValid=v1, avsDataValidTo=t1, avsDataIssueDate=d1} ->
|
||||
let p2@AvsDataPersonCard{avsDataIssueDate=d2} = p0{avsDataValid=v1, avsDataValidTo=t1} in
|
||||
(d1 /= d2) ==> compare p1 p2 == compare d1 d2
|
||||
{- naive implementations discards too many tests in order to produce a meaningful result:
|
||||
it "prioritises avsDataIssueDate after avsDataValid and avsDataValidTo" . property $
|
||||
\p1@AvsDataPersonCard{avsDataValid=v1, avsDataValidTo=t1, avsDataIssueDate=d1}
|
||||
p2@AvsDataPersonCard{avsDataValid=v2, avsDataValidTo=t2, avsDataIssueDate=d2} ->
|
||||
(v1 == v2 && t1 == t2 && d1 /= d2) ==> compare p1 p2 == compare d1 d2
|
||||
-}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user