diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 337f99d48..7d101e786 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -95,7 +95,7 @@ makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateA parseAvsIds txt = AvsQueryStatus $ Set.fromList ids where nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt - ids = catMaybes $ readMay <$> nonemptys + ids = mapMaybe readMay nonemptys unparseAvsIds :: AvsQueryStatus -> Text unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids @@ -113,7 +113,7 @@ makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validat parseAvsIds txt = AvsQueryContact $ Set.fromList ids where nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt - ids = catMaybes $ fmap AvsObjPersonId . readMay <$> nonemptys + ids = mapMaybe (fmap AvsObjPersonId . readMay) nonemptys unparseAvsIds :: AvsQueryContact -> Text unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 56666c293..bd9aaa0e9 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -587,6 +587,7 @@ deriveJSON defaultOptions -- Responses -- --------------- +type AvsResponseStatus :: Type newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions @@ -595,6 +596,8 @@ deriveJSON defaultOptions , tagSingleConstructors = False , rejectUnknownFields = False } ''AvsResponseStatus +instance Semigroup AvsResponseStatus where + (AvsResponseStatus a) <> (AvsResponseStatus b) = AvsResponseStatus (a <> b) newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) deriving (Eq, Ord, Show, Generic) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index b366bac50..1a978eb45 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -34,6 +34,10 @@ type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQueryS avsMaxSetLicenceAtOnce :: Int avsMaxSetLicenceAtOnce = 99 -- maximum input set size for avsQuerySetLicences as enforced by AVS +avsMaxGetStatusAtOnce :: Int +avsMaxGetStatusAtOnce = 990 -- maximum input set size for avsQueryStatus as enforced by AVS + + avsApi :: Proxy AVS avsApi = Proxy @@ -75,7 +79,7 @@ mkAvsQuery _ _ _ = AvsQuery #else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv - , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv + , avsQueryStatus = \q -> liftIO $ runClientM (splitQueryStatus q) cliEnv , avsQueryContact = \q -> liftIO $ runClientM (rawQueryContact q) cliEnv , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv @@ -91,6 +95,16 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404))) | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! catch404toEmpty other = other + + -- TODO: make a generic implementation for this + splitQueryStatus :: AvsQueryStatus -> ClientM AvsResponseStatus + splitQueryStatus q@(AvsQueryStatus avids) + | Set.size avids <= avsMaxGetStatusAtOnce = rawQueryStatus q + | otherwise = do + let (avid_1,avid_2) = Set.splitAt avsMaxGetStatusAtOnce avids + res1 <- rawQueryStatus (AvsQueryStatus avid_1) + res2 <- splitQueryStatus (AvsQueryStatus avid_2) + return $ res1 <> res2 #endif -----------------------