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

Merge remote-tracking branch 'origin/fradrive/localmaster'

Browse Source
This commit is contained in:
Steffen Jost 2023-03-13 17:32:59 +01:00
commit deb13e67fa
13 changed files with 121 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
config/settings.yml
View File

@ -24,9 +24,9 @@ mail-from:
email: "_env:MAILFROM_EMAIL:uniworx@localhost"
mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true"
#mail-reroute-to:
# name: "_env:MAIL_REROUTE_TO_NAME:Steffen Jost"
# email: "_env:MAIL_REROUTE_TO_EMAL:jost@tcs.ifi.lmu.de"
mail-reroute-to:
name: "_env:MAIL_REROUTE_TO_NAME:"
email: "_env:MAIL_REROUTE_TO_EMAIL:"
#mail-verp:
# separator: "_env:VERP_SEPARATOR:+"
# prefix: "_env:VERP_PREFIX:bounce"

1
messages/uniworx/utils/utils/de-de-formal.msg
View File

@ -77,6 +77,7 @@ MultiUserFieldExplanationAnyUser: Dieses Eingabefeld sucht in den Adressen aller
MultiUserFieldInvitationExplanation: An Adressen, die so keinem Uni2work-Benutzer/keiner Uni2work-Benutzerin zugeordnet werden können, wird eine Einladung per E-Mail versandt.
MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hier angeben, eine Einladung per E-Mail versandt.
AmbiguousEmail: E-Mail-Adresse nicht eindeutig
InvalidEmailAddress: E-Mail-Adresse ist ungültig
UtilExamResultGrade: Note
UtilExamResultPass: Bestanden/Nicht Bestanden
UtilExamResultNoShow: Nicht erschienen

1
messages/uniworx/utils/utils/en-eu.msg
View File

@ -77,6 +77,7 @@ MultiUserFieldExplanationAnyUser: This input searches through the addresses of a
MultiUserFieldInvitationExplanation: For addresses, which are not found in this way, an invitation will be sent via email.
MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email to all addresses you enter here.
AmbiguousEmail: Email address is ambiguous
InvalidEmailAddress: Email address is invalid
UtilExamResultGrade: Grade
UtilExamResultPass: Passed/Failed
UtilExamResultNoShow: Not present

22
src/Handler/Admin.hs
View File

