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

config/settings.yml

@@ -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: 
+mail-reroute-to: 
-#  name:         "_env:MAIL_REROUTE_TO_NAME:Steffen Jost"
+ name:         "_env:MAIL_REROUTE_TO_NAME:"
-#  email:        "_env:MAIL_REROUTE_TO_EMAL:jost@tcs.ifi.lmu.de"
+ email:        "_env:MAIL_REROUTE_TO_EMAIL:"
 #mail-verp:
 #  separator:    "_env:VERP_SEPARATOR:+"
 #  prefix:       "_env:VERP_PREFIX:bounce"

messages/uniworx/utils/utils/de-de-formal.msg

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

messages/uniworx/utils/utils/en-eu.msg

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

src/Handler/Admin.hs

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

src/Handler/Profile.hs

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

src/Handler/Utils/Mail.hs

@@ -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
+        mailtoAddr = userAddress supervisor
-      _mailTo .= pure (userAddress supervisor)
+    if validEmail $ addressEmail mailtoAddr
-      mAct
+      then 
-      if uid==svr
+        mailT ctx $ do
-        then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
+          -- TODO: ensure that the Email is VALID HERE!
-        else do
+          _mailTo .= pure mailtoAddr 
-          mapSubject ("[SUPERVISOR] " <>)
+          mAct
-          addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
+          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)
+    failedSubject <- lookupMailHeader "Subject"
-    mAct
+    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

src/Handler/Utils/Profile.hs

@@ -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 
+pickValidEmail x y
-  | validEmail' x = x 
+  | validEmail' x = x
-  | otherwise     = y
+  | 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

src/Handler/Utils/Users.hs

@@ -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    
+  where        
-    emailPossible = validEmail' userEmail
-    postPossible  = isJust pa
     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)

src/Jobs/Handler/QueueNotification.hs

@@ -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}) -> 
+            .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) -> 
-                and2M (return $ validEmail' 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

src/Settings.hs

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

start.sh

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

templates/profileData.hamlet

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

test/Database/Fill.hs

@@ -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
+      , userMatrikelnummer = Just userMatrikelnummer'
-      , userEmail = userIdent
+      , userEmail        = userEmail'
-      , userDisplayEmail = userIdent
+      , 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] []