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 UserAuth
ident UserIdent -- Human-readable text uniquely identifying a user ident UserIdent -- Human-readable text uniquely identifying a user
lastLogin UTCTime -- When did the corresponding User last authenticate using this entry? 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 Primary ident
UniqueAuthentication ident UniqueAuthentication ident
deriving Show Eq Ord Generic deriving Show Eq Ord Generic
@ -44,7 +45,7 @@ ExternalAuth
ident UserIdent ident UserIdent
source AuthenticationSourceIdent -- Identifier of the external source in the config source AuthenticationSourceIdent -- Identifier of the external source in the config
data Value "default='{}'::jsonb" -- Raw user data from external source 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 UniqueExternalAuth ident source -- At most one entry of this user per source
deriving Show Eq Ord Generic 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 -- 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 :: HasCallStack => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
getDBRunner = UniWorX.getDBRunner' callStack getDBRunner = UniWorX.getDBRunner' callStack
instance YesodAuth UniWorX where instance YesodAuth UniWorX where
type AuthId UniWorX = UserId type AuthId UniWorX = UserAuthId
-- Where to send a user after successful login -- Where to send a user after successful login
loginDest _ = NewsR loginDest _ = NewsR
@ -172,6 +172,7 @@ instance YesodAuth UniWorX where
BearerToken{..} <- MaybeT . liftHandler $ runDBRead maybeBearerToken BearerToken{..} <- MaybeT . liftHandler $ runDBRead maybeBearerToken
hoistMaybe bearerImpersonate hoistMaybe bearerImpersonate
-- TODO: update?
instance YesodAuthPersist UniWorX where instance YesodAuthPersist UniWorX where
getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User) getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User)
getAuthEntity = liftHandler . runDBRead . get getAuthEntity = liftHandler . runDBRead . get

4
src/Foundation/Navigation.hs
View File

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

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

