diff --git a/models/users.model b/models/users.model index 38fb7334d..9eff01c9f 100644 --- a/models/users.model +++ b/models/users.model @@ -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 diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index bdbc06155..f0b6f567d 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 3dfb4bb7d..b488193db 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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 diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs new file mode 100644 index 000000000..569403d5b --- /dev/null +++ b/src/Model/Types/Avs.hs @@ -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 + +-} \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs index 259cfea21..7c565484b 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 0c5f93544..0b52818ea 100644 --- a/src/Utils/Avs.hs +++ b/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 ------------- diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index 12432f194..420169580 100644 --- a/test/Utils/TypesSpec.hs +++ b/test/Utils/TypesSpec.hs @@ -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 + -}