655 lines
30 KiB
Haskell
655 lines
30 KiB
Haskell
-- 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
|
|
, ldapLookupAndUpsert
|
|
, upsertUser
|
|
, decodeLdapUserTest, decodeAzureUserTest
|
|
, UserConversionException(..)
|
|
, updateUserLanguage
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (authenticate)
|
|
|
|
import Auth.Dummy (apDummy)
|
|
import Auth.LDAP
|
|
import Auth.OAuth2
|
|
import Auth.PWHash (apHash)
|
|
|
|
import qualified Control.Monad.Catch as C (Handler(..))
|
|
|
|
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.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, UserAuthId ~ AuthId 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 = UniqueExternalAuth $ CI.mk credsIdent
|
|
upsertMode = creds ^? _upsertUserMode
|
|
|
|
isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
|
|
isOther = is (_Just . _UpsertUserLoginOther) 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 $ \(ldapExc :: LdapUserException) -> case ldapExc of
|
|
LdapUserNoResult -> do
|
|
$logWarnS "Auth" $ "LDAP user lookup failed after successful login for " <> credsIdent
|
|
excRecovery . UserError $ IdentifierNotFound 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 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 euid
|
|
-> associateUserSchoolsByTerms euid
|
|
_other
|
|
-> return ()
|
|
case res of
|
|
Authenticated uid
|
|
| not isDummy -> res <$ update euid [ ExternalUserLastAuth =. Just now ]
|
|
_other -> return res
|
|
|
|
$logDebugS "Auth" $ tshow Creds{..}
|
|
|
|
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
|
|
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{..}
|
|
$logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
|
Authenticated . entityKey <$> upsertLdapUser upsertMode' ldapData
|
|
_other
|
|
-> acceptExisting
|
|
|
|
|
|
data UserConversionException
|
|
= UserInvalidIdent
|
|
| UserInvalidEmail
|
|
| UserInvalidDisplayName
|
|
| UserInvalidGivenName
|
|
| UserInvalidSurname
|
|
| UserInvalidTitle
|
|
| UserInvalidFeaturesOfStudy Text
|
|
| UserInvalidAssociatedSchools Text
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
deriving anyclass (Exception)
|
|
|
|
|
|
_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 UpsertUserLoginAzure{} -- TODO: stuff upsertUserSource into credsExtra?
|
|
= cs{ credsPlugin = apAzure }
|
|
setMode UpsertUserLoginLdap{} -- TODO: stuff upsertUserSource into credsExtra?
|
|
= cs{ credsPlugin = apLdap }
|
|
setMode UpsertUserLoginDummy{..}
|
|
= cs{ credsPlugin = apDummy
|
|
, credsIdent = CI.original upsertUserIdent
|
|
}
|
|
setMode UpsertUserLoginOther{..}
|
|
= cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure])
|
|
, credsIdent = CI.original upsertUserIdent
|
|
}
|
|
setMode _ = cs
|
|
|
|
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 $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
|
|
Just ldapPool ->
|
|
ldapUser'' ldapPool ident >>= \case
|
|
Nothing -> throwM LdapUserNoResult
|
|
Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse
|
|
|
|
|
|
-- | 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 <- selectKeysList [ ExternalUserIdent ==. externalUserIdent newUser ] []
|
|
|
|
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 =. AuthLDAP | 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) <- ldapData
|
|
guard $ k == ldapAffiliation
|
|
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
|
|
|
|
-- | Upsert User DB according to given Azure data (does not query Azure itself)
|
|
-- 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 UserConversionException (User, [Update User]))
|
|
decodeLdapUserTest mbIdent ldapData = do
|
|
now <- liftIO getCurrentTime
|
|
userDefaultConf <- getsYesod $ view _appUserDefaults
|
|
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 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 -- ^ 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 ldapPrimaryKey' <- Text.decodeUtf8' bs
|
|
, Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
|
|
-> return ldapPrimaryKey''
|
|
| otherwise
|
|
-> throwM ExternalUserInvalidIdent
|
|
|
|
let externalAuthData = encode ldapData
|
|
|
|
externalAuthLastAuth <- if
|
|
| is _UpsertUserSync upsertMode || is _UpsertUserGuessUser upsertMode
|
|
-> Nothing
|
|
| otherwise
|
|
-> Just now
|
|
|
|
let
|
|
newUser = ExternalAuth
|
|
{ externalAuthSource = ldapSourceIdent
|
|
, externalAuthLastSync = now
|
|
, ..
|
|
}
|
|
userUpdate =
|
|
[ ExternalAuthIdent =. externalAuthIdent
|
|
, ExternalAuthData =. externalAuthData
|
|
, ExternalAuthLastSync =. now
|
|
]
|
|
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)
|
|
-- 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
|
|
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 UserInvalidDisplayName <&> 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 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 UserInvalidEmail
|
|
|
|
-- 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
|
|
, 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
|
|
, 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
|
|
sfs <- selectList [StudyFeaturesUser ==. uid] []
|
|
|
|
forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
|
|
schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
|
|
forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
|
|
void $ insertUnique UserSchool
|
|
{ userSchoolUser = uid
|
|
, userSchoolSchool = schoolTermsSchool
|
|
, userSchoolIsOptOut = False
|
|
}
|
|
|
|
|
|
updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, YesodAuth UniWorX
|
|
, UserId ~ AuthId UniWorX
|
|
)
|
|
=> Maybe Lang -> SqlPersistT m (Maybe Lang)
|
|
updateUserLanguage (Just lang) = do
|
|
unless (lang `elem` appLanguages) $
|
|
invalidArgs ["Unsupported language"]
|
|
|
|
muid <- maybeAuthId
|
|
for_ muid $ \uid -> do
|
|
langs <- languages
|
|
update uid [ UserLanguages =. Just (Languages $ lang : nubOrd (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
|
|
setRegisteredCookie CookieLang lang
|
|
return $ Just lang
|
|
updateUserLanguage Nothing = runMaybeT $ do
|
|
uid <- MaybeT maybeAuthId
|
|
User{..} <- MaybeT $ get uid
|
|
setLangs <- toList . selectLanguages appLanguages <$> languages
|
|
highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
|
|
let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
|
|
lang <- case (userLanguages', setLangs, highPrioSetLangs) of
|
|
(_, _, hpl : _)
|
|
-> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
|
|
(Just (l : _), _, _)
|
|
-> return l
|
|
(Nothing, l : _, _)
|
|
-> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
|
|
(Just [], l : _, _)
|
|
-> return l
|
|
(_, [], _)
|
|
-> mzero
|
|
setRegisteredCookie CookieLang lang
|
|
return lang
|
|
|
|
embedRenderMessage ''UniWorX ''UserConversionException id
|