chore(auth): rewrote authenticate (still WIP)
This commit is contained in:
parent
a0e7b2f96c
commit
bf13473954
@ -34,8 +34,8 @@ AuthSourceLdap
|
||||
-- | User authentication data, source-agnostic data
|
||||
UserAuth
|
||||
ident UserIdent -- Human-readable text uniquely identifying a user
|
||||
lastLogin UTCTime -- When did the corresponding User last authenticate using this entry?
|
||||
lastSync UTCTime Maybe -- When was the corresponding User entry last synced with any external source? -- TODO rethink
|
||||
lastLogin UTCTime Maybe -- 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?
|
||||
Primary ident
|
||||
UniqueAuthentication ident
|
||||
deriving Show Eq Ord Generic
|
||||
|
||||
@ -172,7 +172,7 @@ instance YesodAuth UniWorX where
|
||||
BearerToken{..} <- MaybeT . liftHandler $ runDBRead maybeBearerToken
|
||||
hoistMaybe bearerImpersonate
|
||||
|
||||
-- TODO: update?
|
||||
-- TODO: update to new AuthId!
|
||||
instance YesodAuthPersist UniWorX where
|
||||
getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User)
|
||||
getAuthEntity = liftHandler . runDBRead . get
|
||||
|
||||
@ -4,8 +4,11 @@
|
||||
|
||||
module Foundation.Types
|
||||
( UpsertUserMode(..)
|
||||
, _UpsertUserLoginLdap, _UpsertUserLoginAzure, _UpsertUserLoginDummy, _UpsertUserLoginOther, _UpsertUserSync, _UpsertUserGuessUser
|
||||
, _upsertUserLdapSource, _upsertUserLdapData, _upsertUserAzureSource, _upsertUserAzureData, _upsertUserIdent
|
||||
, _UpsertUserLogin, _UpsertUserLoginDummy, _UpsertUserLoginOther, _UpsertUserSync, _UpsertUserGuessUser
|
||||
, _upsertUserSource, _upsertUserIdent
|
||||
, UpsertUserData(..)
|
||||
, _UpsertUserDataAzure, _UpsertUserDataLdap
|
||||
, _upsertUserAzureConf, _upsertUserAzureData, _upsertUserLdapConf, _upsertUserLdapData
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -14,25 +17,27 @@ import qualified Ldap.Client as Ldap
|
||||
|
||||
|
||||
data UpsertUserMode
|
||||
= UpsertUserLoginLdap
|
||||
{ upsertUserLdapSource :: AuthSourceLdapId
|
||||
, upsertUserLdapData :: Ldap.AttrList []
|
||||
}
|
||||
| UpsertUserLoginAzure
|
||||
{ upsertUserAzureSource :: AuthSourceAzureId
|
||||
, upsertUserAzureData :: [(Text, [ByteString])] -- TODO: use type synonym?
|
||||
}
|
||||
| UpsertUserLoginDummy
|
||||
{ upsertUserIdent :: UserIdent
|
||||
}
|
||||
| UpsertUserLoginOther -- does not allow further login
|
||||
{ upsertUserIdent :: UserIdent
|
||||
}
|
||||
| UpsertUserSync
|
||||
{ upsertUserIdent :: UserIdent
|
||||
}
|
||||
= UpsertUserLogin { upsertUserSource :: Text } -- TODO: use type synonym?
|
||||
| UpsertUserLoginDummy { upsertUserIdent :: UserIdent }
|
||||
| UpsertUserLoginOther { upsertUserIdent :: UserIdent } -- does not allow further login
|
||||
| UpsertUserSync { upsertUserIdent :: UserIdent }
|
||||
| UpsertUserGuessUser
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
deriving (Show)
|
||||
|
||||
makeLenses_ ''UpsertUserMode
|
||||
makePrisms ''UpsertUserMode
|
||||
|
||||
|
||||
data UpsertUserData
|
||||
= UpsertUserDataAzure
|
||||
{ upsertUserAzureConf :: AzureConf
|
||||
, upsertUserAzureData :: [(Text, [ByteString])] -- TODO: use type synonym?
|
||||
}
|
||||
| UpsertUserDataLdap
|
||||
{ upsertUserLdapConf :: LdapConf
|
||||
, upsertUserLdapData :: Ldap.AttrList []
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
makeLenses_ ''UpsertUserData
|
||||
makePrisms ''UpsertUserData
|
||||
|
||||
@ -4,9 +4,9 @@
|
||||
|
||||
module Foundation.Yesod.Auth
|
||||
( authenticate
|
||||
, ldapLookupAndUpsert
|
||||
, ldapLookupAndUpsert -- TODO generalize
|
||||
, upsertUser
|
||||
, decodeLdapUserTest, decodeAzureUserTest
|
||||
, decodeUserTest
|
||||
, UserConversionException(..)
|
||||
, updateUserLanguage
|
||||
) where
|
||||
@ -20,13 +20,13 @@ import Auth.PWHash (apHash)
|
||||
|
||||
import qualified Control.Monad.Catch as C (Handler(..))
|
||||
|
||||
-- import qualified Data.Aeson as Json (encode)
|
||||
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
|
||||
@ -55,7 +55,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
|
||||
userAuthConf <- getsYesod $ view _appUserAuthConf
|
||||
|
||||
let
|
||||
uAuth = UniqueExternalAuth $ CI.mk credsIdent
|
||||
uAuth = UniqueAuthentication $ CI.mk credsIdent
|
||||
upsertMode = creds ^? _upsertUserMode
|
||||
|
||||
isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
|
||||
@ -96,29 +96,29 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
|
||||
acceptExisting = do
|
||||
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||
case res of
|
||||
Authenticated euid
|
||||
-> associateUserSchoolsByTerms euid
|
||||
Authenticated uid
|
||||
-> associateUserSchoolsByTerms uid
|
||||
_other
|
||||
-> return ()
|
||||
case res of
|
||||
Authenticated uid
|
||||
| not isDummy -> res <$ update euid [ ExternalUserLastAuth =. Just now ]
|
||||
| not isDummy -> res <$ update uid [ UserAuthLastLogin =. Just now ]
|
||||
_other -> return res
|
||||
|
||||
$logDebugS "Auth" $ tshow Creds{..}
|
||||
|
||||
flip catches excHandlers $ case userAuthConf of
|
||||
UserAuthConfSingleSource (AuthSourceConfAzureAdV2 azureConf)
|
||||
UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf)
|
||||
| Just upsertMode' <- upsertMode -> do
|
||||
azureData <- azureUser azureConf Creds{..}
|
||||
$logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData
|
||||
Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData
|
||||
UserAuthConfSingleSource (AuthSourceConfLdap _)
|
||||
upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..}
|
||||
$logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData
|
||||
Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
|
||||
UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf)
|
||||
| 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
|
||||
upsertUserLdapData <- ldapUser ldapPool Creds{..}
|
||||
$logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData
|
||||
Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..}
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
@ -136,17 +136,16 @@ data UserConversionException
|
||||
deriving anyclass (Exception)
|
||||
|
||||
|
||||
-- TODO: this is probably not a sane traversal anymore...
|
||||
_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
|
||||
| credsPlugin `elem` loginAPs
|
||||
= setMode <$> mMode (UpsertUserLogin credsPlugin)
|
||||
| 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 UpsertUserLogin{..} | upsertUserSource `elem` loginAPs
|
||||
= cs{ credsPlugin = upsertUserSource }
|
||||
setMode UpsertUserLoginDummy{..}
|
||||
= cs{ credsPlugin = apDummy
|
||||
, credsIdent = CI.original upsertUserIdent
|
||||
@ -157,9 +156,11 @@ _upsertUserMode mMode cs@Creds{..}
|
||||
}
|
||||
setMode _ = cs
|
||||
|
||||
loginAPs = [ apAzure, apLdap ]
|
||||
defaultOther = apHash
|
||||
|
||||
|
||||
-- TODO: generalize
|
||||
ldapLookupAndUpsert :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
@ -167,64 +168,84 @@ ldapLookupAndUpsert :: forall m.
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Text
|
||||
-> SqlPersistT m (Entity User)
|
||||
-> SqlPersistT m (Entity UserAuth)
|
||||
ldapLookupAndUpsert ident =
|
||||
getsYesod (view _appLdapPool) >>= \case
|
||||
Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
|
||||
Just ldapPool ->
|
||||
Just ldapPool@(upsertUserLdapConf, _) ->
|
||||
ldapUser'' ldapPool ident >>= \case
|
||||
Nothing -> throwM LdapUserNoResult
|
||||
Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse
|
||||
Just upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..}
|
||||
|
||||
|
||||
-- | Upsert ExternalUser DB according to given external source data (does not query source itself)
|
||||
-- | Upsert User and related auth in 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
|
||||
-> UpsertUserData
|
||||
-> SqlPersistT m (Entity UserAuth)
|
||||
upsertUser upsertMode upsertData = do
|
||||
now <- liftIO getCurrentTime
|
||||
userDefaultConf <- getsYesod $ view _appUserDefaults
|
||||
|
||||
(newUser,userUpdate) <- decodeLdapUser now userDefaultConf upsertMode ldapData
|
||||
(newUser,userUpdate) <- decodeUser now userDefaultConf upsertData
|
||||
--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 ] []
|
||||
oldUsers <- selectKeysList [ UserIdent ==. userIdent newUser ] []
|
||||
|
||||
user@(Entity userId userRec) <- case oldUsers of
|
||||
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
|
||||
_other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
|
||||
unless (validDisplayName (newUser ^. _userTitle)
|
||||
_user@(Entity userId userRec) <- case oldUsers of
|
||||
[oldUserId] -> updateGetEntity oldUserId userUpdate
|
||||
_other -> upsertBy (UniqueUser (newUser ^. _userIdent)) newUser userUpdate
|
||||
|
||||
-- sets display name
|
||||
-- TODO: use display name from external source, if possible
|
||||
unless (validDisplayName (newUser ^. _userTitle)
|
||||
(newUser ^. _userFirstName)
|
||||
(newUser ^. _userSurname)
|
||||
(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 ()))
|
||||
|
||||
-- TODO updates ident with email - refactor and/or remove with Azure! (email /= ident in azure)
|
||||
-- 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
|
||||
userSystemFunctions' = case upsertData of
|
||||
UpsertUserDataAzure{..} -> do
|
||||
(_k, v) <- upsertUserAzureData
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
assertM' (not . Text.null) $ Text.strip str
|
||||
UpsertUserDataLdap{..} -> do
|
||||
(k, v) <- upsertUserLdapData
|
||||
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
|
||||
let (userAuthLastLogin, userAuthLastSync) = case upsertMode of
|
||||
UpsertUserSync{} -> (Nothing , Just now)
|
||||
UpsertUserGuessUser{} -> (Nothing , Nothing )
|
||||
_other -> (Just now, Nothing )
|
||||
userAuth <- upsertBy (UniqueAuthentication $ newUser ^. _userIdent) UserAuth{ userAuthIdent = newUser ^. _userIdent, ..} $
|
||||
[ UserAuthLastLogin =. Just lastLogin | lastLogin <- maybeToList userAuthLastLogin ] ++
|
||||
[ UserAuthLastSync =. Just lastSync | lastSync <- maybeToList userAuthLastSync ]
|
||||
|
||||
return userAuth
|
||||
|
||||
-- | Upsert User DB according to given Azure data (does not query Azure itself)
|
||||
-- upsertAzureUser :: forall m.
|
||||
@ -275,68 +296,122 @@ upsertUser upsertMode = do
|
||||
--
|
||||
-- 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
|
||||
decodeUserTest :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch 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
|
||||
=> UpsertUserData
|
||||
-> m (Either UserConversionException (User, [Update User]))
|
||||
decodeUserTest decodeData = do
|
||||
now <- liftIO getCurrentTime
|
||||
userDefaultConf <- getsYesod $ view _appUserDefaults
|
||||
try $ decodeUser now userDefaultConf decodeData
|
||||
|
||||
decodeUser :: ( MonadThrow m
|
||||
)
|
||||
=> UTCTime -- ^ Now
|
||||
-> UserDefaultConf
|
||||
-> UpsertUserData -- ^ Raw source data
|
||||
-> m (User,_) -- ^ Data for new User entry and updating existing User entries
|
||||
decodeUser now UserDefaultConf{..} upsertData = do
|
||||
userIdent <- if
|
||||
| Just azureData <- mbAzureData
|
||||
, [(Text.decodeUtf8' -> Right azureUserPrincipalName')] <- azureData !!! azureUserPrincipalName
|
||||
, Just azureUserPrincipalName'' <- assertM' (not . Text.null) $ Text.strip azureUserPrincipalName'
|
||||
-> return $ CI.mk azureUserPrincipalName''
|
||||
| Just ldapData <- mbLdapData
|
||||
, [(Text.decodeUtf8' -> Right ldapPrimaryKey')] <- ldapData !!! ldapPrimaryKey
|
||||
, Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
|
||||
-> return ldapPrimaryKey''
|
||||
-> return $ CI.mk ldapPrimaryKey''
|
||||
| otherwise
|
||||
-> throwM ExternalUserInvalidIdent
|
||||
|
||||
let externalAuthData = encode ldapData
|
||||
|
||||
externalAuthLastAuth <- if
|
||||
| is _UpsertUserSync upsertMode || is _UpsertUserGuessUser upsertMode
|
||||
-> Nothing
|
||||
| otherwise
|
||||
-> Just now
|
||||
-> throwM UserInvalidIdent
|
||||
|
||||
let
|
||||
newUser = ExternalAuth
|
||||
{ externalAuthSource = ldapSourceIdent
|
||||
, externalAuthLastSync = now
|
||||
(userSurname, userFirstName, userDisplayName, userEmail, userTelephone, userMobile, userCompanyPersonalNumber, userCompanyDepartment, userLanguages)
|
||||
| Just azureData <- mbAzureData
|
||||
= ( azureData `decodeAzure'` azureUserSurname
|
||||
, azureData `decodeAzure'` azureUserGivenName
|
||||
, azureData `decodeAzure'` azureUserDisplayName
|
||||
, CI.mk $
|
||||
azureData `decodeAzure'` azureUserMail
|
||||
, azureData `decodeAzure` azureUserTelephone
|
||||
, azureData `decodeAzure` azureUserMobile
|
||||
, Nothing -- userCompanyPersonalNumber not contained in Azure response
|
||||
, Nothing -- userCompanyDepartment not contained in Azure response
|
||||
, Nothing -- azureData `decodeAzure` azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage
|
||||
)
|
||||
| Just ldapData <- mbLdapData
|
||||
= ( ldapData `decodeLdap'` ldapUserSurname
|
||||
, ldapData `decodeLdap'` ldapUserFirstName
|
||||
, ldapData `decodeLdap'` ldapUserDisplayName
|
||||
, CI.mk $
|
||||
ldapData `decodeLdap'` (Ldap.Attr "mail") -- TODO: use ldapUserEmail?
|
||||
, ldapData `decodeLdap` ldapUserTelephone
|
||||
, ldapData `decodeLdap` ldapUserMobile
|
||||
, ldapData `decodeLdap` ldapUserFraportPersonalnummer
|
||||
, ldapData `decodeLdap` ldapUserFraportAbteilung
|
||||
, Nothing -- userLanguage not contained in LDAP response
|
||||
)
|
||||
| otherwise
|
||||
= error "decodeUser: Both azureData and ldapData are empty, cannot decode basic fields from no data!"
|
||||
|
||||
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
|
||||
, userTitle = Nothing
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
, userNotificationSettings = def
|
||||
, userCsvOptions = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userCreated = now
|
||||
, userDisplayEmail = userEmail
|
||||
, userMatrikelnummer = Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
|
||||
, userPostAddress = Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
|
||||
, userPostLastUpdate = Nothing
|
||||
, userPinPassword = Nothing -- must be derived via AVS
|
||||
, userPrefersPostal = userDefaultPrefersPostal
|
||||
, ..
|
||||
}
|
||||
userUpdate =
|
||||
[ ExternalAuthIdent =. externalAuthIdent
|
||||
, ExternalAuthData =. externalAuthData
|
||||
, ExternalAuthLastSync =. now
|
||||
[ UserSurname =. userSurname
|
||||
, UserFirstName =. userFirstName
|
||||
-- , UserDisplayName =. userDisplayName -- not updated, since users are allowed to change their DisplayName
|
||||
, UserEmail =. userEmail
|
||||
, UserTelephone =. userTelephone
|
||||
, UserMobile =. userMobile
|
||||
, 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))
|
||||
mbAzureData :: Maybe (Map Text [ByteString])
|
||||
mbAzureData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserAzureData upsertData
|
||||
mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString
|
||||
mbLdapData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserLdapData upsertData
|
||||
-- ldapData = fmap (Map.fromListWith (++)) $ upsertData ^? _upsertUserLdapData . over _2 (filter $ not . ByteString.null)
|
||||
|
||||
-- just returns Nothing on error, pure
|
||||
decodeLdap :: Ldap.Attr -> Maybe Text
|
||||
decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
|
||||
decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text
|
||||
decodeAzure azureData k = listToMaybe . rights $ Text.decodeUtf8' <$> azureData !!! k
|
||||
decodeLdap :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Maybe Text
|
||||
decodeLdap ldapData attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapData !!! attr
|
||||
|
||||
decodeLdap' :: Ldap.Attr -> Text
|
||||
decodeLdap' = fromMaybe "" . decodeLdap
|
||||
decodeAzure' :: Map Text [ByteString] -> Text -> Text
|
||||
decodeAzure' azureData = fromMaybe "" . decodeAzure azureData
|
||||
decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text
|
||||
decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData
|
||||
-- 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
|
||||
@ -348,11 +423,11 @@ decodeLdapUser now upsertMode ldapData = do
|
||||
|
||||
-- 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)
|
||||
-- decodeLdap1 ldapData attr err
|
||||
-- | (h:_) <- rights vs = return h
|
||||
-- | otherwise = throwM err
|
||||
-- where
|
||||
-- vs = Text.decodeUtf8' <$> (ldapData !!! attr)
|
||||
|
||||
-- accept and merge one or more successful decodings, ignoring all others
|
||||
-- decodeLdapN attr err
|
||||
@ -489,121 +564,122 @@ decodeLdapUser now 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 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)
|
||||
-- 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
|
||||
-- = AuthPWHash (error "Non-LDAP logins should only work for users that are already known") -- TODO throwM instead?
|
||||
-- | 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
|
||||
associateUserSchoolsByTerms :: MonadIO m => UserAuthId -> SqlPersistT m ()
|
||||
associateUserSchoolsByTerms uaid = do
|
||||
uid <- join $ fmap (fromMaybe $ error "associateUserSchoolsByTerms: No User for given UserAuthId!") . getKeyBy . UniqueUser . userAuthIdent <$> getJust uaid
|
||||
sfs <- selectList [StudyFeaturesUser ==. uid] []
|
||||
|
||||
forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
|
||||
@ -616,11 +692,13 @@ associateUserSchoolsByTerms uid = do
|
||||
}
|
||||
|
||||
|
||||
updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
updateUserLanguage :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, YesodAuth UniWorX
|
||||
, UserId ~ AuthId UniWorX
|
||||
)
|
||||
=> Maybe Lang -> SqlPersistT m (Maybe Lang)
|
||||
=> Maybe Lang
|
||||
-> SqlPersistT m (Maybe Lang)
|
||||
updateUserLanguage (Just lang) = do
|
||||
unless (lang `elem` appLanguages) $
|
||||
invalidArgs ["Unsupported language"]
|
||||
|
||||
Reference in New Issue
Block a user