chore(foundation): loosen tight ldap<>failover coupling, move campusUser to ldapUser
This commit is contained in:
parent
2e005a90f2
commit
12bb8b7145
@ -1,13 +1,12 @@
|
||||
-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.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>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Foundation.Yesod.Auth
|
||||
( authenticate
|
||||
, oAuthenticate
|
||||
, ldapLookupAndUpsert
|
||||
, upsertCampusUser
|
||||
, decodeUserTest
|
||||
-- , ldapLookupAndUpsert
|
||||
, upsertLdapUser, upsertAzureUser
|
||||
, decodeLdapUserTest, decodeAzureUserTest
|
||||
, CampusUserConversionException(..)
|
||||
, campusUserFailoverMode, updateUserLanguage
|
||||
) where
|
||||
@ -37,19 +36,8 @@ 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.Conduit.Combinators as C
|
||||
|
||||
-- import qualified Data.List as List ((\\))
|
||||
|
||||
-- import qualified Data.UUID as UUID
|
||||
-- import Data.ByteArray (convert)
|
||||
-- import Crypto.Hash (SHAKE128)
|
||||
-- import qualified Data.Binary as Binary
|
||||
|
||||
-- import qualified Database.Esqueleto.Legacy as E
|
||||
-- import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
-- import Crypto.Hash.Conduit (sinkHash)
|
||||
import qualified Data.List.PointedList as PointedList
|
||||
import qualified Data.UUID as UUID
|
||||
|
||||
|
||||
authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
@ -58,15 +46,16 @@ authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Creds UniWorX -> m (AuthenticationResult UniWorX)
|
||||
authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
|
||||
$logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m"
|
||||
$logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let
|
||||
uAuth = UniqueAuthentication $ CI.mk credsIdent
|
||||
upsertMode = creds ^? _upsertCampusUserMode
|
||||
upsertMode = creds ^? _upsertUserMode
|
||||
|
||||
isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode
|
||||
isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode
|
||||
isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
|
||||
isOther = is (_Just . _UpsertUserLoginOther) upsertMode
|
||||
|
||||
excRecovery res
|
||||
| isDummy || isOther
|
||||
@ -82,17 +71,17 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
|
||||
excHandlers =
|
||||
[ C.Handler $ \case
|
||||
CampusUserNoResult -> do
|
||||
$logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
|
||||
$logWarnS "Auth" $ "User lookup failed after successful login for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
CampusUserAmbiguous -> do
|
||||
$logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
|
||||
$logWarnS "Auth" $ "Multiple auth results for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
err -> do
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
$logErrorS "Auth" $ tshow err
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr MsgInternalLdapError
|
||||
, C.Handler $ \(cExc :: CampusUserConversionException) -> do
|
||||
$logErrorS "LDAP" $ tshow cExc
|
||||
$logErrorS "Auth" $ tshow cExc
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr cExc
|
||||
]
|
||||
@ -110,92 +99,27 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
|
||||
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
|
||||
_other -> return res
|
||||
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
ldapPool' <- getsYesod $ view _appLdapPool
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
|
||||
flip catches excHandlers $ case ldapPool' of
|
||||
Just ldapPool
|
||||
userdbConf <- getsYesod $ view _appUserDbConf
|
||||
flip catches excHandlers $ case userdbConf of
|
||||
UserDbSingleSource (UserDbAzureAdV2 azureConf)
|
||||
| Just upsertMode' <- upsertMode -> do
|
||||
ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
|
||||
azureData <- oauth2User azureConf Creds{..}
|
||||
$logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData
|
||||
Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData
|
||||
UserDbSingleSource (UserDbLdap _)
|
||||
| Just upsertMode' <- upsertMode -> do
|
||||
-- TODO WIP
|
||||
ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
|
||||
ldapConf <- mkFailover $ PointedList.singleton ldapPool
|
||||
ldapData <- ldapUser ldapConf FailoverNone Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..}
|
||||
$logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
Authenticated . entityKey <$> upsertLdapUser upsertMode' ldapData
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
|
||||
-- | Authentication via AzureADv2 / OAuth 2
|
||||
oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, YesodAuth UniWorX, UserId ~ AuthId UniWorX
|
||||
)
|
||||
=> Creds UniWorX -> m (AuthenticationResult UniWorX)
|
||||
oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
|
||||
$logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m"
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let
|
||||
uAuth = UniqueAuthentication $ CI.mk credsIdent
|
||||
upsertMode = creds ^? _upsertAzureUserMode
|
||||
|
||||
isDummy = is (_Just . _UpsertAzureUserLoginDummy) upsertMode -- mock server
|
||||
isOther = is (_Just . _UpsertAzureUserLoginOther) upsertMode
|
||||
|
||||
excRecovery res
|
||||
| isDummy || isOther
|
||||
= do
|
||||
case res of
|
||||
UserError err -> addMessageI Error err
|
||||
ServerError err -> addMessage Error $ toHtml err
|
||||
_other -> return ()
|
||||
acceptExisting
|
||||
| otherwise
|
||||
= return res
|
||||
|
||||
excHandlers =
|
||||
[ C.Handler $ \case
|
||||
AzureUserNoResult -> do
|
||||
$logWarnS "OAuth" $ "User lookup failed after successful login for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
AzureUserAmbiguous -> do
|
||||
$logWarnS "OAuth" $ "Multiple OAuth results for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
err -> do
|
||||
$logErrorS "OAuth" $ tshow err
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr MsgInternalLdapError -- TODO where does this come from?
|
||||
, C.Handler $ \(cExc :: CampusUserConversionException) -> do -- TODO new exception type or not?
|
||||
$logErrorS "OAuth" $ tshow cExc
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr cExc
|
||||
]
|
||||
|
||||
acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
|
||||
acceptExisting = do
|
||||
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||
case res of
|
||||
Authenticated uid
|
||||
-> associateUserSchoolsByTerms uid
|
||||
_other
|
||||
-> return ()
|
||||
case res of
|
||||
Authenticated uid
|
||||
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
|
||||
_other -> return res
|
||||
|
||||
$logDebugS "oauth" $ tshow creds
|
||||
-- TODO If user not in DB then put
|
||||
pool <- getsYesod $ view _appLdapPool
|
||||
flip catches excHandlers $ case pool of
|
||||
Just ldapPool
|
||||
| Just upsertMode' <- upsertMode -> do
|
||||
ldapData <- campusUser ldapPool campusUserFailoverMode creds
|
||||
$logDebugS "OAuth" $ "Successful LDAP lookup of Azure user: " <> tshow ldapData
|
||||
Authenticated . entityKey <$> upsertAzureUser upsertMode' ldapData
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
|
||||
|
||||
data CampusUserConversionException
|
||||
= CampusUserInvalidIdent
|
||||
| CampusUserInvalidEmail
|
||||
@ -209,19 +133,23 @@ data CampusUserConversionException
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
|
||||
_upsertCampusUserMode mMode cs@Creds{..}
|
||||
| credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent)
|
||||
| credsPlugin == apLdap = setMode <$> mMode UpsertCampusUserLoginLdap
|
||||
| otherwise = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent)
|
||||
|
||||
_upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode
|
||||
_upsertUserMode mMode cs@Creds{..}
|
||||
| credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent)
|
||||
| credsPlugin == apAzure = setMode <$> mMode UpsertUserLoginAzure
|
||||
| credsPlugin == apLdap = setMode <$> mMode UpsertUserLoginLdap
|
||||
| otherwise = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
|
||||
where
|
||||
setMode UpsertCampusUserLoginLdap
|
||||
setMode UpsertUserLoginAzure
|
||||
= cs{ credsPlugin = apAzure }
|
||||
setMode UpsertUserLoginLdap
|
||||
= cs{ credsPlugin = apLdap }
|
||||
setMode (UpsertCampusUserLoginDummy ident)
|
||||
setMode (UpsertUserLoginDummy ident)
|
||||
= cs{ credsPlugin = apDummy
|
||||
, credsIdent = CI.original ident
|
||||
}
|
||||
setMode (UpsertCampusUserLoginOther ident)
|
||||
setMode (UpsertUserLoginOther ident)
|
||||
= cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap)
|
||||
, credsIdent = CI.original ident
|
||||
}
|
||||
@ -230,73 +158,28 @@ _upsertCampusUserMode mMode cs@Creds{..}
|
||||
defaultOther = apHash
|
||||
|
||||
|
||||
_upsertAzureUserMode :: Traversal' (Creds UniWorX) UpsertAzureUserMode
|
||||
_upsertAzureUserMode mMode cs@Creds{..}
|
||||
| credsPlugin == mockPluginName = setMode <$> mMode (UpsertAzureUserLoginDummy $ CI.mk credsIdent)
|
||||
| credsPlugin == "azureadv2" = setMode <$> mMode UpsertAzureUserLoginOAuth
|
||||
| otherwise = setMode <$> mMode (UpsertAzureUserLoginOther $ CI.mk credsIdent)
|
||||
where
|
||||
setMode UpsertAzureUserLoginOAuth
|
||||
= cs{ credsPlugin = "azureadv2" }
|
||||
setMode (UpsertAzureUserLoginDummy ident)
|
||||
= cs{ credsPlugin = mockPluginName
|
||||
, credsIdent = CI.original ident
|
||||
}
|
||||
setMode (UpsertAzureUserLoginOther ident)
|
||||
= cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= mockPluginName && credsPlugin /= "azureadv2")
|
||||
, credsIdent = CI.original ident
|
||||
}
|
||||
setMode _ = cs
|
||||
-- TODO: rewrite
|
||||
-- ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
|
||||
-- ldapLookupAndUpsert ident =
|
||||
-- getsYesod (view _appLdapPool) >>= \case
|
||||
-- Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
|
||||
-- Just ldapPool ->
|
||||
-- campusUser'' ldapPool campusUserFailoverMode ident >>= \case
|
||||
-- Nothing -> throwM CampusUserNoResult
|
||||
-- Just ldapResponse -> upsertLdapUser UpsertCampusUserGuessUser ldapResponse
|
||||
|
||||
defaultOther = apHash
|
||||
|
||||
|
||||
|
||||
ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
|
||||
ldapLookupAndUpsert ident =
|
||||
getsYesod (view _appLdapPool) >>= \case
|
||||
Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
|
||||
Just ldapPool ->
|
||||
campusUser'' ldapPool campusUserFailoverMode ident >>= \case
|
||||
Nothing -> throwM CampusUserNoResult
|
||||
Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse
|
||||
|
||||
|
||||
upsertAzureUser :: forall m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
)
|
||||
=> UpsertAzureUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) -- TODO UpsertAzureUserMode is probably redundant
|
||||
upsertAzureUser upsertMode = upsertCampusUser (toCampus upsertMode)
|
||||
where
|
||||
toCampus :: UpsertAzureUserMode -> UpsertCampusUserMode
|
||||
toCampus UpsertAzureUserLoginOAuth = UpsertCampusUserLoginLdap
|
||||
toCampus (UpsertAzureUserLoginDummy u) = UpsertCampusUserLoginDummy u
|
||||
toCampus (UpsertAzureUserLoginOther u) = UpsertCampusUserLoginOther u
|
||||
toCampus (UpsertAzureUserOAuthSync u) = UpsertCampusUserLdapSync u
|
||||
toCampus UpsertAzureUserGuessUser = UpsertCampusUserGuessUser
|
||||
|
||||
|
||||
{- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP!
|
||||
upsertCampusUserByCn :: forall m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
)
|
||||
=> Text -> SqlPersistT m (Entity User)
|
||||
upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])]
|
||||
-}
|
||||
|
||||
-- | Upsert User DB according to given LDAP data (does not query LDAP itself)
|
||||
upsertCampusUser :: forall m.
|
||||
upsertLdapUser :: forall m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
)
|
||||
=> UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
|
||||
upsertCampusUser upsertMode ldapData = do
|
||||
=> UpsertUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
|
||||
upsertLdapUser upsertMode ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
userDefaultConf <- getsYesod $ view _appUserDefaults
|
||||
|
||||
(newUser,userUpdate) <- decodeUser 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?
|
||||
|
||||
oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
|
||||
@ -333,17 +216,72 @@ upsertCampusUser upsertMode ldapData = do
|
||||
|
||||
return user
|
||||
|
||||
decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
|
||||
-- | 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
|
||||
|
||||
decodeLdapUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
|
||||
=> Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
|
||||
decodeUserTest mbIdent ldapData = do
|
||||
decodeLdapUserTest mbIdent ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
userDefaultConf <- getsYesod $ view _appUserDefaults
|
||||
let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent
|
||||
try $ decodeUser now userDefaultConf mode ldapData
|
||||
let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent
|
||||
try $ decodeLdapUser now userDefaultConf mode ldapData
|
||||
|
||||
decodeAzureUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
|
||||
=> Maybe UserIdent -> [(Text, [ByteString])] -> m (Either CampusUserConversionException (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
|
||||
|
||||
decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
|
||||
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
decodeLdapUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_)
|
||||
decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
let
|
||||
userTelephone = decodeLdap ldapUserTelephone
|
||||
userMobile = decodeLdap ldapUserMobile
|
||||
@ -351,11 +289,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
|
||||
|
||||
userAuthentication
|
||||
| is _UpsertCampusUserLoginOther upsertMode
|
||||
| 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 (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
|
||||
isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode
|
||||
|
||||
userTitle = decodeLdap ldapUserTitle -- CampusUserInvalidTitle
|
||||
userFirstName = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
|
||||
@ -368,9 +306,9 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
userIdent <- if
|
||||
| [bs] <- ldapMap !!! ldapUserPrincipalName
|
||||
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
|
||||
, hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
|
||||
, hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
|
||||
-> return userIdent'
|
||||
| Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
|
||||
| Just userIdent' <- upsertMode ^? _upsertUserIdent
|
||||
-> return userIdent'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidIdent
|
||||
@ -412,6 +350,8 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
, 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
|
||||
@ -425,7 +365,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
[ UserLastAuthentication =. Just now | isLogin ] ++
|
||||
[ UserEmail =. userEmail | validEmail' userEmail ] ++
|
||||
[
|
||||
-- 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
|
||||
UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
@ -472,6 +412,123 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
-- where
|
||||
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
|
||||
|
||||
decodeAzureUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_)
|
||||
decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
|
||||
let
|
||||
userTelephone = decodeAzure azureUserTelephone
|
||||
userMobile = decodeAzure azureUserMobile
|
||||
userCompanyPersonalNumber = Nothing -- TODO decodeAzure azureUserFraportPersonalnummer
|
||||
userCompanyDepartment = Nothing --TODO decodeAzure ldapUserFraportAbteilung
|
||||
|
||||
userAuthentication
|
||||
| is _UpsertUserLoginOther upsertMode
|
||||
= AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
|
||||
| otherwise = AuthAzure
|
||||
userLastAuthentication = guardOn isLogin now
|
||||
isLogin = has (_UpsertUserLoginAzure <> _UpsertUserLoginOther . united) upsertMode
|
||||
|
||||
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 <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
|
||||
-- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
|
||||
|
||||
userIdent <- if
|
||||
| [bs] <- azureMap !!! azureUserPrincipalName
|
||||
, 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 azureMap [azureUserMail])
|
||||
-> return $ CI.mk userEmail
|
||||
-- -> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
|
||||
-- TODO: use fromASCIIBytes / fromByteString?
|
||||
userAzurePrimaryKey <- if
|
||||
| [bs] <- azureMap !!! azurePrimaryKey
|
||||
, Right userAzurePrimaryKey'' <- Text.decodeUtf8' bs
|
||||
, Just userAzurePrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userAzurePrimaryKey''
|
||||
, Just userAzurePrimaryKey'''' <- UUID.fromText userAzurePrimaryKey'''
|
||||
-> return $ Just userAzurePrimaryKey''''
|
||||
| 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 -- TODO: decode and parse preferredLanguages
|
||||
, 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
|
||||
, 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; see line 272
|
||||
UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserLastAzureSynchronisation =. Just now
|
||||
, UserAzurePrimaryKey =. userAzurePrimaryKey
|
||||
, UserMobile =. userMobile
|
||||
, UserTelephone =. userTelephone
|
||||
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
|
||||
, UserCompanyDepartment =. userCompanyDepartment
|
||||
]
|
||||
return (newUser, userUpdate)
|
||||
|
||||
where
|
||||
azureMap :: Map.Map Text [ByteString]
|
||||
azureMap = Map.fromListWith (++) $ azureData <&> second (filter (not . ByteString.null))
|
||||
|
||||
-- just returns Nothing on error, pure
|
||||
decodeAzure :: Text -> Maybe Text
|
||||
decodeAzure attr = listToMaybe . rights $ Text.decodeUtf8' <$> azureMap !!! attr
|
||||
|
||||
decodeAzure' :: Text -> Text
|
||||
decodeAzure' = fromMaybe "" . decodeAzure
|
||||
|
||||
-- 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
|
||||
decodeAzure1 attr err
|
||||
| (h:_) <- rights vs = return h
|
||||
| otherwise = throwM err
|
||||
where
|
||||
vs = Text.decodeUtf8' <$> (azureMap !!! attr)
|
||||
|
||||
|
||||
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
|
||||
associateUserSchoolsByTerms uid = do
|
||||
@ -486,6 +543,7 @@ associateUserSchoolsByTerms uid = do
|
||||
, userSchoolIsOptOut = False
|
||||
}
|
||||
|
||||
|
||||
updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, YesodAuth UniWorX
|
||||
, UserId ~ AuthId UniWorX
|
||||
|
||||
Reference in New Issue
Block a user