chore(avs): more resilient JSON en/decoding

src/Model/Types/Avs.hs

@@ -8,7 +8,7 @@ module Model.Types.Avs
   ) where
 
 import Import.NoModel hiding ((.=))
-import Database.Persist.Sql 
+import Database.Persist.Sql
 import qualified Database.Esqueleto.Experimental as E
 import qualified Data.Csv as Csv
 import Utils.Lens.TH
@@ -17,12 +17,13 @@ import Text.Read (Read(..))
 
 import qualified Data.Set           as Set
 import qualified Data.Text          as Text
-import qualified Data.HashMap.Lazy  as HM
+-- 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.
@@ -30,19 +31,24 @@ import Data.Aeson.Types
 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.
--- 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]
 -}
 
+
+-- Like (.:?) but maps Just null to Nothing, ie. Nothing instead of Just ""
+(.:?!) :: (MonoFoldable a, FromJSON a) => Object -> Text -> Parser (Maybe a)
+(.:?!) o k = null2nothing <$> (o .:? k)
+
+
 -- | `SloppyBool` successfully parses different variations of true/false
 newtype SloppyBool = SloppyBool { sloppyBool :: Bool }
   deriving (Bounded, Enum, Eq, Ord, Generic, Typeable)
 
 -- Cannot tell difference between SloppyBool and Bool through Show and Read. A good or a bad idea?
-instance Show SloppyBool where 
+instance Show SloppyBool where
   show = show . sloppyBool
 
 instance Read SloppyBool where
@@ -72,20 +78,20 @@ newtype AvsPersonId = AvsPersonId { avsPersonId :: Int }
   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
 instance E.SqlString AvsPersonId
 -- AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API
-instance FromJSON AvsPersonId where 
+instance FromJSON AvsPersonId where
   parseJSON x = AvsPersonId <$> parseJSON x
-instance ToJSON AvsPersonId where 
+instance ToJSON AvsPersonId where
-  toJSON (AvsPersonId pid) = toJSON pid 
+  toJSON (AvsPersonId pid) = toJSON pid
 
 
 newtype AvsCardNo = AvsCardNo { avsCardNo :: Text }  -- always 8 digits
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
-instance E.SqlString AvsCardNo 
+instance E.SqlString AvsCardNo
 -- AvsCardNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API
-instance FromJSON AvsCardNo where 
+instance FromJSON AvsCardNo where
   parseJSON x = AvsCardNo <$> parseJSON x
-instance ToJSON AvsCardNo where 
+instance ToJSON AvsCardNo where
   toJSON (AvsCardNo cno) = toJSON cno
 
 
@@ -141,7 +147,7 @@ data AvsDataPersonCard = AvsDataPersonCard
       , 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       
+      , avsDataFirm      :: Maybe Text  -- always Nothing if returned with AvsResponseStatus
       , avsDataCardNo    :: AvsCardNo   -- always 8 digits
       , avsDataVersionNo :: Text
       }
@@ -149,18 +155,17 @@ data AvsDataPersonCard = AvsDataPersonCard
   deriving anyclass (NFData)
 
 {- Automatically derived Ord instance should prioritize avsDataValid and avsDataValidTo. Checked in test/Model.TypesSpec
-instance Ord AvsDataPersonCard where 
+instance Ord AvsDataPersonCard where
-  compare a b = 
+  compare a b =
-          compareBy avsDataValid  
+          compareBy avsDataValid
       <>  compareBy avsDataValidTo
       <>  compareBy avsDataIssueDate
       <>  compareBy avsDataCardAreas
       ...
-    where 
+    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)
@@ -168,34 +173,37 @@ instance FromJSON AvsDataPersonCard where
     <*> v .:? "IssueDate"
     <*> v .: "CardColor"
     <*> ((v .: "CardAreas") <&> charSet)
-    <*> v .:? "Street"
+    <*> v .:?! "Street"
-    <*> v .:? "PostalCode"
+    <*> v .:?! "PostalCode"
-    <*> v .:? "City"
+    <*> v .:?! "City"
-    <*> v .:? "Firm"    
+    <*> v .:?! "Firm"
     <*> v .: "CardNo"
     <*> v .: "VersionNo"
 
 instance ToJSON AvsDataPersonCard where
