From 6699f1d72f148ccd2c82bebb3f582cf61d711425 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Apr 2023 16:35:06 +0000 Subject: [PATCH 1/5] fix(profile): bad email indicator --- templates/profileData.hamlet | 2 +- test/Database/Fill.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 87dae8ebb..0c9783fd4 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -65,7 +65,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
#{userEmail} $if not (validEmail' userEmail) - \ ^{messageTooltip tooltipInvalidEmail} + \ ^{messageTooltip tooltipInvalidEmail}
_{MsgAdminUserPinPassword}
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" From 13f53e32215d30349904201f0b37bd74ea410193 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Apr 2023 16:35:45 +0000 Subject: [PATCH 2/5] chore(tutorial): attempt to fix download --- src/Handler/Tutorial/Users.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 From 3f759614b4ddc455b515d753e260d11834139ccb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 20 Apr 2023 10:10:06 +0000 Subject: [PATCH 3/5] chore(email): fix case sensitivity for fraport-e-account email checks --- src/Handler/Utils/Profile.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 7d5c4bff2512154c087133e029713efa0657fa5a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 20 Apr 2023 16:03:50 +0000 Subject: [PATCH 4/5] fix(letter): update receiver postal address before sending --- src/Handler/Utils/Avs.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) 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 From 352ee215b4075c70dbf9229434e62c8e6d847ae4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 20 Apr 2023 17:11:43 +0000 Subject: [PATCH 5/5] fix(avs): chunk avs status query automatically --- src/Handler/Admin/Avs.hs | 4 ++-- src/Model/Types/Avs.hs | 3 +++ src/Utils/Avs.hs | 16 +++++++++++++++- 3 files changed, 20 insertions(+), 3 deletions(-) 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 -----------------------