diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 50e2a9d78..bf5851355 100644 --- a/src/Model/Types/Avs.hs +++ b/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 - 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 --} \ No newline at end of file +-} \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs index c3043de6e..e375de8d0 100644 --- a/src/Utils.hs +++ 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 diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index d4ff57d52..c52d5634c 100644 --- a/test/Utils/TypesSpec.hs +++ b/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 $