-  toJSON AvsDataPersonCard{..} = object
+  toJSON AvsDataPersonCard{..} = object $
-    [ "CardAreas"   .= Set.foldl Text.snoc Text.empty avsDataCardAreas
+    catMaybes 
+    [ ("ValidTo"     .=) <$> avsDataValidTo
+    , ("IssueDate"   .=) <$> avsDataIssueDate
+    , ("Street"      .=) <$> (avsDataStreet     & null2nothing)
+    , ("PostalCode"  .=) <$> (avsDataPostalCode & null2nothing)
+    , ("City"        .=) <$> (avsDataCity       & null2nothing)
+    , ("Firm"        .=) <$> (avsDataFirm       & null2nothing)
+    ] 
+    <>
+    [ "Valid"       .= show avsDataValid
     , "CardColor"   .= avsDataCardColor
+    , "CardAreas"   .= Set.foldl Text.snoc Text.empty avsDataCardAreas
     , "CardNo"      .= avsDataCardNo
     , "VersionNo"   .= avsDataVersionNo
-    , "Valid"       .= show avsDataValid
-    , "ValidTo"     .= avsDataValidTo
-    , "IssueDate"   .= avsDataIssueDate
-    , "Firm"        .= avsDataFirm
-    , "City"        .= avsDataCity
-    , "Street"      .= avsDataStreet
-    , "PostalCode"  .= avsDataPostalCode
     ]
 
 derivePersistFieldJSON ''AvsDataPersonCard
-makeLenses_ ''AvsDataPersonCard -- not possible here due to module import cycle
+makeLenses_ ''AvsDataPersonCard
 
 -- The AVS API sometimes requests PersonIds as numbers and sometimes as objects.
 newtype AvsObjPersonId = AvsObjPersonId
-      { avsObjPersonID :: AvsPersonId      
+      { avsObjPersonID :: AvsPersonId
       }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
@@ -224,24 +232,45 @@ data AvsDataPerson = AvsDataPerson
       { avsPersonFirstName          :: Text
       , avsPersonLastName           :: Text
       , avsPersonInternalPersonalNo :: Maybe Text   -- Fraport Personalnummer
-      , avsPersonPersonNo           :: AvsPersonId  -- AVS Personennummer
+      , avsPersonPersonNo           :: Int          -- AVS Personennummer, Bedeutung ist unklar
       , avsPersonPersonID           :: AvsPersonId  -- Eindeutige PersonenID, wichtig für die Schnittstelle!
       , avsPersonPersonCards        :: Set AvsDataPersonCard
       }
     deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
+instance FromJSON AvsDataPerson where
+  parseJSON = withObject "AvsDataPerson" $ \v -> AvsDataPerson
+    <$> v .:    "FirstName"
+    <*> v .:    "LastName"
+    <*> v .:?!  "InternalPersonalNo"
+    <*> v .:    "PersonNo"
+    <*> v .:    "PersonID"
+    <*> v .:    "personCards"                        -- starts with lower case letter!
+
+instance ToJSON AvsDataPerson where
+  toJSON AvsDataPerson{..} = object $    
+    catMaybes [ ("InternalPersonalNo"  .=) <$> (avsPersonInternalPersonalNo & null2nothing) ]
+    <>
+    [ "FirstName"           .= avsPersonFirstName
+    , "LastName"            .= avsPersonLastName
+    , "PersonNo"            .= avsPersonPersonNo
+    , "PersonID"            .= avsPersonPersonID
+    , "personCards"         .= avsPersonPersonCards   -- starts with lower case letter!
+    ]
+
+{- Dervied instance decodes empty Texts to Just "", which is annoying
 deriveJSON defaultOptions
   { fieldLabelModifier = \case { "avsPersonPersonCards" -> "personCards"; others -> dropCamel 2 others }
   , omitNothingFields = True
   , tagSingleConstructors = False
   , rejectUnknownFields = False
   } ''AvsDataPerson
-
+-}
 
 data AvsPersonLicence = AvsPersonLicence
       { avsLicencePersonID     :: AvsPersonId
       , avsLicenceRampLicence  :: AvsLicence    -- Schnittstelle unklar: RampDrivingLicence oder RampLicence
-      --, avsLicenceRampDrivingLicence  :: AvsLicence   
+      --, avsLicenceRampDrivingLicence  :: AvsLicence
       }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 deriveJSON defaultOptions
@@ -252,9 +281,9 @@ deriveJSON defaultOptions
   } ''AvsPersonLicence
 
 data AvsLicenceResponse = AvsLicenceResponse
-      { avsResponsePersonID :: AvsPersonId  
+      { avsResponsePersonID :: AvsPersonId
       , avsResponseSuccess  :: SloppyBool
-      , avsResponseMessage  :: Text    
+      , avsResponseMessage  :: Text
       }
     deriving (Eq, Ord, Read, Show, Generic, Typeable)
 deriveJSON defaultOptions
@@ -349,15 +378,15 @@ deriveJSON defaultOptions ''AvsQuerySetLicences
 --   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     
+getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
-  where 
+  where
     licence = licence2char licence'
-    validLicenceCards = Set.filter cardMatch cards 
+    validLicenceCards = Set.filter cardMatch cards
     cardMatch AvsDataPersonCard{..} =
       avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
 
 guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text)
-guessLicenceAddress cards  
+guessLicenceAddress cards
   | Just c <- Set.lookupMax cards
   , AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
   , Just street <- avsDataStreet
@@ -370,33 +399,33 @@ hasAddress :: AvsDataPersonCard -> Bool
 hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
 
 pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
-pickLicenceAddress a b 
+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
     | avsDataCardColor a > avsDataCardColor b                               = a   -- prefer Yellow over Green, etc.
-    | avsDataCardColor a < avsDataCardColor b                               = b   
+    | avsDataCardColor a < avsDataCardColor b                               = b
     | avsDataIssueDate a > avsDataIssueDate b                               = a   -- prefer later issue date
-    | avsDataIssueDate a < avsDataIssueDate b                               = b                  
+    | avsDataIssueDate a < avsDataIssueDate b                               = b
     | avsDataValidTo   a > avsDataValidTo   b                               = a   -- prefer later validto date
-    | avsDataValidTo   a < avsDataValidTo   b                               = b    
+    | avsDataValidTo   a < avsDataValidTo   b                               = b
-    | Just r <- pickBetter' (isJust . avsDataFirm)                          = r   -- prefer having a firm 
+    | Just r <- pickBetter' (isJust . avsDataFirm)                          = r   -- prefer having a firm
-    | a <= b    = b -- respect natural Ord instance 
+    | a <= b    = b -- respect natural Ord instance
-    | otherwise = a 
+    | otherwise = a
-  where 
+  where
     pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
-    pickBetter' = pickBetter a b 
+    pickBetter' = pickBetter a b
     licenceRollfeld = licence2char AvsLicenceRollfeld
     licenceVorfeld  = licence2char AvsLicenceVorfeld
- 
+
 {- Note:
 For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this can be conveniently be used like so
 bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
-  compare a b =  compareBy avsDataValid  
+  compare a b =  compareBy avsDataValid
               <> compareBy avsDataValidTo
               <> compareBy avsDataIssueDate
               ...
-    where 
+    where
       compareBy f = compare `on` f a b
--} 
+-}

