chore(avs): ToJSON and FromJSON instances to deal with avs interface quirks in response

src/Utils/Avs.hs

@@ -1,14 +1,58 @@
-{-# OPTIONS_GHC -ddump-splices #-}
-{-# LANGUAGE TemplateHaskell #-}
 
 module Utils.Avs where
 
-import Import.NoModel
+import Import.NoModel hiding ((.=))
+import Utils.Lens     hiding ((.=))
+
+-- import qualified Data.HashMap.Lazy    as HM
+import qualified Data.Text            as Text
+import Data.Aeson
+import Data.Aeson.Types
 
 import Servant
 import Servant.Client.Core (ClientError)
 
-import Utils.Lens
+
+
+-- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
+--   Taken from Data.Aeson.Filthy, which could somehow not be added as a dependency.
+{-
+(.:~) :: FromJSON a => Object -> Text -> Parser a -- would be useful for AvsDataPerson, where Case is inconsistent
+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, Ix, Generic)
+
+instance ToJSON SloppyBool where
+    toJSON (SloppyBool True) = "true"
+    toJSON _                 = "false"
+
+instance FromJSON SloppyBool where
+    parseJSON (Bool b)          = pure $ SloppyBool b
+    parseJSON (String t)
+     | Text.toLower t == "true" = pure $ SloppyBool True    
+    parseJSON _                 = pure $ SloppyBool False
+
+data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text
+  deriving (Eq, Ord, Read, Show, Generic)
+
+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)
 
 type AvsPersonResponse = Value 
 type AvsStatusResponse = Value 
@@ -44,25 +88,38 @@ data AvsDataPerson = AvsDataPerson
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 data AvsDataPersonCard = AvsDataPersonCard 
       { avsDataCardAreas :: Maybe String
-      , avsDataCardColor :: String
+      , avsDataCardColor :: AvsDataCardColor
       , avsDataCardNo    :: String
-      , avsDataValid     :: String -- Bool; unfortunately, AVS encodes Booleans as JSON String "true" and "false" and not as JSON Booleans
+      , avsDataValid     :: Bool    -- unfortunately, AVS encodes Booleans as JSON String "true" and "false" and not as JSON Booleans
       , avsDataVersionNo :: String
       }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
--- data AvsDataCardColor = AvsCardColorRot | AvsCardColorGrün | AvsCardColorGelb | AvsCardColorBlau
-deriveJSON defaultOptions
-  { fieldLabelModifier    = dropCamel 2
-  , omitNothingFields     = True
-  , tagSingleConstructors = False
-  , rejectUnknownFields   = False 
-  } ''AvsDataPersonCard
+
+{- Instead of programming entirely by hand, why not dump splices and adjust? -}
+instance FromJSON AvsDataPersonCard where 
+  parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard
+    <$> v .:? "CardAreas"
+    <*> v .: "CardColor"
+    <*> v .: "CardNo"
+    <*> (sloppyBool <$> (v .: "Valid"))
+    <*> v .: "VersionNo"     
+
+instance ToJSON AvsDataPersonCard where
+  toJSON AvsDataPersonCard{..} = object 
+    [ "CardAreas" .= avsDataCardAreas
+    , "CardColor" .= avsDataCardColor
+    , "CardNo"    .= avsDataCardNo
+    , "Valid"     .= show avsDataValid
+    , "VersionNo" .= avsDataVersionNo
+    ]
+
 deriveJSON defaultOptions
   { fieldLabelModifier = \case { "avsDataPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others }
   , omitNothingFields = True
   , tagSingleConstructors = False
   , rejectUnknownFields = False 
   } ''AvsDataPerson
+
 deriveJSON defaultOptions
   { fieldLabelModifier = dropCamel 2
   , omitNothingFields = True
@@ -70,13 +127,6 @@ deriveJSON defaultOptions
   , rejectUnknownFields = False 
   } ''AvsResponseStatus
 
-{- Instead of programming entirely by hand, why not dump splices and adjust?
-instance FromJSON AvsDataPersonCard where 
-  parseJSON (Object v) = AvsDataPersonCard
-    <$> v .:? "CardAreas"
-    <*> ...
-    <*> v .: "VersionNo"     
--}
 
 data AvsQuery = AvsQuery
   { avsQueryPerson :: forall m. MonadIO m => AvsPersonQuery -> m (Either ClientError AvsPersonResponse)