From 6699f1d72f148ccd2c82bebb3f582cf61d711425 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Apr 2023 16:35:06 +0000 Subject: [PATCH 1/7] 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/7] 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/7] 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/7] 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/7] 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 ----------------------- From 5720ba58c848f141e2d3a15f7cf35ca179491a03 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 21 Apr 2023 16:17:50 +0200 Subject: [PATCH 6/7] chore(login): more informative login error message The login messages are more Fraport specific. --- .../categories/authorization/de-de-formal.msg | 14 +++++++------- .../uniworx/categories/authorization/en-eu.msg | 14 +++++++------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index 1c4416244..e16240aa5 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -111,15 +111,15 @@ CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko- CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Institute ermitteln InvalidCredentialsADNoSuchObject: Benutzereintrag existiert nicht InvalidCredentialsADLogonFailure: Ungültiges Passwort -InvalidCredentialsADAccountRestriction: Kontobeschränkungen verhindern Login +InvalidCredentialsADAccountRestriction: Beschränkungen des Fraport Accounts verhindern Login InvalidCredentialsADInvalidLogonHours: Benutzer:in darf sich zur aktuellen Tageszeit nicht anmelden InvalidCredentialsADInvalidWorkstation: Benutzer:in darf sich von diesem System aus nicht anmelden -InvalidCredentialsADPasswordExpired: Passwort abgelaufen -InvalidCredentialsADAccountDisabled: Benutzereintrag gesperrt +InvalidCredentialsADPasswordExpired: Passwort abgelaufen; ändern Sie Ihr Fraport Passwort auf dem üblichen Weg (z.B. E-Account Nutzer per Azure-Portal) +InvalidCredentialsADAccountDisabled: Ihr Fraport Account wurde gesperrt, bitte wenden Sie sich an den allgemeinen IT Support InvalidCredentialsADTooManyContextIds: Benutzereintrag trägt zu viele Sicherheitskennzeichen -InvalidCredentialsADAccountExpired: Benutzereintrag abgelaufen -InvalidCredentialsADPasswordMustChange: Passwort muss geändert werden -InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt +InvalidCredentialsADAccountExpired: Benutzereintrag abgelaufen, bitte wenden Sie sich an den allgemeinen IT Support +InvalidCredentialsADPasswordMustChange: Passwort muss geändert werden; ändern Sie Ihr Fraport Passwort auf dem üblichen Weg (z.B. E-Account Nutzer per Azure-Portal) +InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt, bitte wenden Sie sich an den allgemeinen IT Support LoginTitle: Authentifizierung @@ -136,4 +136,4 @@ FormHoneypotNameTip: Ihr Name oder Ihre E-Mail Adresse FormHoneypotNamePlaceholder: Name FormHoneypotComment: Kommentar FormHoneypotCommentPlaceholder: Kommentar -FormHoneypotFilled: Bitte füllen Sie keines der verstecken Felder aus \ No newline at end of file +FormHoneypotFilled: Bitte füllen Sie keines der verstecken Felder aus diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index b1676fc75..d2ad99d62 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -111,16 +111,16 @@ CampusUserInvalidTitle: Could not determine title during Fraport Büko login CampusUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login CampusUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login InvalidCredentialsADNoSuchObject: User entry does not exist -InvalidCredentialsADLogonFailure: Invalid passwod -InvalidCredentialsADAccountRestriction: Account restrictions are preventing login +InvalidCredentialsADLogonFailure: Invalid password +InvalidCredentialsADAccountRestriction: Restrictions on your Fraport account prevent a login InvalidCredentialsADInvalidLogonHours: User may not login at the current time of day InvalidCredentialsADInvalidWorkstation: User may not login from this system -InvalidCredentialsADPasswordExpired: Password expired -InvalidCredentialsADAccountDisabled: Account disabled +InvalidCredentialsADPasswordExpired: Password expired, please change your Fraport account password by the usual way (eg. E-account users via Azure portal) +InvalidCredentialsADAccountDisabled: Fraport account disabled, please contact general IT support InvalidCredentialsADTooManyContextIds: Account carries to many security identifiers -InvalidCredentialsADAccountExpired: Account expired -InvalidCredentialsADPasswordMustChange: Password needs to be changed -InvalidCredentialsADAccountLockedOut: Account disabled by intruder detection +InvalidCredentialsADAccountExpired: Account expired, please contact general IT support +InvalidCredentialsADPasswordMustChange: Password needs to be changed, please change your Fraport account password by the usual way (eg. E-account users via Azure portal) +InvalidCredentialsADAccountLockedOut: Account disabled by intruder detection, please contact general IT support LoginTitle: Authentication From 54a956dc3663b6d3fe0540d75983a1845074f21f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 24 Apr 2023 13:45:10 +0000 Subject: [PATCH 7/7] chore(error): remove default layout from error handler --- src/Foundation/Yesod/ErrorHandler.hs | 88 ++++++++++++++-------------- 1 file changed, 44 insertions(+), 44 deletions(-) diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index fb330960b..a8edfbccf 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -72,39 +72,51 @@ errorHandler err = do setSessionJson SessionError sessErr selectRep $ do - provideRep $ do - mr <- getMessageRender - let - encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX () - encrypted plaintextJson plaintext = do - let displayEncrypted ciphertext = - [whamlet| - $newline never -

_{MsgErrorResponseEncrypted} - 

-                    #{ciphertext}
-                |]
-          if
-            | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
-            | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
-            | otherwise -> plaintext
+    -- provideRep $ do
+    --   mr <- getMessageRender
+    --   let
+    --     encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+    --     encrypted plaintextJson plaintext = do
+    --       let displayEncrypted ciphertext = 
+    --             [whamlet|
+    --               $newline never
+    --               
_{MsgErrorResponseEncrypted}
+    --               
+    --                 #{ciphertext}
+    --             |]
+    --       if
+    --         | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
+    --         | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
+    --         | otherwise -> plaintext
 