src/Utils.hs

@@ -765,6 +765,11 @@ toNothing = const Nothing
 toNothingS :: String -> Maybe b
 toNothingS = const Nothing
 
+-- a more general formulation probably possible
+null2nothing :: MonoFoldable a => Maybe a -> Maybe a
+null2nothing (Just x) | null x = Nothing
+null2nothing other = other
+
 -- | Swap 'Nothing' for 'Just' and vice versa
 -- This belongs into Module 'Utils' but we have a weird cyclic
 -- dependency

test/Utils/TypesSpec.hs

@@ -47,16 +47,34 @@ instance Arbitrary AvsQueryPerson where
 spec :: Spec
 spec = do
   parallel $ do
+    lawsCheckHspec (Proxy @AvsPersonId)
+      [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @AvsCardNo)
+      [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
     lawsCheckHspec (Proxy @AvsDataPersonCard)
       [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @AvsDataPerson)
+      [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @AvsPersonLicence)
+      [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @AvsLicenceResponse)
+      [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
     lawsCheckHspec (Proxy @AvsResponsePerson)
       [ eqLaws, showLaws, showReadLaws, jsonLaws]
     lawsCheckHspec (Proxy @AvsResponseStatus)
       [ eqLaws, showLaws, showReadLaws, jsonLaws]
+    lawsCheckHspec (Proxy @AvsResponseGetLicences)
+      [ eqLaws, showLaws, showReadLaws, jsonLaws]
+    lawsCheckHspec (Proxy @AvsResponseSetLicences)
+      [ eqLaws, showLaws, showReadLaws, jsonLaws]
     lawsCheckHspec (Proxy @AvsQueryPerson)
       [ eqLaws, showLaws, showReadLaws, jsonLaws]
     lawsCheckHspec (Proxy @AvsQueryStatus)
       [ eqLaws, showLaws, showReadLaws, jsonLaws]
+    lawsCheckHspec (Proxy @AvsQueryGetLicences)
+      [ eqLaws, showLaws, showReadLaws, jsonLaws]
+    lawsCheckHspec (Proxy @AvsQuerySetLicences)
+      [ eqLaws, showLaws, showReadLaws, jsonLaws]
 
   describe "Ord AvsDataCard" $ do
     it "prioritises avsDataValid" . property $