fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(auth): work on authenticate

Browse Source
This commit is contained in:
Sarah Vaupel 2024-02-16 03:25:36 +01:00
parent 848890d3cd
commit a0e7b2f96c
4 changed files with 285 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
models/auth.model
View File

@ -35,6 +35,7 @@ AuthSourceLdap
UserAuth
ident UserIdent -- Human-readable text uniquely identifying a user
lastLogin UTCTime -- When did the corresponding User last authenticate using this entry?
lastSync UTCTime Maybe -- When was the corresponding User entry last synced with any external source? -- TODO rethink
Primary ident
UniqueAuthentication ident
deriving Show Eq Ord Generic
@ -44,7 +45,7 @@ ExternalAuth
ident UserIdent
source AuthenticationSourceIdent -- Identifier of the external source in the config
data Value "default='{}'::jsonb" -- Raw user data from external source
lastSync UTCTime -- When was the corresponding User entry last synced with this external source?
lastSync UTCTime -- When was the corresponding User entry last synced with this external source? -- TODO rethink
UniqueExternalAuth ident source -- At most one entry of this user per source
deriving Show Eq Ord Generic

7
src/Foundation/Instances.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -119,9 +119,9 @@ instance YesodPersistRunner UniWorX where
getDBRunner :: HasCallStack => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
getDBRunner = UniWorX.getDBRunner' callStack
instance YesodAuth UniWorX where
type AuthId UniWorX = UserId
type AuthId UniWorX = UserAuthId
-- Where to send a user after successful login
loginDest _ = NewsR
@ -172,6 +172,7 @@ instance YesodAuth UniWorX where
BearerToken{..} <- MaybeT . liftHandler $ runDBRead maybeBearerToken
hoistMaybe bearerImpersonate
-- TODO: update?
instance YesodAuthPersist UniWorX where
getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User)
getAuthEntity = liftHandler . runDBRead . get

4
src/Foundation/Navigation.hs
View File

@ -1212,8 +1212,8 @@ pageActions (AdminUserR cID) = return
, navRoute = UserPasswordR cID
, navAccess' = NavAccessDB $ do
uid <- decrypt cID
User{userAuthentication} <- get404 uid
return $ is _AuthPWHash userAuthentication
User{userIdent} <- get404 uid
existsBy $ UniqueInternalAuth userIdent
, navType = NavTypeLink { navModal = True }
, navQuick' = mempty
, navForceActive = False

485
src/Foundation/Yesod/Auth.hs
View File

