Merge branch 'fradrive/localmaster'

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
+InvalidCredentialsADPasswordExpired: Passwort abgelaufen; ändern Sie Ihr Fraport Passwort auf dem üblichen Weg (z.B. E-Account Nutzer per Azure-Portal)
-InvalidCredentialsADAccountDisabled: Benutzereintrag gesperrt
+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
+InvalidCredentialsADAccountExpired: Benutzereintrag abgelaufen, bitte wenden Sie sich an den allgemeinen IT Support
-InvalidCredentialsADPasswordMustChange: Passwort muss geändert werden
+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
+InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt, bitte wenden Sie sich an den allgemeinen IT Support
 
 LoginTitle: Authentifizierung
 

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
+InvalidCredentialsADLogonFailure: Invalid password
-InvalidCredentialsADAccountRestriction: Account restrictions are preventing login
+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
+InvalidCredentialsADPasswordExpired: Password expired, please change your Fraport account password by the usual way (eg. E-account users via Azure portal)
-InvalidCredentialsADAccountDisabled: Account disabled
+InvalidCredentialsADAccountDisabled: Fraport account disabled, please contact general IT support
 InvalidCredentialsADTooManyContextIds: Account carries to many security identifiers
-InvalidCredentialsADAccountExpired: Account expired
+InvalidCredentialsADAccountExpired: Account expired, please contact general IT support
-InvalidCredentialsADPasswordMustChange: Password needs to be changed
+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
+InvalidCredentialsADAccountLockedOut: Account disabled by intruder detection, please contact general IT support
 
 LoginTitle: Authentication
 

src/Foundation/Yesod/ErrorHandler.hs

@@ -72,39 +72,51 @@ errorHandler err = do
   setSessionJson SessionError sessErr
 
   selectRep $ do
-    provideRep $ do
+    -- provideRep $ do
-      mr <- getMessageRender
+    --   mr <- getMessageRender
-      let
+    --   let
-        encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+    --     encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
-        encrypted plaintextJson plaintext = do
+    --     encrypted plaintextJson plaintext = do
-          let displayEncrypted ciphertext = 
+    --       let displayEncrypted ciphertext = 
-                [whamlet|
+    --             [whamlet|
-                  $newline never
+    --               $newline never
-                  <p>_{MsgErrorResponseEncrypted}
+    --               <p>_{MsgErrorResponseEncrypted}
-                  <pre .literal-error>
+    --               <pre .literal-error>
-                    #{ciphertext}
+    --                 #{ciphertext}
-                |]
+    --             |]
-          if
+    --       if
-            | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
+    --         | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
-            | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
+    --         | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
-            | otherwise -> plaintext
+    --         | otherwise -> plaintext
 
-        errPage = case err of
+    --     errPage = case err of
-          NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
+    --       NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
-          InternalError err'
+    --       InternalError err'
-            | "Crash Button" `isPrefixOf` err'   -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
+    --         | "Crash Button" `isPrefixOf` err'   -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
-            | otherwise -> encrypted err' [whamlet|<p .literal-error>#{fromMaybe err' decrypted}|]
+    --         | otherwise -> encrypted err' [whamlet|<p .literal-error>#{fromMaybe err' decrypted}|]
-          InvalidArgs errs -> [whamlet|
+    --       InvalidArgs errs -> [whamlet|
-              <ul>
+    --           <ul>
-                $forall err' <- errs
+    --             $forall err' <- errs
-                  <li .literal-error>
+    --               <li .literal-error>
-                    #{err'}
+    --                 #{err'}
-             |]
+    --          |]
-          NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
+    --       NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
-          PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
+    --       PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
-          BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
+    --       BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
-      siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
+    --   siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
-        errPage
+    --     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

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
 

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

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 $ (,,)
+  -- 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    
-    <*> getBy (UniqueUserAvsUser uid)
     <*> (E.select $ do
           (usrSuper :& usrAvs) <-
             E.from $     E.table @UserSupervisor            
@@ -545,9 +549,8 @@ updateReceivers uid = do
         )
   let (superVs, avsIds) = unzip avsSupers
       receiverIDs :: [UserId] = E.unValue <$> superVs      
-      underlingAvsId = userAvsPersonId . entityVal <$> avsUnderling
+      toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
-      toUpdate = Set.fromList $ catMaybes (underlingAvsId : (E.unValue <$> avsIds))      
+      directResult = return (underling, pure underling, True)     -- already contains updated address
-      directResult = return (underling, pure underling, True)
   forM_ toUpdate (void . maybeCatchAll . upsertAvsUserById)       -- attempt to update postaddress from AVS  
   if null receiverIDs 
     then directResult

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
 

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)

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
 
 -----------------------

templates/profileData.hamlet

@@ -65,7 +65,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         <dd .deflist__dd>
           #{userEmail}
             $if not (validEmail' userEmail)
-            \ ^{messageTooltip tooltipInvalidEmail}
+              \ ^{messageTooltip tooltipInvalidEmail}
       <dt .deflist__dt>
         _{MsgAdminUserPinPassword}
       <dd .deflist__dd>

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"