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/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index e384524d8..b32f1aeb8 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -135,7 +135,7 @@ postTUsersR tid ssh csh tutn = do let fName = letterFileName aletter renderLetters rcvr letters apcIdent >>= \case Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err - Right pdf -> Just <$> sendByteStringAsFile fName (LBS.toStrict pdf) now + Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now) -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf) -- let typePDF :: ContentType -- typePDF = "application/pdf" @@ -165,7 +165,7 @@ postTUsersR tid ssh csh tutn = do _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing case tcontent of - Just content -> return content -- abort and return produced content + Just act -> act -- abort and return produced content Nothing -> do tutors <- runDB $ E.select $ do (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index f772b0a4e..b3e3dfd8f 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -531,9 +531,13 @@ lookupAvsUsers apis = do -- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool) updateReceivers uid = do - (underling :: Entity User, avsUnderling :: Maybe (Entity UserAvs), avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,,) - <$> getJustEntity uid - <*> getBy (UniqueUserAvsUser uid) + -- First perform AVS update for receiver + runDB (getBy (UniqueUserAvsUser uid)) >>= \case + Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ upsertAvsUserById apid + Nothing -> return () + -- Retrieve updated user and supervisors now + (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,) + <$> getJustEntity uid <*> (E.select $ do (usrSuper :& usrAvs) <- E.from $ E.table @UserSupervisor @@ -544,10 +548,9 @@ updateReceivers uid = do pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId) ) let (superVs, avsIds) = unzip avsSupers - receiverIDs :: [UserId] = E.unValue <$> superVs - underlingAvsId = userAvsPersonId . entityVal <$> avsUnderling - toUpdate = Set.fromList $ catMaybes (underlingAvsId : (E.unValue <$> avsIds)) - directResult = return (underling, pure underling, True) + receiverIDs :: [UserId] = E.unValue <$> superVs + toUpdate = Set.fromList $ mapMaybe E.unValue avsIds + directResult = return (underling, pure underling, True) -- already contains updated address forM_ toUpdate (void . maybeCatchAll . upsertAvsUserById) -- attempt to update postaddress from AVS if null receiverIDs then directResult diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index d473bd54d..4f8e87546 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -83,7 +83,7 @@ validEmail :: Email -> Bool -- Email = Text validEmail email = validRFC5322 && not invalidFraport where validRFC5322 = Email.isValid $ encodeUtf8 email - invalidFraport = case Text.stripSuffix "@fraport.de" email of + invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of Just fralogin -> all isDigit $ drop 1 fralogin Nothing -> False 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 ----------------------- diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8ced73ec8..b5f4549ba 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -164,7 +164,7 @@ fillDb = do , userLastAuthentication = Nothing , userTokensIssuedAfter = Nothing , userMatrikelnummer = Just "94094094094" - , userEmail = "e12345@fraport.de" + , userEmail = "S.Jost@Fraport.de" , userDisplayEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" , userSurname = "Jost"