diff --git a/models/auth.model b/models/auth.model index 69d0502b0..147fefa9b 100644 --- a/models/auth.model +++ b/models/auth.model @@ -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 diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index a076b389e..9a8c15327 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -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 diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs index 0a2a4a97a..0cb2f2234 100644 --- a/src/Foundation/Types.hs +++ b/src/Foundation/Types.hs @@ -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 diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index b43320fbd..feeb1c692 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -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 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 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"]