refactor(avs): rework fraport email recognition

models/users.model

@@ -21,7 +21,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     lastAuthentication UTCTime Maybe        -- last login date
     created        UTCTime default=now()
     lastLdapSynchronisation UTCTime Maybe
-    ldapPrimaryKey UserEduPersonPrincipalName Maybe
+    ldapPrimaryKey UserEduPersonPrincipalName Maybe   -- Fraport Personnel Number or Email-Prefix for @fraport.de work here
     tokensIssuedAfter  UTCTime Maybe        -- do not accept bearer tokens issued before this time (accept all tokens if null)
     matrikelnummer UserMatriculation Maybe  -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer!
     firstName      Text                     -- For export in tables, pre-split firstName from displayName

src/Handler/Utils/Avs.hs

@@ -672,7 +672,7 @@ createAvsUserById api = do
           return $ seq userCompId $ seq userAvsId uid
       
 
-
+-- | upsert superior by eMail through LDAP only (currently no email search available in AVS)
 repsertSuperiorSupervisor :: Maybe CompanyId -> AvsFirmInfo -> UserId -> DB ()
 repsertSuperiorSupervisor cid afi uid = 
   whenIsJust (afi ^. _avsFirmEMailSuperior) $ \supemail -> forMM_
@@ -762,7 +762,7 @@ guessAvsUser someid = do
       other -> do -- attempt to recover by trying other ids
         whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all      
         runDB . runMaybeT $ 
-          let someIdent = stripCI someid
+          let someIdent = stripCI someid                                  -- also see Handler.Utils.guessUserByEmail for a similar function, this one is more lenient, since a unique email is acceptable, even it would not be unique as DisplayEmail
           in    MaybeT (getKeyBy $ UniqueEmail          someIdent)        -- recall that monadic actions are only executed until first success here
             <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
             <|> MaybeT (getKeyByFilter [UserDisplayEmail ==. someIdent])

src/Handler/Utils/Users.hs

@@ -201,17 +201,13 @@ computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
 computeUserAuthenticationDigest = hashlazy . JSON.encode
 
 guessUserByEmail :: UserEmail -> DB (Maybe UserId)
-guessUserByEmail eml = listToMaybe <$> selectKeysList
-    (ofoldl1Ex' (||.)      
-      [ [UserDisplayEmail ==. eml]
-      , [UserEmail        ==. eml]
-      , [UserIdent        ==. eml]
-      -- , [UserLdapPrimaryKey ==. Text.stripSuffix "@fraport.de" $ CI.foldedCase eml]
-      ]
-    )
-    [ Asc UserEmail -- Unique, to ensure reproducable results
-    , LimitTo 1
-    ]  
+guessUserByEmail eml = getKeyByFilter $ ofoldl1Ex' (||.) $
+  mcons (getFraportLogin (CI.original eml) <&> (\lgi ->
+    [UserLdapPrimaryKey ==. Just lgi]))                           -- Note that we must exclude `==. Nothing` here!
+  [ [UserDisplayEmail   ==. eml]
+  , [UserEmail          ==. eml]
+  , [UserIdent          ==. eml]      
+  ]
 
 data GuessUserInfo
   = GuessUserMatrikelnummer

src/Utils.hs

@@ -1039,6 +1039,14 @@ altM ma mb = ma >>= \case
   Nothing -> mb
   res     -> return res
 
+-- | Map f and get the first Just
+firstJust :: MonoFoldable mono => (Element mono -> Maybe a) -> mono -> Maybe a
+firstJust f = foldr go Nothing
+  where 
+    -- go :: a -> Maybe b -> Maybe b
+    go x Nothing = f x
+    go _ res     = res
+
 --   Takes computations returnings @Maybe@; tries each one in order.
 --   The first one to return a @Just@ wins. Returns @Nothing@ if all computations
 --   return @Nothing@.

src/Utils/Mail.hs

@@ -13,12 +13,29 @@ import qualified Data.CaseInsensitive as CI
 
 import qualified Text.Email.Validate as Email
 
+-- | domains used by LDAP accounts
+fraportMailDomains :: [Text]
+fraportMailDomains = ["@fraport.de"] -- <&> foldCase only!
+
+-- | returns the part before the @ symbol of an email address that ends with a fraport domain, preserving case
+--   eg. getFraportLogin "E1234@fraport.de"     == Just "E1234" 
+--       getFraportLogin "S.Guy@fraport.de"     == Just "S.Guy"
+--       getFraportLogin "S.Guy@elsewhere.com"  == Nothing
+--   Use CI.traverse getFraportLogin :: CI Text -> Maybe (CI Text)
+--       CI.traverse getFraportLogin "S.Jost@Fraport.de" == Just "S.Jost" 
+getFraportLogin :: Text -> Maybe Text
+getFraportLogin email = orgCase <$> lowerCaseLogin
+  where 
+    orgCase         = flip Text.take email . Text.length
+    lowerCaseLogin  = firstJust (flip Text.stripSuffix $ foldCase email) fraportMailDomains
+
+-- | check that an email is valid and that it is not an E-account that nobody reads
 -- also see `Handler.Utils.Users.getUserEmail` for Tests accepting User Type
 validEmail :: Text -> Bool      -- Email = Text
 validEmail email = validRFC5322 && not invalidFraport
   where 
     validRFC5322 = Email.isValid $ encodeUtf8 email
-    invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of  
+    invalidFraport = case getFraportLogin email of
       Just fralogin -> Text.all Char.isDigit $ Text.drop 1 fralogin          -- Emails like E1234@fraport.de or 012345!fraport.de are not read
       Nothing       -> False