@ -5,52 +5,57 @@
module Foundation.Yesod.Auth module Foundation.Yesod.Auth
( authenticate ( authenticate
, ldapLookupAndUpsert , ldapLookupAndUpsert
, upsertLdapUser, upsertAzureUser , upsertUser
, decodeLdapUserTest, decodeAzureUserTest , decodeLdapUserTest, decodeAzureUserTest
, CampusUserConversionException(..) , UserConversionException(..)
, updateUserLanguage , updateUserLanguage
) where ) where
import Import.NoFoundation hiding (authenticate) import Import.NoFoundation hiding (authenticate)
import Foundation.Type import Auth.Dummy (apDummy)
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.LDAP import Auth.LDAP
import Auth.OAuth2 import Auth.OAuth2
import Auth.PWHash (apHash) import Auth.PWHash (apHash)
import Auth.Dummy (apDummy)
import qualified Data.CaseInsensitive as CI
import qualified Control.Monad.Catch as C (Handler(..)) 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 as Text
import qualified Data.Text.Encoding 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 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 authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
, YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend 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 authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
$logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
userAuthConf <- getsYesod $ view _appUserAuthConf
let let
uAuth = UniqueAuthentication $ CI.mk credsIdent uAuth = UniqueExternalAuth $ CI.mk credsIdent
upsertMode = creds ^? _upsertUserMode upsertMode = creds ^? _upsertUserMode
isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
@ -68,46 +73,47 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
= return res = return res
excHandlers = excHandlers =
[ C.Handler $ \case [ C.Handler $ \(ldapExc :: LdapUserException) -> case ldapExc of
CampusUserNoResult -> do LdapUserNoResult -> do
$logWarnS "Auth" $ "User lookup failed after successful login for " <> credsIdent $logWarnS "Auth" $ "LDAP user lookup failed after successful login for " <> credsIdent
excRecovery . UserError $ IdentifierNotFound credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent
CampusUserAmbiguous -> do LdapUserAmbiguous -> do
$logWarnS "Auth" $ "Multiple auth results for " <> credsIdent $logWarnS "Auth" $ "Multiple LDAP auth results for " <> credsIdent
excRecovery . UserError $ IdentifierNotFound credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent
err -> do err -> do
$logErrorS "Auth" $ tshow err $logErrorS "Auth" $ tshow err
mr <- getMessageRender mr <- getMessageRender
excRecovery . ServerError $ mr MsgInternalLdapError excRecovery . ServerError $ mr MsgInternalLoginError
, C.Handler $ \(cExc :: CampusUserConversionException) -> do -- TODO: handle azure exceptions or generalize LdapUserException
, C.Handler $ \(cExc :: UserConversionException) -> do
$logErrorS "Auth" $ tshow cExc $logErrorS "Auth" $ tshow cExc
mr <- getMessageRender mr <- getMessageRender
excRecovery . ServerError $ mr cExc excRecovery . ServerError $ mr cExc
] ]
-- | Authenticate already existing ExternalUser entries only
acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX) acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
acceptExisting = do acceptExisting = do
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
case res of case res of
Authenticated uid Authenticated euid
-> associateUserSchoolsByTerms uid -> associateUserSchoolsByTerms euid
_other _other
-> return () -> return ()
case res of case res of
Authenticated uid Authenticated uid
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] | not isDummy -> res <$ update euid [ ExternalUserLastAuth =. Just now ]
_other -> return res _other -> return res
$logDebugS "auth" $ tshow Creds{..} $logDebugS "Auth" $ tshow Creds{..}
userSourceConf <- getsYesod $ view _appUserSourceConf flip catches excHandlers $ case userAuthConf of
flip catches excHandlers $ case userSourceConf of UserAuthConfSingleSource (AuthSourceConfAzureAdV2 azureConf)
UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf)
| Just upsertMode' <- upsertMode -> do | Just upsertMode' <- upsertMode -> do
azureData <- azureUser azureConf Creds{..} azureData <- azureUser azureConf Creds{..}
$logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData
Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData
UserSourceConfSingleSource (UserSourceLdap _) UserAuthConfSingleSource (AuthSourceConfLdap _)
| Just upsertMode' <- upsertMode -> do | Just upsertMode' <- upsertMode -> do
ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
ldapData <- ldapUser ldapPool Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..} ldapData <- ldapUser ldapPool Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..}
@ -117,16 +123,15 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
-> acceptExisting -> acceptExisting
data CampusUserConversionException data UserConversionException
= CampusUserInvalidIdent = UserInvalidIdent
| CampusUserInvalidEmail | UserInvalidEmail
| CampusUserInvalidDisplayName | UserInvalidDisplayName
| CampusUserInvalidGivenName | UserInvalidGivenName
| CampusUserInvalidSurname | UserInvalidSurname
| CampusUserInvalidTitle | UserInvalidTitle
-- | CampusUserInvalidMatriculation | UserInvalidFeaturesOfStudy Text
| CampusUserInvalidFeaturesOfStudy Text | UserInvalidAssociatedSchools Text
| CampusUserInvalidAssociatedSchools Text
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
deriving anyclass (Exception) deriving anyclass (Exception)
@ -138,17 +143,17 @@ _upsertUserMode mMode cs@Creds{..}
| credsPlugin == apLdap = setMode <$> mMode UpsertUserLoginLdap | credsPlugin == apLdap = setMode <$> mMode UpsertUserLoginLdap
| otherwise = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent) | otherwise = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
where where
setMode UpsertUserLoginAzure setMode UpsertUserLoginAzure{} -- TODO: stuff upsertUserSource into credsExtra?
= cs{ credsPlugin = apAzure } = cs{ credsPlugin = apAzure }
setMode UpsertUserLoginLdap setMode UpsertUserLoginLdap{} -- TODO: stuff upsertUserSource into credsExtra?
= cs{ credsPlugin = apLdap } = cs{ credsPlugin = apLdap }
setMode (UpsertUserLoginDummy ident) setMode UpsertUserLoginDummy{..}
= cs{ credsPlugin = apDummy = cs{ credsPlugin = apDummy
, credsIdent = CI.original ident , credsIdent = CI.original upsertUserIdent
} }
setMode (UpsertUserLoginOther ident) setMode UpsertUserLoginOther{..}
= cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap) = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure])
, credsIdent = CI.original ident , credsIdent = CI.original upsertUserIdent
} }
setMode _ = cs setMode _ = cs
@ -165,27 +170,29 @@ ldapLookupAndUpsert :: forall m.
-> SqlPersistT m (Entity User) -> SqlPersistT m (Entity User)
ldapLookupAndUpsert ident = ldapLookupAndUpsert ident =
getsYesod (view _appLdapPool) >>= \case getsYesod (view _appLdapPool) >>= \case
Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
Just ldapPool -> Just ldapPool ->
ldapUser'' ldapPool ident >>= \case ldapUser'' ldapPool ident >>= \case
Nothing -> throwM CampusUserNoResult Nothing -> throwM LdapUserNoResult
Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse
-- | Upsert User DB according to given LDAP data (does not query LDAP itself) -- | Upsert ExternalUser DB according to given external source data (does not query source itself)
upsertLdapUser :: forall m. upsertUser :: forall m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m
, MonadCatch m , HandlerSite m ~ UniWorX
) , MonadCatch m
=> UpsertUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) )
upsertLdapUser upsertMode ldapData = do => UpsertUserMode
-> SqlPersistT m (Entity ExternalAuth)
upsertUser upsertMode = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
userDefaultConf <- getsYesod $ view _appUserDefaults userDefaultConf <- getsYesod $ view _appUserDefaults
(newUser,userUpdate) <- decodeLdapUser now userDefaultConf upsertMode ldapData (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? --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 user@(Entity userId userRec) <- case oldUsers of
Just [oldUserId] -> updateGetEntity oldUserId userUpdate Just [oldUserId] -> updateGetEntity oldUserId userUpdate
@ -220,55 +227,56 @@ upsertLdapUser upsertMode ldapData = do
return user return user
-- | Upsert User DB according to given Azure data (does not query Azure itself) -- | Upsert User DB according to given Azure data (does not query Azure itself)
-- TODO: maybe merge with upsertLdapUser -- upsertAzureUser :: forall m.
upsertAzureUser :: forall m. -- ( MonadHandler m, HandlerSite m ~ UniWorX
( MonadHandler m, HandlerSite m ~ UniWorX -- , MonadCatch m
, MonadCatch m -- )
) -- => UpsertUserMode
=> UpsertUserMode -> [(Text, [ByteString])] -> SqlPersistT m (Entity User) -- -> [(Text, [ByteString])]
upsertAzureUser upsertMode azureData = do -- -> SqlPersistT m (Entity User)
now <- liftIO getCurrentTime -- upsertAzureUser upsertMode azureData = do
userDefaultConf <- getsYesod $ view _appUserDefaults -- 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? -- (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 ] [] --
-- oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] []
user@(Entity userId userRec) <- case oldUsers of --
Just [oldUserId] -> updateGetEntity oldUserId userUpdate -- user@(Entity userId userRec) <- case oldUsers of
_other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate -- Just [oldUserId] -> updateGetEntity oldUserId userUpdate
unless (validDisplayName (newUser ^. _userTitle) -- _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
(newUser ^. _userFirstName) -- unless (validDisplayName (newUser ^. _userTitle)
(newUser ^. _userSurname) -- (newUser ^. _userFirstName)
(userRec ^. _userDisplayName)) $ -- (newUser ^. _userSurname)
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] -- (userRec ^. _userDisplayName)) $
when (validEmail' (userRec ^. _userEmail)) $ do -- update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ] -- when (validEmail' (userRec ^. _userEmail)) $ do
++ [ UserAuthentication =. AuthAzure | is _AuthNoLogin (userRec ^. _userAuthentication) ] -- let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ]
unless (null emUps) $ update userId emUps -- ++ [ UserAuthentication =. AuthAzure | is _AuthNoLogin (userRec ^. _userAuthentication) ]
-- Attempt to update ident, too: -- unless (null emUps) $ update userId emUps
unless (validEmail' (userRec ^. _userIdent)) $ -- -- Attempt to update ident, too:
void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ())) -- unless (validEmail' (userRec ^. _userIdent)) $
-- void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
let --
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' -- let
userSystemFunctions' = do -- userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
(_k, v) <- azureData -- userSystemFunctions' = do
-- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way? -- (_k, v) <- azureData
v' <- v -- -- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way?
Right str <- return $ Text.decodeUtf8' v' -- v' <- v
assertM' (not . Text.null) $ Text.strip str -- Right str <- return $ Text.decodeUtf8' v'
-- assertM' (not . Text.null) $ Text.strip str
iforM_ userSystemFunctions $ \func preset -> do --
memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId) -- iforM_ userSystemFunctions $ \func preset -> do
if | preset -> void $ upsert (UserSystemFunction userId func False False) [] -- memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] -- if | preset -> void $ upsert (UserSystemFunction userId func False False) []
-- | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
return user --
-- return user
decodeLdapUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) 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 decodeLdapUserTest mbIdent ldapData = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
userDefaultConf <- getsYesod $ view _appUserDefaults userDefaultConf <- getsYesod $ view _appUserDefaults
@ -276,107 +284,46 @@ decodeLdapUserTest mbIdent ldapData = do
try $ decodeLdapUser now userDefaultConf mode ldapData try $ decodeLdapUser now userDefaultConf mode ldapData
decodeAzureUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) 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 decodeAzureUserTest mbIdent azureData = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
userDefaultConf <- getsYesod $ view _appUserDefaults userDefaultConf <- getsYesod $ view _appUserDefaults
let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent
try $ decodeAzureUser now userDefaultConf mode azureData try $ decodeAzureUser now userDefaultConf mode azureData
decodeLdapUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_) decodeLdapUser :: ( MonadThrow m
decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do )
let => UTCTime -- ^ Now
userTelephone = decodeLdap ldapUserTelephone -> UpsertUserMode
userMobile = decodeLdap ldapUserMobile -> Ldap.AttrList [] -- ^ Raw LDAP data
userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer -> m (ExternalAuth,_) -- ^ Data for new ExternalUser entry and updating existing ExternalUser entry
userCompanyDepartment = decodeLdap ldapUserFraportAbteilung decodeLdapUser now upsertMode ldapData = do
externalAuthIdent <- if
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
| [bs] <- ldapMap !!! ldapPrimaryKey | [bs] <- ldapMap !!! ldapPrimaryKey
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs , Right ldapPrimaryKey' <- Text.decodeUtf8' bs
, Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey'' , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
-> return $ Just userLdapPrimaryKey''' -> return ldapPrimaryKey''
| otherwise | otherwise
-> return Nothing -> throwM ExternalUserInvalidIdent
let externalAuthData = encode ldapData
externalAuthLastAuth <- if
| is _UpsertUserSync upsertMode || is _UpsertUserGuessUser upsertMode
-> Nothing
| otherwise
-> Just now
let let
newUser = User newUser = ExternalAuth
{ userMaxFavourites = userDefaultMaxFavourites { externalAuthSource = ldapSourceIdent
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms , externalAuthLastSync = now
, 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
, .. , ..
} }
userUpdate = userUpdate =
[ UserLastAuthentication =. Just now | isLogin ] ++ [ ExternalAuthIdent =. externalAuthIdent
[ UserEmail =. userEmail | validEmail' userEmail ] ++ , ExternalAuthData =. externalAuthData
[ , ExternalAuthLastSync =. now
-- 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
] ]
return (newUser, userUpdate) return (newUser, userUpdate)
@ -414,6 +361,133 @@ decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
-- | otherwise = throwM err -- | otherwise = throwM err
-- where -- where
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr) -- 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 :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_)
decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
@ -433,7 +507,7 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
userTitle = Nothing -- TODO decodeAzure ldapUserTitle -- CampusUserInvalidTitle userTitle = Nothing -- TODO decodeAzure ldapUserTitle -- CampusUserInvalidTitle
userFirstName = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName userFirstName = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName
userSurname = decodeAzure' azureUserSurname -- CampusUserInvalidSurname 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 >>= --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname) -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
@ -446,14 +520,14 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
| Just userIdent' <- upsertMode ^? _upsertUserIdent | Just userIdent' <- upsertMode ^? _upsertUserIdent
-> return userIdent' -> return userIdent'
| otherwise | 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 <- 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]) | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome azureMap [azureUserMail])
-> return $ CI.mk userEmail -> return $ CI.mk userEmail
-- -> return $ CI.mk userEmail -- -> return $ CI.mk userEmail
| otherwise | otherwise
-> throwM CampusUserInvalidEmail -> throwM UserInvalidEmail
-- TODO: use fromASCIIBytes / fromByteString? -- TODO: use fromASCIIBytes / fromByteString?
userAzurePrimaryKey <- if userAzurePrimaryKey <- if
@ -485,9 +559,6 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
, userCsvOptions = def , userCsvOptions = def
, userTokensIssuedAfter = Nothing , userTokensIssuedAfter = Nothing
, userCreated = now , userCreated = now
, userLastAzureSynchronisation = Just now
, userLdapPrimaryKey = Nothing
, userLastLdapSynchronisation = Nothing
, userDisplayName = userDisplayName , userDisplayName = userDisplayName
, userDisplayEmail = userEmail , userDisplayEmail = userEmail
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO , 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 -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
UserFirstName =. userFirstName UserFirstName =. userFirstName
, UserSurname =. userSurname , UserSurname =. userSurname
, UserLastAzureSynchronisation =. Just now
, UserAzurePrimaryKey =. userAzurePrimaryKey
, UserMobile =. userMobile , UserMobile =. userMobile
, UserTelephone =. userTelephone , UserTelephone =. userTelephone
, UserCompanyPersonalNumber =. userCompanyPersonalNumber , UserCompanyPersonalNumber =. userCompanyPersonalNumber
@ -582,4 +651,4 @@ updateUserLanguage Nothing = runMaybeT $ do
setRegisteredCookie CookieLang lang setRegisteredCookie CookieLang lang
return lang return lang
embedRenderMessage ''UniWorX ''CampusUserConversionException id embedRenderMessage ''UniWorX ''UserConversionException id