chore(avs): more resilient JSON en/decoding

src/Model/Types/Avs.hs

@@ -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,13 +31,18 @@ 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)
@@ -160,7 +166,6 @@ instance Ord AvsDataPersonCard 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,30 +173,33 @@ 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
@@ -224,19 +232,40 @@ 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

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 $