@ -5,52 +5,57 @@
module Foundation.Yesod.Auth
( authenticate
, ldapLookupAndUpsert
, upsertLdapUser, upsertAzureUser
, upsertUser
, decodeLdapUserTest, decodeAzureUserTest
, CampusUserConversionException(..)
, UserConversionException(..)
, updateUserLanguage
) where
import Import.NoFoundation hiding (authenticate)
import Foundation.Type
import Foundation.Types
import Foundation.I18n
import Handler.Utils.Profile
import Handler.Utils.LdapSystemFunctions
import Handler.Utils.Memcached
import Foundation.Authorization (AuthorizationCacheKey(..))
import Yesod.Auth.Message
import Auth.Dummy (apDummy)
import Auth.LDAP
import Auth.OAuth2
import Auth.PWHash (apHash)
import Auth.Dummy (apDummy)
import qualified Data.CaseInsensitive as CI
import qualified Control.Monad.Catch as C (Handler(..))
import qualified Ldap.Client as Ldap
import qualified Data.ByteString as ByteString
import qualified Data.CaseInsensitive as CI
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.ByteString as ByteString
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.UUID as UUID
import Foundation.Authorization (AuthorizationCacheKey(..))
import Foundation.I18n
import Foundation.Type
import Foundation.Types
import Handler.Utils.LdapSystemFunctions
import Handler.Utils.Memcached
import Handler.Utils.Profile
import qualified Ldap.Client as Ldap
import Yesod.Auth.Message
authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
, YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
, YesodAuth UniWorX, UserId ~ AuthId UniWorX
, YesodAuth UniWorX, UserAuthId ~ AuthId UniWorX
)
=> Creds UniWorX -> m (AuthenticationResult UniWorX)
=> Creds UniWorX
-> m (AuthenticationResult UniWorX)
authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
$logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
now <- liftIO getCurrentTime
userAuthConf <- getsYesod $ view _appUserAuthConf
let
uAuth = UniqueAuthentication $ CI.mk credsIdent
uAuth = UniqueExternalAuth $ CI.mk credsIdent
upsertMode = creds ^? _upsertUserMode
isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
@ -68,46 +73,47 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
= return res
excHandlers =
[ C.Handler $ \case
CampusUserNoResult -> do
$logWarnS "Auth" $ "User lookup failed after successful login for " <> credsIdent
[ C.Handler $ \(ldapExc :: LdapUserException) -> case ldapExc of
LdapUserNoResult -> do
$logWarnS "Auth" $ "LDAP user lookup failed after successful login for " <> credsIdent
excRecovery . UserError $ IdentifierNotFound credsIdent
CampusUserAmbiguous -> do
$logWarnS "Auth" $ "Multiple auth results for " <> credsIdent
LdapUserAmbiguous -> do
$logWarnS "Auth" $ "Multiple LDAP auth results for " <> credsIdent
excRecovery . UserError $ IdentifierNotFound credsIdent
err -> do
$logErrorS "Auth" $ tshow err
mr <- getMessageRender
excRecovery . ServerError $ mr MsgInternalLdapError
, C.Handler $ \(cExc :: CampusUserConversionException) -> do
excRecovery . ServerError $ mr MsgInternalLoginError
-- TODO: handle azure exceptions or generalize LdapUserException
, C.Handler $ \(cExc :: UserConversionException) -> do
$logErrorS "Auth" $ tshow cExc
mr <- getMessageRender
excRecovery . ServerError $ mr cExc
]
-- | Authenticate already existing ExternalUser entries only
acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
acceptExisting = do
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
case res of
Authenticated uid
-> associateUserSchoolsByTerms uid
Authenticated euid
-> associateUserSchoolsByTerms euid
_other
-> return ()
case res of
Authenticated uid
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
| not isDummy -> res <$ update euid [ ExternalUserLastAuth =. Just now ]
_other -> return res
$logDebugS "auth" $ tshow Creds{..}
$logDebugS "Auth" $ tshow Creds{..}
userSourceConf <- getsYesod $ view _appUserSourceConf
flip catches excHandlers $ case userSourceConf of
UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf)
flip catches excHandlers $ case userAuthConf of
UserAuthConfSingleSource (AuthSourceConfAzureAdV2 azureConf)
| Just upsertMode' <- upsertMode -> do
azureData <- azureUser azureConf Creds{..}
$logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData
Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData
UserSourceConfSingleSource (UserSourceLdap _)
UserAuthConfSingleSource (AuthSourceConfLdap _)
| Just upsertMode' <- upsertMode -> do
ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
ldapData <- ldapUser ldapPool Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..}
@ -117,16 +123,15 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
-> acceptExisting
data CampusUserConversionException
= CampusUserInvalidIdent
| CampusUserInvalidEmail
| CampusUserInvalidDisplayName
| CampusUserInvalidGivenName
| CampusUserInvalidSurname
| CampusUserInvalidTitle
-- | CampusUserInvalidMatriculation
| CampusUserInvalidFeaturesOfStudy Text
| CampusUserInvalidAssociatedSchools Text
data UserConversionException
= UserInvalidIdent
| UserInvalidEmail
| UserInvalidDisplayName
| UserInvalidGivenName
| UserInvalidSurname
| UserInvalidTitle
| UserInvalidFeaturesOfStudy Text
| UserInvalidAssociatedSchools Text
deriving (Eq, Ord, Read, Show, Generic)
deriving anyclass (Exception)
@ -138,17 +143,17 @@ _upsertUserMode mMode cs@Creds{..}
| credsPlugin == apLdap = setMode <$> mMode UpsertUserLoginLdap
| otherwise = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
where
setMode UpsertUserLoginAzure
setMode UpsertUserLoginAzure{} -- TODO: stuff upsertUserSource into credsExtra?
= cs{ credsPlugin = apAzure }
setMode UpsertUserLoginLdap
setMode UpsertUserLoginLdap{} -- TODO: stuff upsertUserSource into credsExtra?
= cs{ credsPlugin = apLdap }
setMode (UpsertUserLoginDummy ident)
setMode UpsertUserLoginDummy{..}
= cs{ credsPlugin = apDummy
, credsIdent = CI.original ident
, credsIdent = CI.original upsertUserIdent
}
setMode (UpsertUserLoginOther ident)
= cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap)
, credsIdent = CI.original ident
setMode UpsertUserLoginOther{..}
= cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure])
, credsIdent = CI.original upsertUserIdent
}
setMode _ = cs
@ -165,27 +170,29 @@ ldapLookupAndUpsert :: forall m.
-> SqlPersistT m (Entity User)
ldapLookupAndUpsert ident =
getsYesod (view _appLdapPool) >>= \case
Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
Just ldapPool ->
ldapUser'' ldapPool ident >>= \case
Nothing -> throwM CampusUserNoResult
Nothing -> throwM LdapUserNoResult
Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse
-- | Upsert User DB according to given LDAP data (does not query LDAP itself)
upsertLdapUser :: forall m.
( MonadHandler m, HandlerSite m ~ UniWorX
, MonadCatch m
)
=> UpsertUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
upsertLdapUser upsertMode ldapData = do
-- | Upsert ExternalUser DB according to given external source data (does not query source itself)
upsertUser :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
)
=> UpsertUserMode
-> SqlPersistT m (Entity ExternalAuth)
upsertUser upsertMode = do
now <- liftIO getCurrentTime
userDefaultConf <- getsYesod $ view _appUserDefaults
(newUser,userUpdate) <- decodeLdapUser now userDefaultConf upsertMode ldapData
--TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
oldUsers <- selectKeysList [ ExternalUserIdent ==. externalUserIdent newUser ] []
user@(Entity userId userRec) <- case oldUsers of
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
@ -220,55 +227,56 @@ upsertLdapUser upsertMode ldapData = do
return user
-- | Upsert User DB according to given Azure data (does not query Azure itself)
-- TODO: maybe merge with upsertLdapUser
upsertAzureUser :: forall m.
( MonadHandler m, HandlerSite m ~ UniWorX
, MonadCatch m
)
=> UpsertUserMode -> [(Text, [ByteString])] -> SqlPersistT m (Entity User)
upsertAzureUser upsertMode azureData = do
now <- liftIO getCurrentTime
userDefaultConf <- getsYesod $ view _appUserDefaults
(newUser,userUpdate) <- decodeAzureUser now userDefaultConf upsertMode azureData
--TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] []
user@(Entity userId userRec) <- case oldUsers of
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
_other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
unless (validDisplayName (newUser ^. _userTitle)
(newUser ^. _userFirstName)
(newUser ^. _userSurname)
(userRec ^. _userDisplayName)) $
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
when (validEmail' (userRec ^. _userEmail)) $ do
let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ]
++ [ UserAuthentication =. AuthAzure | is _AuthNoLogin (userRec ^. _userAuthentication) ]
unless (null emUps) $ update userId emUps
-- Attempt to update ident, too:
unless (validEmail' (userRec ^. _userIdent)) $
void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
let
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
userSystemFunctions' = do
(_k, v) <- azureData
-- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way?
v' <- v
Right str <- return $ Text.decodeUtf8' v'
assertM' (not . Text.null) $ Text.strip str
iforM_ userSystemFunctions $ \func preset -> do
memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
if | preset -> void $ upsert (UserSystemFunction userId func False False) []
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
return user
-- upsertAzureUser :: forall m.
-- ( MonadHandler m, HandlerSite m ~ UniWorX
-- , MonadCatch m
-- )
-- => UpsertUserMode
-- -> [(Text, [ByteString])]
-- -> SqlPersistT m (Entity User)
-- upsertAzureUser upsertMode azureData = do
-- now <- liftIO getCurrentTime
-- userDefaultConf <- getsYesod $ view _appUserDefaults
--
-- (newUser,userUpdate) <- decodeAzureUser now userDefaultConf upsertMode azureData
-- --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
--
-- oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] []
--
-- user@(Entity userId userRec) <- case oldUsers of
-- Just [oldUserId] -> updateGetEntity oldUserId userUpdate
-- _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
-- unless (validDisplayName (newUser ^. _userTitle)
-- (newUser ^. _userFirstName)
-- (newUser ^. _userSurname)
-- (userRec ^. _userDisplayName)) $
-- update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
-- when (validEmail' (userRec ^. _userEmail)) $ do
-- let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ]
-- ++ [ UserAuthentication =. AuthAzure | is _AuthNoLogin (userRec ^. _userAuthentication) ]
-- unless (null emUps) $ update userId emUps
-- -- Attempt to update ident, too:
-- unless (validEmail' (userRec ^. _userIdent)) $
-- void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
--
-- let
-- userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
-- userSystemFunctions' = do
-- (_k, v) <- azureData
-- -- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way?
-- v' <- v
-- Right str <- return $ Text.decodeUtf8' v'
-- assertM' (not . Text.null) $ Text.strip str
--
-- iforM_ userSystemFunctions $ \func preset -> do
-- memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
-- if | preset -> void $ upsert (UserSystemFunction userId func False False) []
-- | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
--
-- return user
decodeLdapUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
=> Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
=> Maybe UserIdent -> Ldap.AttrList [] -> m (Either UserConversionException (User, [Update User]))
decodeLdapUserTest mbIdent ldapData = do
now <- liftIO getCurrentTime
userDefaultConf <- getsYesod $ view _appUserDefaults
@ -276,107 +284,46 @@ decodeLdapUserTest mbIdent ldapData = do
try $ decodeLdapUser now userDefaultConf mode ldapData
decodeAzureUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
=> Maybe UserIdent -> [(Text, [ByteString])] -> m (Either CampusUserConversionException (User, [Update User]))
=> Maybe UserIdent -> [(Text, [ByteString])] -> m (Either UserConversionException (User, [Update User]))
decodeAzureUserTest mbIdent azureData = do
now <- liftIO getCurrentTime
userDefaultConf <- getsYesod $ view _appUserDefaults
let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent
try $ decodeAzureUser now userDefaultConf mode azureData
decodeLdapUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_)
decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
let
userTelephone = decodeLdap ldapUserTelephone
userMobile = decodeLdap ldapUserMobile
userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
userAuthentication
| is _UpsertUserLoginOther upsertMode
= AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
| otherwise = AuthLDAP
userLastAuthentication = guardOn isLogin now
isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode
userTitle = decodeLdap ldapUserTitle -- CampusUserInvalidTitle
userFirstName = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
userSurname = decodeLdap' ldapUserSurname -- CampusUserInvalidSurname
userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName
--userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
userIdent <- if
| [bs] <- ldapMap !!! ldapUserPrincipalName
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
, hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
-> return userIdent'
| Just userIdent' <- upsertMode ^? _upsertUserIdent
-> return userIdent'
| otherwise
-> throwM CampusUserInvalidIdent
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)
-> 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
userLdapPrimaryKey <- if
decodeLdapUser :: ( MonadThrow m
)
=> UTCTime -- ^ Now
-> UpsertUserMode
-> Ldap.AttrList [] -- ^ Raw LDAP data
-> m (ExternalAuth,_) -- ^ Data for new ExternalUser entry and updating existing ExternalUser entry
decodeLdapUser now upsertMode ldapData = do
externalAuthIdent <- if
| [bs] <- ldapMap !!! ldapPrimaryKey
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
, Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
-> return $ Just userLdapPrimaryKey'''
, Right ldapPrimaryKey' <- Text.decodeUtf8' bs
, Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
-> return ldapPrimaryKey''
| otherwise
-> return Nothing
-> throwM ExternalUserInvalidIdent
let externalAuthData = encode ldapData
externalAuthLastAuth <- if
| is _UpsertUserSync upsertMode || is _UpsertUserGuessUser upsertMode
-> Nothing
| otherwise
-> Just now
let
newUser = User
{ userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = userDefaultTheme
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userShowSex = userDefaultShowSex
, userSex = Nothing
, userBirthday = Nothing
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
, userNotificationSettings = def
, userLanguages = Nothing
, userCsvOptions = def
, userTokensIssuedAfter = Nothing
, userCreated = now
, userLastLdapSynchronisation = Just now
, userAzurePrimaryKey = Nothing
, userLastAzureSynchronisation = Nothing
, userDisplayName = userDisplayName
, userDisplayEmail = userEmail
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
, userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
, userPostLastUpdate = Nothing
, userPinPassword = Nothing -- must be derived via AVS
, userPrefersPostal = userDefaultPrefersPostal
newUser = ExternalAuth
{ externalAuthSource = ldapSourceIdent
, externalAuthLastSync = now
, ..
}
userUpdate =
[ UserLastAuthentication =. Just now | isLogin ] ++
[ UserEmail =. userEmail | validEmail' userEmail ] ++
[
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName
UserFirstName =. userFirstName
, UserSurname =. userSurname
, UserLastLdapSynchronisation =. Just now
, UserLdapPrimaryKey =. userLdapPrimaryKey
, UserMobile =. userMobile
, UserTelephone =. userTelephone
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
, UserCompanyDepartment =. userCompanyDepartment
userUpdate =
[ ExternalAuthIdent =. externalAuthIdent
, ExternalAuthData =. externalAuthData
, ExternalAuthLastSync =. now
]
return (newUser, userUpdate)
@ -414,6 +361,133 @@ decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
-- | otherwise = throwM err
-- where
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-- decodeLdapUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_)
-- decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
-- let
-- userTelephone = decodeLdap ldapUserTelephone
-- userMobile = decodeLdap ldapUserMobile
-- userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
-- userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
--
-- userAuthentication
-- | is _UpsertUserLoginOther upsertMode
-- = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
-- | otherwise = AuthLDAP
-- userLastAuthentication = guardOn isLogin now
-- isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode
--
-- userTitle = decodeLdap ldapUserTitle -- CampusUserInvalidTitle
-- userFirstName = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
-- userSurname = decodeLdap' ldapUserSurname -- CampusUserInvalidSurname
-- userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName
--
-- --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-- -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
--
-- userIdent <- if
-- | [bs] <- ldapMap !!! ldapUserPrincipalName
-- , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
-- , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
-- -> return userIdent'
-- | Just userIdent' <- upsertMode ^? _upsertUserIdent
-- -> return userIdent'
-- | otherwise
-- -> throwM CampusUserInvalidIdent
--
-- 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)
-- -> 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
--
-- -- TODO: ExternalUser
-- userLdapPrimaryKey <- if
-- | [bs] <- ldapMap !!! ldapPrimaryKey
-- , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
-- , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
-- -> return $ Just userLdapPrimaryKey'''
-- | otherwise
-- -> return Nothing
--
-- let
-- newUser = User
-- { userMaxFavourites = userDefaultMaxFavourites
-- , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
-- , userTheme = userDefaultTheme
-- , userDateTimeFormat = userDefaultDateTimeFormat
-- , userDateFormat = userDefaultDateFormat
-- , userTimeFormat = userDefaultTimeFormat
-- , userDownloadFiles = userDefaultDownloadFiles
-- , userWarningDays = userDefaultWarningDays
-- , userShowSex = userDefaultShowSex
-- , userSex = Nothing
-- , userBirthday = Nothing
-- , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
-- , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
-- , userNotificationSettings = def
-- , userLanguages = Nothing
-- , userCsvOptions = def
-- , userTokensIssuedAfter = Nothing
-- , userCreated = now
-- , userDisplayName = userDisplayName
-- , userDisplayEmail = userEmail
-- , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-- , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-- , userPostLastUpdate = Nothing
-- , userPinPassword = Nothing -- must be derived via AVS
-- , userPrefersPostal = userDefaultPrefersPostal
-- , ..
-- }
-- userUpdate =
-- [ UserLastAuthentication =. Just now | isLogin ] ++
-- [ UserEmail =. userEmail | validEmail' userEmail ] ++
-- [
-- -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName
-- UserFirstName =. userFirstName
-- , UserSurname =. userSurname
-- , UserMobile =. userMobile
-- , UserTelephone =. userTelephone
-- , UserCompanyPersonalNumber =. userCompanyPersonalNumber
-- , UserCompanyDepartment =. userCompanyDepartment
-- ]
-- return (newUser, userUpdate)
--
-- where
-- ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
-- ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
--
-- -- just returns Nothing on error, pure
-- decodeLdap :: Ldap.Attr -> Maybe Text
-- decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
--
-- decodeLdap' :: Ldap.Attr -> Text
-- decodeLdap' = fromMaybe "" . decodeLdap
-- -- accept the first successful decoding or empty; only throw an error if all decodings fail
-- -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
-- -- decodeLdap' attr err
-- -- | [] <- vs = return Nothing
-- -- | (h:_) <- rights vs = return $ Just h
-- -- | otherwise = throwM err
-- -- where
-- -- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
--
-- -- only accepts the first successful decoding, ignoring all others, but failing if there is none
-- -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-- decodeLdap1 attr err
-- | (h:_) <- rights vs = return h
-- | otherwise = throwM err
-- where
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
--
-- -- accept and merge one or more successful decodings, ignoring all others
-- -- decodeLdapN attr err
-- -- | t@(_:_) <- rights vs
-- -- = return $ Text.unwords t
-- -- | otherwise = throwM err
-- -- where
-- -- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
decodeAzureUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_)
decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
@ -433,7 +507,7 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
userTitle = Nothing -- TODO decodeAzure ldapUserTitle -- CampusUserInvalidTitle
userFirstName = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName
userSurname = decodeAzure' azureUserSurname -- CampusUserInvalidSurname
userDisplayName <- decodeAzure1 azureUserDisplayName CampusUserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName
userDisplayName <- decodeAzure1 azureUserDisplayName UserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName
--userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
@ -446,14 +520,14 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
| Just userIdent' <- upsertMode ^? _upsertUserIdent
-> return userIdent'
| otherwise
-> throwM CampusUserInvalidIdent
-> throwM UserInvalidIdent
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 azureMap [azureUserMail])
-> return $ CI.mk userEmail
-- -> return $ CI.mk userEmail
| otherwise
-> throwM CampusUserInvalidEmail
-> throwM UserInvalidEmail
-- TODO: use fromASCIIBytes / fromByteString?
userAzurePrimaryKey <- if
@ -485,9 +559,6 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
, userCsvOptions = def
, userTokensIssuedAfter = Nothing
, userCreated = now
, userLastAzureSynchronisation = Just now
, userLdapPrimaryKey = Nothing
, userLastLdapSynchronisation = Nothing
, userDisplayName = userDisplayName
, userDisplayEmail = userEmail
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
@ -504,8 +575,6 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
UserFirstName =. userFirstName
, UserSurname =. userSurname
, UserLastAzureSynchronisation =. Just now
, UserAzurePrimaryKey =. userAzurePrimaryKey
, UserMobile =. userMobile
, UserTelephone =. userTelephone
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
@ -582,4 +651,4 @@ updateUserLanguage Nothing = runMaybeT $ do
setRegisteredCookie CookieLang lang
return lang
embedRenderMessage ''UniWorX ''CampusUserConversionException id
embedRenderMessage ''UniWorX ''UserConversionException id