From fdaad16e713e69a7b47f80a690a97d2ff5eb9986 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 28 Aug 2020 12:38:37 +0200 Subject: [PATCH] fix: don't set user-last-authentication during ldap sync --- src/Auth/Dummy.hs | 8 +++-- src/Auth/PWHash.hs | 7 +++-- src/Foundation/Types.hs | 10 +++--- src/Foundation/Yesod/Auth.hs | 47 +++++++++++++++++------------ src/Handler/Users.hs | 4 ++- src/Handler/Utils/Users.hs | 2 +- src/Jobs/Handler/SynchroniseLdap.hs | 2 +- src/Jobs/HealthReport.hs | 2 +- 8 files changed, 50 insertions(+), 32 deletions(-) diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index 859b04554..351893fc9 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -1,5 +1,6 @@ module Auth.Dummy - ( dummyLogin + ( apDummy + , dummyLogin , DummyMessage(..) ) where @@ -32,6 +33,9 @@ dummyForm = do userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent]) toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent) +apDummy :: Text +apDummy = "dummy" + dummyLogin :: forall site. ( YesodAuth site , YesodPersist site @@ -44,7 +48,7 @@ dummyLogin :: forall site. dummyLogin = AuthPlugin{..} where apName :: Text - apName = "dummy" + apName = apDummy apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index c5c7d53a8..9cca6d440 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -1,5 +1,6 @@ module Auth.PWHash - ( hashLogin + ( apHash + , hashLogin , PWHashMessage(..) ) where @@ -39,6 +40,8 @@ hashForm = do <$> areq ciField (fslpI MsgPWHashIdent (mr MsgPWHashIdentPlaceholder)) Nothing <*> areq passwordField (fslpI MsgPWHashPassword (mr MsgPWHashPasswordPlaceholder)) Nothing +apHash :: Text +apHash = "PWHash" hashLogin :: forall site. ( YesodAuth site @@ -53,7 +56,7 @@ hashLogin :: forall site. hashLogin pwHashAlgo = AuthPlugin{..} where apName :: Text - apName = "PWHash" + apName = apHash apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs index 4e21dce2f..7cfa5dc0a 100644 --- a/src/Foundation/Types.hs +++ b/src/Foundation/Types.hs @@ -1,6 +1,6 @@ module Foundation.Types ( UpsertCampusUserMode(..) - , _UpsertCampusUser, _UpsertCampusUserDummy, _UpsertCampusUserOther + , _UpsertCampusUserLoginLdap, _UpsertCampusUserLoginDummy, _UpsertCampusUserLoginOther, _UpsertCampusUserLdapSync, _UpsertCampusUserGuessUser , _upsertCampusUserIdent ) where @@ -8,9 +8,11 @@ import Import.NoFoundation data UpsertCampusUserMode - = UpsertCampusUser - | UpsertCampusUserDummy { upsertCampusUserIdent :: UserIdent } - | UpsertCampusUserOther { uspertCampusUserIdent :: UserIdent } + = UpsertCampusUserLoginLdap + | UpsertCampusUserLoginDummy { upsertCampusUserIdent :: UserIdent } + | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent } + | UpsertCampusUserLdapSync { upsertCampusUserIdent :: UserIdent } + | UpsertCampusUserGuessUser deriving (Eq, Ord, Read, Show, Generic, Typeable) makeLenses_ ''UpsertCampusUserMode diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 12fb36028..0b9455eb0 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -18,10 +18,11 @@ import Handler.Utils.LdapSystemFunctions import Yesod.Auth.Message import Auth.LDAP +import Auth.PWHash (apHash) +import Auth.Dummy (apDummy) import qualified Data.CaseInsensitive as CI import qualified Control.Monad.Catch as C (Handler(..)) -import qualified Data.List.NonEmpty as NonEmpty import qualified Ldap.Client as Ldap import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -55,8 +56,8 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend uAuth = UniqueAuthentication $ CI.mk credsIdent upsertMode = creds ^? _upsertCampusUserMode - isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode - isOther = is (_Just . _UpsertCampusUserOther) upsertMode + isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode + isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode excRecovery res | isDummy || isOther @@ -129,25 +130,30 @@ data CampusUserConversionException _upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode _upsertCampusUserMode mMode cs@Creds{..} - | credsPlugin == "dummy" = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent) - | credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent) - | otherwise = setMode <$> mMode UpsertCampusUser + | credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent) + | credsPlugin == apLdap = setMode <$> mMode UpsertCampusUserLoginLdap + | otherwise = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent) where - setMode UpsertCampusUser - = cs{ credsPlugin = "LDAP" } - setMode (UpsertCampusUserDummy ident) - = cs{ credsPlugin = "dummy", credsIdent = CI.original ident } - setMode (UpsertCampusUserOther ident) - = cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident } + setMode UpsertCampusUserLoginLdap + = cs{ credsPlugin = apLdap } + setMode (UpsertCampusUserLoginDummy ident) + = cs{ credsPlugin = apDummy + , credsIdent = CI.original ident + } + setMode (UpsertCampusUserLoginOther ident) + = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap) + , credsIdent = CI.original ident + } + setMode _ = cs - others = "PWHash" :| [] + defaultOther = apHash upsertCampusUser :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m ) => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) -upsertCampusUser plugin ldapData = do +upsertCampusUser upsertMode ldapData = do now <- liftIO getCurrentTime UserDefaultConf{..} <- getsYesod $ view _appUserDefaults @@ -166,17 +172,18 @@ upsertCampusUser plugin ldapData = do userSex' = fold [ v | (k, v) <- ldapData, k == ldapSex ] userAuthentication - | is _UpsertCampusUserOther plugin - = error "PWHash should only work for users that are already known" + | is _UpsertCampusUserLoginOther upsertMode + = error "Non-LDAP logins should only work for users that are already known" | otherwise = AuthLDAP - userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin) + userLastAuthentication = guardOn isLogin now + isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode userIdent <- if | [bs] <- userIdent'' , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs - , hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin + , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode -> return userIdent' - | Just userIdent' <- plugin ^? _upsertCampusUserIdent + | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent -> return userIdent' | otherwise -> throwM CampusUserInvalidIdent @@ -260,7 +267,7 @@ upsertCampusUser plugin ldapData = do , UserSex =. userSex , UserLastLdapSynchronisation =. Just now ] ++ - [ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ] + [ UserLastAuthentication =. Just now | isLogin ] user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index b5e8313e9..96a285ce0 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -37,6 +37,8 @@ import qualified Data.Conduit.List as C import qualified Data.HashSet as HashSet +import Auth.Dummy (apDummy) + hijackUserForm :: Form () hijackUserForm csrf = do @@ -251,7 +253,7 @@ postUsersR = do hijackUser :: UserId -> Handler TypedContent hijackUser uid = do User{userIdent} <- runDB $ get404 uid - setCredsRedirect $ Creds "dummy" (CI.original userIdent) [] + setCredsRedirect $ Creds apDummy (CI.original userIdent) [] postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent postAdminHijackUserR cID = do diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 9e55182cf..210a45b06 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -135,7 +135,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) ldapPool' <- getsYesod $ view _appLdapPool fmap join . for ldapPool' $ \ldapPool -> do ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr - for ldapData $ upsertCampusUser UpsertCampusUser + for ldapData $ upsertCampusUser UpsertCampusUserGuessUser let getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index cd1765f25..45a32b8dc 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -49,7 +49,7 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do reTestAfter <- getsYesod $ view _appLdapReTestFailover ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user - void . lift $ upsertCampusUser UpsertCampusUser ldapAttrs + void . lift $ upsertCampusUser (UpsertCampusUserLdapSync userIdent) ldapAttrs Nothing -> throwM SynchroniseLdapNoLdap where diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index 67ee78717..de297d339 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -106,7 +106,7 @@ dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHea Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) -> let hCampusExc :: CampusUserException -> Handler (Sum Integer) hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err) - in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent []) + in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds apLdap adminIdent []) return $ numResolved % numAdmins _other -> return Nothing