fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'fradrive/localmaster'

Browse Source
This commit is contained in:
Steffen Jost 2023-04-24 13:56:22 +00:00
commit 472931d946
11 changed files with 93 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
messages/uniworx/categories/authorization/de-de-formal.msg
View File

@ -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
FormHoneypotFilled: Bitte füllen Sie keines der verstecken Felder aus

14
messages/uniworx/categories/authorization/en-eu.msg
View File

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

88
src/Foundation/Yesod/ErrorHandler.hs
View File

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

4
src/Handler/Admin/Avs.hs
View File

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

4
src/Handler/Tutorial/Users.hs
View File

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

17
src/Handler/Utils/Avs.hs
View File

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

2
src/Handler/Utils/Profile.hs
View File

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

3
src/Model/Types/Avs.hs
View File

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

16
src/Utils/Avs.hs
View File

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

2
templates/profileData.hamlet
View File

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

2
test/Database/Fill.hs
View File

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