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

refactor(avs): avs queries are automatically chunked

Browse Source
This commit is contained in:
Steffen Jost 2023-04-24 16:42:57 +00:00
parent ea82d75a09
commit ebb81e0c54
2 changed files with 36 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -197,6 +197,7 @@ discernAvsCardPersonalNo _ = Nothing
newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int
deriving (Eq, Ord, Generic) deriving (Eq, Ord, Generic)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary) deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary)
-- TODO: consider using "makeWrapped ''AvsPersonId"
instance E.SqlString AvsPersonId instance E.SqlString AvsPersonId
-- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API; -- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API;
instance FromJSON AvsPersonId where instance FromJSON AvsPersonId where
@ -590,6 +591,7 @@ deriveJSON defaultOptions
type AvsResponseStatus :: Type type AvsResponseStatus :: Type
newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson)
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
makeWrapped ''AvsResponseStatus
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2 { fieldLabelModifier = dropCamel 2
, omitNothingFields = True , omitNothingFields = True
@ -601,6 +603,7 @@ instance Semigroup AvsResponseStatus where
newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson)
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
-- makeWrapped ''AvsResponsePerson
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2 { fieldLabelModifier = dropCamel 2
, omitNothingFields = True , omitNothingFields = True
@ -610,6 +613,7 @@ deriveJSON defaultOptions
newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact) newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact)
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
makeWrapped ''AvsResponseContact
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2 { fieldLabelModifier = dropCamel 2
, omitNothingFields = True , omitNothingFields = True
@ -666,10 +670,12 @@ deriveJSON defaultOptions
newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryStatus deriveJSON defaultOptions ''AvsQueryStatus
makeWrapped ''AvsQueryStatus
newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryContact deriveJSON defaultOptions ''AvsQueryContact
makeWrapped ''AvsQueryContact
newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)

68
src/Utils/Avs.hs
View File

@ -13,10 +13,10 @@ import qualified Data.Text as Text
import Servant import Servant
import Servant.Client import Servant.Client
#ifdef DEVELOPMENT -- #ifdef DEVELOPMENT
#else -- #else
import Servant.Client.Core (requestPath) import Servant.Client.Core (requestPath)
#endif -- #endif
import Model.Types.Avs import Model.Types.Avs
@ -34,8 +34,8 @@ type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQueryS
avsMaxSetLicenceAtOnce :: Int avsMaxSetLicenceAtOnce :: Int
avsMaxSetLicenceAtOnce = 90 -- maximum input set size for avsQuerySetLicences as enforced by AVS avsMaxSetLicenceAtOnce = 90 -- maximum input set size for avsQuerySetLicences as enforced by AVS
avsMaxGetStatusAtOnce :: Int avsMaxQueryAtOnce :: Int
avsMaxGetStatusAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS avsMaxQueryAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS
avsApi :: Proxy AVS avsApi :: Proxy AVS
@ -68,20 +68,20 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
#ifdef DEVELOPMENT -- #ifdef DEVELOPMENT
mkAvsQuery _ _ _ = AvsQuery -- mkAvsQuery _ _ _ = AvsQuery
{ avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty -- { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty
, avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty -- , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty
, avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) -- , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing)
, avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty -- , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty
, avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty -- , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty
} -- }
#else -- #else
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (splitQueryStatus q) cliEnv , avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv
, avsQueryContact = \q -> liftIO $ runClientM (rawQueryContact q) cliEnv , avsQueryContact = \q -> liftIO $ runClientM (splitQuery rawQueryContact q) cliEnv
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- TODO: currently uses setLicencesAvs for splitting to ensure return of correctly set licences
-- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv -- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv , avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
} }
@ -96,26 +96,18 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
| baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
catch404toEmpty other = other catch404toEmpty other = other
-- TODO: make a generic implementation for this splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c))
splitQueryStatus :: AvsQueryStatus -> ClientM AvsResponseStatus => (a -> ClientM c) -> a -> ClientM c
splitQueryStatus q@(AvsQueryStatus avids) splitQuery rawQuery q
| Set.size avids <= avsMaxGetStatusAtOnce = rawQueryStatus q | Set.size s <= avsMaxQueryAtOnce = rawQuery q
| otherwise = do | otherwise = do
let (avid_1,avid_2) = Set.splitAt avsMaxGetStatusAtOnce avids let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s
res1 <- rawQueryStatus (AvsQueryStatus avid_1) res1 <- rawQuery $ view _Unwrapped' avsid1
res2 <- splitQueryStatus (AvsQueryStatus avid_2) res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2
return $ res1 <> res2 return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped')
where
-- splitQuery :: (a -> Set b) -> (Set b -> a) -> (a -> ClientM c) -> a -> ClientM c s = view _Wrapped' q
-- splitQuery toSet fromSet rawQuery q -- #endif
-- | Set.size (toSet q) <= avsMaxGetStatusAtOnce = rawQueryStatus q
-- | otherwise = do
-- let (fromSet -> avid_1,fromSet -> avid_2) = Set.splitAt avsMaxGetStatusAtOnce (toSet q)
-- res1 <- rawQuery avid_1
-- res2 <- splitQuery toSet fromSet rawQuery avid_2
-- return $ fromSet (toSet res1 <> toSet res2)
#endif
----------------------- -----------------------
-- Utility Functions -- -- Utility Functions --