@ -23,6 +23,7 @@ import qualified Database.Esqueleto.Utils as E
import Handler.Utils.DateTime
import Handler.Utils.Avs
import Handler.Utils.Widgets
import Handler.Utils.Users
import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin
@ -83,7 +84,7 @@ getAdminProblemsR = do
getProblemUnreachableR :: Handler Html
getProblemUnreachableR = do
unreachables <- runDB $ E.select retrieveUnreachableUsers
unreachables <- runDB retrieveUnreachableUsers'
siteLayoutMsg MsgProblemsUnreachableHeading $ do
setTitleI MsgProblemsUnreachableHeading
[whamlet|
@ -92,7 +93,7 @@ getProblemUnreachableR = do
<ul>
$forall usr <- unreachables
<li>
^{linkUserWidget ForProfileR usr}
^{linkUserWidget ForProfileR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
|]
getProblemFbutNoR :: Handler Html
@ -147,9 +148,24 @@ retrieveUnreachableUsers = do
user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.isNothing (user E.^. UserCompanyDepartment)
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
return user
retrieveUnreachableUsers' :: DB [Entity User]
retrieveUnreachableUsers' = do
obviousUnreachable <- E.select retrieveUnreachableUsers
emailUsers <- E.select $ do
user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.isNothing (user E.^. UserCompanyDepartment)
E.&&. ( ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
E.||. ((user E.^. UserEmail) `E.like` E.val "%@%.%"))
pure user
let hasInvalidEmail = isNothing . getEmailAddress . entityVal
invaldEmail = filter hasInvalidEmail emailUsers
return $ obviousUnreachable ++ invaldEmail
allDriversHaveAvsId :: Day -> DB Bool
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId

7
src/Handler/Profile.hs
View File

@ -357,6 +357,10 @@ validateSettings User{..} = do
userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
validDisplayName userTitle userFirstName userSurname userDisplayName'
userDisplayEmail' <- use _stgDisplayEmail
guardValidation MsgInvalidEmailAddress $
not (validEmail' userDisplayEmail')
userPostAddress' <- use _stgPostAddress
let postalNotSet = isNothing userPostAddress'
postalIsValid = validPostAddress userPostAddress'
@ -445,7 +449,7 @@ serveProfileR (uid, user@User{..}) = do
now <- liftIO getCurrentTime
runDBJobs $ do
update uid $
[ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- SJ asks: what does this line achieve?
[ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- Note that DisplayEmail changes must be confirmed, see 472
[ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++
[ UserDisplayName =. stgDisplayName
, UserMaxFavourites =. stgMaxFavourites
@ -617,6 +621,7 @@ makeProfileData (Entity uid User{..}) = do
mCRoute <- getCurrentRoute
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
let profileRemarks = $(i18nWidgetFile "profile-remarks")
return $(widgetFile "profileData")

47
src/Handler/Utils/Mail.hs
View File

@ -16,7 +16,7 @@ import Handler.Utils.Pandoc
import Handler.Utils.Files
import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here?
import Handler.Utils.Users (getReceivers)
import Handler.Utils.Profile (pickValidEmail)
import Handler.Utils.Profile
import qualified Data.CaseInsensitive as CI
@ -42,13 +42,13 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSo
userAddressFrom :: User -> Address
-- ^ Format an e-mail address suitable for usage in a @From@-header
--
-- Uses `userDisplayEmail`
-- Uses `userDisplayEmail` only
userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail
userAddress :: User -> Address
-- ^ Format an e-mail address suitable for usage as a recipient
--
-- Like userAddressFrom and no longer uses `userEmail`, since unlike Uni2work, userEmail from LDAP is untrustworthy.
-- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy.
userAddress User{userEmail, userDisplayEmail, userDisplayName}
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
@ -98,15 +98,21 @@ userMailT uid mAct = do
$else
_{MsgMailSupervisorNoCopy}
|]
mailT ctx $ do
_mailTo .= pure (userAddress supervisor)
mAct
if uid==svr
then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
else do
mapSubject ("[SUPERVISOR] " <>)
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
mailtoAddr = userAddress supervisor
if validEmail $ addressEmail mailtoAddr
then
mailT ctx $ do
-- TODO: ensure that the Email is VALID HERE!
_mailTo .= pure mailtoAddr
mAct
if uid==svr
then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
else do
mapSubject ("[SUPERVISOR] " <>)
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
else -- do
-- failedSubject <- lookupMailHeader "Subject"
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr -- <> " with subject " <> tshow failedSubject
-- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
userMailTdirect :: ( MonadHandler m
@ -131,9 +137,22 @@ userMailTdirect uid mAct = do
SelFormatTime -> userTimeFormat
, mcCsvOptions = userCsvOptions
}
mailtoAddr = userAddress user
mailT ctx $ do
_mailTo .= pure (userAddress user)
mAct
failedSubject <- lookupMailHeader "Subject"
unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
_mailTo .= pure mailtoAddr
mAct
{- Problematic due to return type a
if validEmail $ addressEmail mailtoAddr
then mailT ctx $ do
_mailTo .= pure mailtoAddr
mAct
else
-- failedSubject <- lookupMailHeader "Subject"
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAdd -- <> " with subject " <> tshow failedSubject
-}
addFileDB :: ( MonadMail m

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

@ -9,7 +9,8 @@ module Handler.Utils.Profile
, validDisplayName
, fixDisplayName
, validPostAddress
, validEmail, validEmail', pickValidEmail
, validEmail, validEmail'
, pickValidEmail, pickValidEmail'
) where
import Import.NoFoundation
@ -79,14 +80,27 @@ validPostAddress (Just StoredMarkup {markupInput = addr})
= True
validPostAddress _ = False
-- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type
validEmail :: Email -> Bool -- Email = Text
validEmail = Email.isValid . encodeUtf8
validEmail email = validRFC5322 && not invalidFraport
where
validRFC5322 = Email.isValid $ encodeUtf8 email
invalidFraport = case Text.stripSuffix "@fraport.de" email of
Just fralogin -> all isDigit $ drop 1 fralogin
Nothing -> False
validEmail' :: UserEmail -> Bool -- UserEmail = CI Text
validEmail' = Email.isValid . encodeUtf8 . CI.original
validEmail' = validEmail . CI.original
-- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function
pickValidEmail :: UserEmail -> UserEmail -> UserEmail
pickValidEmail x y
| validEmail' x = x
| otherwise = y
pickValidEmail x y
| validEmail' x = x
| otherwise = y
-- | returns first valid email address or none if none are valid
pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail
pickValidEmail' x y
| validEmail' x = Just x
| validEmail' y = Just y
| otherwise = Nothing

14
src/Handler/Utils/Users.hs
View File

@ -14,6 +14,7 @@ module Handler.Utils.Users
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
, assimilateUser
, userPrefersEmail, userPrefersLetter
, getEmailAddress
, getPostalAddress, getPostalPreferenceAndAddress
, abbrvName
, getReceivers
@ -71,13 +72,16 @@ userPrefersEmail = not . userPrefersLetter
-- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
getPostalPreferenceAndAddress usr@User{..} =
getPostalPreferenceAndAddress usr@User{userPrefersPostal} =
((userPrefersPostal && postPossible) || not emailPossible, pa)
-- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set
where
emailPossible = validEmail' userEmail
postPossible = isJust pa
where
pa = getPostalAddress usr
postPossible = isJust pa
emailPossible = isJust $ getEmailAddress usr
getEmailAddress :: User -> Maybe UserEmail
getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail
getPostalAddress :: User -> Maybe [Text]
getPostalAddress User{..}
@ -89,7 +93,7 @@ getPostalAddress User{..}
| otherwise
= Nothing
-- | DEPRECATED, use Handler.Utils.Avs.updateReceivers instead
-- | Consider using Handler.Utils.Avs.updateReceivers instead
-- Return Entity User and all Supervisors with rerouteNotifications as well as
-- a boolean indicating if the user is own supervisor with rerouteNotifications
getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)

6
src/Jobs/Handler/QueueNotification.hs
View File

@ -15,7 +15,7 @@ import Jobs.Queue
import qualified Data.Set as Set
import Handler.Utils.Profile (validEmail')
import Handler.Utils.Profile (pickValidEmail')
import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam
@ -26,8 +26,8 @@ dispatchJobQueueNotification :: Notification -> JobHandler UniWorX
dispatchJobQueueNotification jNotification = JobHandlerAtomic $
runConduit $ yield jNotification
.| transPipe (hoist lift) determineNotificationCandidates
.| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userEmail}) ->
and2M (return $ validEmail' userEmail) $
.| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) ->
and2M (return $ isJust $ pickValidEmail' userDisplayEmail userEmail) $
or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
.| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification')
.| sinkDBJobs

2
src/Settings.hs
View File

@ -657,7 +657,7 @@ instance FromJSON AppSettings where
appMailVerp <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing)
appMailRetainSent <- o .: "mail-retain-sent"
appMailSupport <- o .: "mail-support"
appMailRerouteTo <- o .:? "mail-reroute-to"
appMailRerouteTo <- join <$> (o .:? "mail-reroute-to" <|> pure Nothing)
appJobWorkers <- o .: "job-workers"
appJobFlushInterval <- o .:? "job-flush-interval"

2
start.sh
View File

@ -29,6 +29,8 @@ export RIBBON=${RIBBON:-${__HOST:-localhost}}
export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))}
export AVSPASS=${AVSPASS:-nopasswordset}
export PATH=${PATH:/home/jost/projects/fradrive}
export MAIL_REROUTE_TO_NAME='Steffen Jost'
export MAIL_REROUTE_TO_EMAIL=jost@tcs.ifi.lmu.de
unset HOST
move-back() {

8
templates/profileData.hamlet
View File

@ -56,12 +56,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dt .deflist__dt>
_{MsgUserDisplayEmail}
<dd .deflist__dd .email>
#{userDisplayEmail}
#{mailtoHtml userDisplayEmail}
$if not (validEmail' userDisplayEmail)
\ ^{messageTooltip tooltipInvalidEmail}
$if userEmail /= userDisplayEmail
<dt .deflist__dt>
_{MsgUserSystemEmail}
<dd .deflist__dd>
#{mailtoHtml userEmail}
#{userEmail}
$if not (validEmail' userEmail)
\ ^{messageTooltip tooltipInvalidEmail}
<dt .deflist__dt>
_{MsgAdminUserPinPassword}
<dd .deflist__dd>

22
test/Database/Fill.hs
View File

@ -164,7 +164,7 @@ fillDb = do
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer = Nothing
, userEmail = "jost@tcs.ifi.lmu.de"
, userEmail = "e12345@fraport.de"
, userDisplayEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost"
, userSurname = "Jost"
@ -386,14 +386,14 @@ fillDb = do
= foldMap tshow cs : toMatrikel rest
| otherwise
= []
manyUser (firstName, middleName, userSurname) (Just -> userMatrikelnummer) = User
manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User
{ userIdent
, userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer
, userEmail = userIdent
, userDisplayEmail = userIdent
, userMatrikelnummer = Just userMatrikelnummer'
, userEmail = userEmail'
, userDisplayEmail = userDisplayEmail'
, userDisplayName = case middleName of
Just middleName' -> [st|#{firstName} #{middleName'} #{userSurname}|]
Nothing -> [st|#{firstName} #{userSurname}|]
@ -433,6 +433,18 @@ fillDb = do
userIdent = fromString $ case middleName of
Just middleName' -> repack [st|#{firstName}.#{middleName'}.#{userSurname}@example.invalid|]
Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
userEmail' :: CI Text
userEmail' = CI.mk $ case firstName of
"James" -> userIdent
"John" -> userIdent
--"Elizabeth" -> "AVSID:" <> userMatrikelnummer'
_ -> "E" <> userMatrikelnummer' <> "@fraport.de"
userDisplayEmail' :: CI Text
userDisplayEmail' = CI.mk $ case userSurname of
"Walker" -> "AVSNO:" <> userMatrikelnummer'
"Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de"
_ -> userIdent
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
matUsers <- selectList [UserMatrikelnummer !=. Nothing] []