fix(email): reenable ldap logins with invalid email addresses (missing mail field problem)

src/Foundation/Yesod/Auth.hs

@@ -260,11 +260,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
       | otherwise
         -> throwM CampusUserInvalidIdent
 
-    userEmail <- if -- TODO: refactor
+    userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E<number@fraport.de` here, too strong! Make Email-Field optional!
-      -- | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
+      | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-      --   -> return $ CI.mk userEmail
-      | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
          -> return $ CI.mk userEmail
+      -- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
+      --    -> return $ CI.mk userEmail
       | otherwise
         -> throwM CampusUserInvalidEmail
         
@@ -306,19 +306,20 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
         , userPrefersPostal           = userDefaultPrefersPostal
         , ..
         }
-      userUpdate =  [
+      userUpdate =  
-                    -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
+        [ UserLastAuthentication      =. Just now  | isLogin ] ++
-                      UserFirstName               =. userFirstName
+        [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
-                    , UserSurname                 =. userSurname
+        [
-                    , UserEmail                   =. userEmail
+        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
-                    , UserLastLdapSynchronisation =. Just now
+          UserFirstName               =. userFirstName
-                    , UserLdapPrimaryKey          =. userLdapPrimaryKey
+        , UserSurname                 =. userSurname                    
-                    , UserMobile                  =. userMobile
+        , UserLastLdapSynchronisation =. Just now
-                    , UserTelephone               =. userTelephone
+        , UserLdapPrimaryKey          =. userLdapPrimaryKey
-                    , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
+        , UserMobile                  =. userMobile
-                    , UserCompanyDepartment       =. userCompanyDepartment
+        , UserTelephone               =. userTelephone
-                    ] ++
+        , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
-                    [ UserLastAuthentication =. Just now  | isLogin ]
+        , UserCompanyDepartment       =. userCompanyDepartment
+        ]
     return (newUser, userUpdate)
 
   where

src/Handler/Utils/Mail.hs

@@ -52,6 +52,13 @@ userAddress :: User -> Address
 userAddress User{userEmail, userDisplayEmail, userDisplayName}
   = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
 
+userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address)
+userAddressError User{userEmail, userDisplayEmail, userDisplayName} 
+  | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)
+  | otherwise = do
+      $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow userDisplayEmail <> " Sent to support instead." -- <> " with subject " <> tshow failedSubject
+      (True,) <$> getsYesod (view _appMailSupport)
+
 -- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True
 userMailT :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
@@ -59,7 +66,7 @@ userMailT :: ( MonadHandler m
              , MonadUnliftIO m
              ) => UserId -> MailT m () -> m ()
 userMailT uid mAct = do
-  (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
+  (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid  
   let undername = underling ^. _userDisplayName -- nameHtml' underling
       undermail = CI.original $ pickValidEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail)
       infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|            
@@ -98,21 +105,17 @@ userMailT uid mAct = do
               $else
                 _{MsgMailSupervisorNoCopy}
           |]
-        mailtoAddr = userAddress supervisor
+    (mailOk, mailtoAddr) <- userAddressError supervisor -- ensures a valid email, logs error and sends to support otherwise 
-    if validEmail $ addressEmail mailtoAddr
+
-      then 
+    mailT ctx $ do      
-        mailT ctx $ do
+      _mailTo .= pure mailtoAddr 
-          -- TODO: ensure that the Email is VALID HERE!
+      mAct
-          _mailTo .= pure mailtoAddr 
+      if uid==svr
-          mAct
+        then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
-          if uid==svr
+        else do
-            then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
+          mapSubject ("[SUPERVISOR] " <>)
-            else do
+          addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
-              mapSubject ("[SUPERVISOR] " <>)
+      unless mailOk $ mapSubject ("[ERROR]" <>)
-              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
@@ -137,23 +140,13 @@ userMailTdirect uid mAct = do
           SelFormatTime -> userTimeFormat
       , mcCsvOptions = userCsvOptions
       }
-    mailtoAddr = userAddress user 
+  (mailOk, mailtoAddr) <- userAddressError user -- ensures a valid email, logs error and sends to support otherwise 
   mailT ctx $ do
-    failedSubject <- lookupMailHeader "Subject"
+    -- failedSubject <- lookupMailHeader "Subject"
-    unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
+    -- unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
     _mailTo .= pure mailtoAddr
-    mAct  
+    unless mailOk $ mapSubject ("[ERROR]" <>)
-{- Problematic due to return type a      
+    mAct
-  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
              , HandlerSite m ~ UniWorX