-        errPage = case err of
-          NotFound -> [whamlet|
_{MsgErrorResponseNotFound}|]
-          InternalError err'
-            | "Crash Button" `isPrefixOf` err'   -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
-            | otherwise -> encrypted err' [whamlet|
#{fromMaybe err' decrypted}|]
-          InvalidArgs errs -> [whamlet|
-              
    
-                $forall err' <- errs
-                  
  • 
-                    #{err'}
-             |]
-          NotAuthenticated -> [whamlet|
    _{MsgErrorResponseNotAuthenticated}|]
-          PermissionDenied err' -> [whamlet|
    #{err'}|]
-          BadMethod method -> [whamlet|
    _{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
-      siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
-        errPage
+    --     errPage = case err of
+    --       NotFound -> [whamlet|
    _{MsgErrorResponseNotFound}|]
+    --       InternalError err'
+    --         | "Crash Button" `isPrefixOf` err'   -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
+    --         | otherwise -> encrypted err' [whamlet|
    #{fromMaybe err' decrypted}|]
+    --       InvalidArgs errs -> [whamlet|
+    --           
      
+    --             $forall err' <- errs
+    --               
    • 
+    --                 #{err'}
+    --          |]
+    --       NotAuthenticated -> [whamlet|
      _{MsgErrorResponseNotAuthenticated}|]
+    --       PermissionDenied err' -> [whamlet|
      #{err'}|]
+    --       BadMethod method -> [whamlet|
      _{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
+    --   siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
+    --     errPage
+    provideRep $ case err of
+      PermissionDenied err' -> return err'
+      InternalError err'
+        | isEncrypted && shouldEncrypt -> do
+            addHeader "Encrypted-Error-Message" "True"
+            return err'
+        | shouldEncrypt -> do
+            addHeader "Encrypted-Error-Message" "True"
+            encodedSecretBox SecretBoxPretty err'
+        | otherwise -> return $ fromMaybe err' decrypted
+      InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
+      _other -> return Text.empty
     provideRep . fmap PrettyValue $ case err of
       PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
       InternalError err'
@@ -120,15 +132,3 @@ errorHandler err = do
         | otherwise -> return $ object [ "message" JSON..= fromMaybe err' decrypted ]
       InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
       _other -> return $ object []
-    provideRep $ case err of
-      PermissionDenied err' -> return err'
-      InternalError err'
-        | isEncrypted && shouldEncrypt -> do
-            addHeader "Encrypted-Error-Message" "True"
-            return err'
-        | shouldEncrypt -> do
-            addHeader "Encrypted-Error-Message" "True"
-            encodedSecretBox SecretBoxPretty err'
-        | otherwise -> return $ fromMaybe err' decrypted
-      InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
-      _other -> return Text.empty