feat(avs): add extraction functions for avs datatypes and tests

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

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

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

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
+
+-} 

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 --

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)
 
-
+import Model.Types.Avs
-
--- | 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
-
 
 
 -------------

test/Utils/TypesSpec.hs

@@ -2,8 +2,6 @@ module Utils.TypesSpec where
 
 import TestImport
 
-import Utils.Avs
-
 
 instance Arbitrary AvsDataCardColor where
   arbitrary = genericArbitrary
@@ -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
+    -}