fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(avs): more resilient JSON en/decoding

Browse Source
This commit is contained in:
Steffen Jost 2022-09-26 11:39:07 +02:00
parent a5173bdf22
commit b4a25df963
3 changed files with 106 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

137
src/Model/Types/Avs.hs
View File

@ -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
toJSON (AvsPersonId pid) = toJSON pid
instance ToJSON AvsPersonId where
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
compare a b =
compareBy avsDataValid
instance Ord AvsDataPersonCard where
compare a b =
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 .:? "PostalCode"
<*> v .:? "City"
<*> v .:? "Firm"
<*> v .:?! "Street"
<*> v .:?! "PostalCode"
<*> v .:?! "City"
<*> v .:?! "Firm"
<*> v .: "CardNo"
<*> v .: "VersionNo"
instance ToJSON AvsDataPersonCard where
toJSON AvsDataPersonCard{..} = object
[ "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas
toJSON AvsDataPersonCard{..} = object $
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
where
getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
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
| Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
| a <= b = b -- respect natural Ord instance
| otherwise = a
where
| 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
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
-}
-}

5
src/Utils.hs
View File

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

18
test/Utils/TypesSpec.hs
View File

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