363 lines
14 KiB
Haskell
363 lines
14 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Auth.LDAP
|
|
( apLdap
|
|
, ADError(..), ADInvalidCredentials(..)
|
|
, ldapLogin
|
|
, LdapUserException(..)
|
|
, ldapUser, ldapUser', ldapUser''
|
|
--, ldapUserReTest, ldapUserReTest'
|
|
, ldapUserMatr, ldapUserMatr'
|
|
, CampusMessage(..)
|
|
, ldapPrimaryKey
|
|
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
|
, ldapUserFirstName, ldapUserSurname
|
|
, ldapAffiliation
|
|
, ldapUserMobile, ldapUserTelephone
|
|
, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
|
|
, ldapUserTitle
|
|
, ldapSearch
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
|
|
import Auth.LDAP.AD
|
|
|
|
import qualified Ldap.Client as Ldap
|
|
|
|
import Utils.Form
|
|
import Utils.Metrics
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import qualified Yesod.Auth.Message as Msg
|
|
|
|
|
|
-- | Plugin name of the LDAP yesod auth plugin
|
|
apLdap :: Text
|
|
apLdap = "LDAP"
|
|
|
|
|
|
-- TODO: rename
|
|
data CampusLogin = CampusLogin
|
|
{ campusIdent :: CI Text
|
|
, campusPassword :: Text
|
|
} deriving (Generic)
|
|
|
|
-- TODO: rename
|
|
data CampusMessage = MsgCampusIdentPlaceholder
|
|
| MsgCampusIdent
|
|
| MsgCampusPassword
|
|
| MsgCampusPasswordPlaceholder
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
|
|
findUser :: LdapConf
|
|
-> Ldap
|
|
-> Text -- ^ needle
|
|
-> [Ldap.Attr]
|
|
-> IO [Ldap.SearchEntry]
|
|
findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapConfBase $ userSearchSettings conf) retAttrs) userFilters
|
|
where
|
|
userFilters =
|
|
[ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
|
|
, ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@fraport.de|]
|
|
] ++
|
|
[ ldapUserEmail' Ldap.:= Text.encodeUtf8 ident'
|
|
| ident' <- [ident, [st|#{ident}@fraport.de|]]
|
|
, ldapUserEmail' <- toList ldapUserEmail
|
|
-- ] ++
|
|
-- [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident -- for Fraport, userDisplayName has the pattern "Surname, Firstnames"
|
|
] ++
|
|
[ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident
|
|
]
|
|
|
|
findUserMatr :: LdapConf
|
|
-> Ldap
|
|
-> Text -- ^ matriculation needle
|
|
-> [Ldap.Attr]
|
|
-> IO [Ldap.SearchEntry]
|
|
findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapConfBase $ userSearchSettings conf) retAttrs) userFilters
|
|
where
|
|
userFilters =
|
|
[ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr
|
|
]
|
|
|
|
userSearchSettings :: LdapConf
|
|
-> Ldap.Mod Ldap.Search
|
|
userSearchSettings LdapConf{..} = mconcat
|
|
[ Ldap.scope ldapConfScope
|
|
, Ldap.size 2
|
|
, Ldap.time ldapConfSearchTimeout
|
|
, Ldap.derefAliases Ldap.DerefAlways
|
|
]
|
|
|
|
ldapSearch :: forall m.
|
|
( MonadUnliftIO m
|
|
, MonadCatch m
|
|
)
|
|
=> (LdapConf, LdapPool)
|
|
-> Text -- ^ needle
|
|
-> m [Ldap.SearchEntry]
|
|
ldapSearch (conf@LdapConf{..}, ldapPool) needle = either (throwM . LdapUserLdapError) return <=< withLdap ldapPool $ \ldap -> liftIO $ do
|
|
Ldap.bind ldap ldapConfDn ldapConfPassword
|
|
findUser conf ldap needle []
|
|
|
|
ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone, ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr
|
|
ldapPrimaryKey = Ldap.Attr "cn" -- should always be identical to "sAMAccountName"
|
|
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
|
ldapUserDisplayName = Ldap.Attr "displayName"
|
|
ldapUserFirstName = Ldap.Attr "givenName"
|
|
ldapUserSurname = Ldap.Attr "sn"
|
|
ldapAffiliation = Ldap.Attr "memberOf" -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions
|
|
ldapUserTitle = Ldap.Attr "title" -- not used at Fraport
|
|
-- new
|
|
ldapUserTelephone = Ldap.Attr "telephoneNumber"
|
|
ldapUserMobile = Ldap.Attr "mobile"
|
|
ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName"
|
|
ldapUserFraportAbteilung = Ldap.Attr "department"
|
|
|
|
ldapUserEmail :: NonEmpty Ldap.Attr
|
|
ldapUserEmail = Ldap.Attr "mail" :|
|
|
[ Ldap.Attr "userPrincipalName"
|
|
]
|
|
|
|
|
|
-- TODO: deprecate in favour of FetchUserDataException
|
|
data LdapUserException = LdapUserLdapError LdapPoolError
|
|
| LdapUserNoResult
|
|
| LdapUserAmbiguous
|
|
deriving (Show, Eq, Generic)
|
|
|
|
instance Exception LdapUserException
|
|
|
|
makePrisms ''LdapUserException
|
|
|
|
|
|
ldapUserWith :: ( MonadUnliftIO m
|
|
, MonadCatch m
|
|
--, MonadLogger m
|
|
)
|
|
-- ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
|
|
-- -> (LdapConf, LdapPool)
|
|
-- -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
|
|
-- -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
|
|
-- )
|
|
=> ( LdapPool
|
|
-> (Ldap -> m (Either LdapUserException (Ldap.AttrList [])))
|
|
-> m (Either LdapPoolError (Either LdapUserException (Ldap.AttrList [])))
|
|
)
|
|
-> (LdapConf, LdapPool)
|
|
-> Creds site
|
|
-> m (Either LdapUserException (Ldap.AttrList []))
|
|
ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . LdapUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do
|
|
lift $ Ldap.bind ldap ldapConfDn ldapConfPassword
|
|
results <- case lookup "DN" credsExtra of
|
|
Just userDN -> do
|
|
let userFilter = Ldap.Present ldapUserPrincipalName
|
|
lift $ Ldap.search ldap (Ldap.Dn userDN) (userSearchSettings conf) userFilter []
|
|
Nothing -> do
|
|
lift $ findUser conf ldap credsIdent []
|
|
case results of
|
|
[] -> throwE LdapUserNoResult
|
|
[Ldap.SearchEntry _ attrs] -> return attrs
|
|
_otherwise -> throwE LdapUserAmbiguous
|
|
|
|
|
|
-- TODO: reintroduce once failover has been reimplemented
|
|
-- ldapUserReTest :: ( MonadUnliftIO m
|
|
-- , MonadMask m
|
|
-- , MonadLogger m
|
|
-- )
|
|
-- => Failover (LdapConf, LdapPool)
|
|
-- -> (Nano -> Bool)
|
|
-- -> FailoverMode
|
|
-- -> Creds site
|
|
-- -> m (Ldap.AttrList [])
|
|
-- ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
|
|
--
|
|
-- ldapUserReTest' :: ( MonadMask m
|
|
-- , MonadLogger m
|
|
-- , MonadUnliftIO m
|
|
-- )
|
|
-- => Failover (LdapConf, LdapPool)
|
|
-- -> (Nano -> Bool)
|
|
-- -> FailoverMode
|
|
-- -> User
|
|
-- -> m (Maybe (Ldap.AttrList []))
|
|
-- ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey}
|
|
-- = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent [])
|
|
-- where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey
|
|
|
|
|
|
-- TODO: deprecate in favour of fetchUserData
|
|
ldapUser :: ( MonadMask m
|
|
, MonadUnliftIO m
|
|
--, MonadLogger m
|
|
)
|
|
=> (LdapConf, LdapPool)
|
|
-> Creds site
|
|
-> m (Ldap.AttrList [])
|
|
ldapUser pool creds = throwLeft =<< ldapUserWith withLdap pool creds
|
|
|
|
ldapUser' :: ( MonadMask m
|
|
, MonadUnliftIO m
|
|
--, MonadLogger m
|
|
)
|
|
=> (LdapConf, LdapPool)
|
|
-> User
|
|
-> m (Maybe (Ldap.AttrList []))
|
|
ldapUser' pool User{userIdent}
|
|
= ldapUser'' pool $ CI.original userIdent
|
|
|
|
ldapUser'' :: ( MonadMask m
|
|
, MonadUnliftIO m
|
|
--, MonadLogger m
|
|
)
|
|
=> (LdapConf, LdapPool)
|
|
-> Text
|
|
-> m (Maybe (Ldap.AttrList []))
|
|
ldapUser'' pool ident
|
|
= runMaybeT . catchIfMaybeT (is _LdapUserNoResult) $ ldapUser pool (Creds apLdap ident [])
|
|
|
|
|
|
ldapUserMatr :: ( MonadUnliftIO m
|
|
, MonadMask m
|
|
--, MonadLogger m
|
|
)
|
|
=> (LdapConf, LdapPool)
|
|
-> UserMatriculation
|
|
-> m (Ldap.AttrList [])
|
|
ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . LdapUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do
|
|
Ldap.bind ldap ldapConfDn ldapConfPassword
|
|
results <- findUserMatr conf ldap userMatr []
|
|
case results of
|
|
[] -> throwM LdapUserNoResult
|
|
[Ldap.SearchEntry _ attrs] -> return attrs
|
|
_otherwise -> throwM LdapUserAmbiguous
|
|
|
|
ldapUserMatr' :: ( MonadMask m
|
|
, MonadUnliftIO m
|
|
--, MonadLogger m
|
|
)
|
|
=> (LdapConf, LdapPool)
|
|
-> UserMatriculation
|
|
-> m (Maybe (Ldap.AttrList []))
|
|
ldapUserMatr' pool = runMaybeT . catchIfMaybeT (is _LdapUserNoResult) . ldapUserMatr pool
|
|
|
|
|
|
newtype ADInvalidCredentials = ADInvalidCredentials ADError
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
deriving newtype (Universe, Finite, Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
|
|
|
|
isUnusualADError :: ADError -> Bool
|
|
isUnusualADError = flip notElem [ADNoSuchObject, ADLogonFailure]
|
|
|
|
|
|
campusForm :: ( RenderMessage (HandlerSite m) FormMessage
|
|
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
|
, RenderMessage (HandlerSite m) CampusMessage
|
|
, MonadHandler m
|
|
)
|
|
=> WForm m (FormResult CampusLogin)
|
|
campusForm = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
aFormToWForm $ CampusLogin
|
|
<$> areq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "" & addAttr "autocomplete" "username") Nothing
|
|
<*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing
|
|
|
|
|
|
-- TODO: reintroduce Failover
|
|
ldapLogin :: forall site.
|
|
( YesodAuth site
|
|
, RenderMessage site CampusMessage
|
|
, RenderAFormSite site
|
|
, RenderMessage site (ValueRequired site)
|
|
, RenderMessage site ADInvalidCredentials
|
|
, Button site ButtonSubmit
|
|
)
|
|
=> LdapConf
|
|
-> LdapPool
|
|
-> AuthPlugin site
|
|
ldapLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
|
where
|
|
apName :: Text
|
|
apName = apLdap
|
|
|
|
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
|
|
apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do
|
|
((loginRes, _), _) <- runFormPost $ renderWForm FormLogin campusForm
|
|
tp <- getRouteToParent
|
|
|
|
resp <- formResultMaybe loginRes $ \CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> Just <$> do
|
|
ldapResult <- withLdap pool $ \ldap -> liftIO $ do
|
|
Ldap.bind ldap ldapConfDn ldapConfPassword
|
|
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
|
|
case searchResults of
|
|
[Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
|
|
| [principalName] <- nubOrd $ fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
|
|
, Right credsIdent <- Text.decodeUtf8' principalName
|
|
-> handleIf isInvalidCredentials (return . Left) $ do
|
|
Ldap.bind ldap (Ldap.Dn credsIdent) . Ldap.Password $ Text.encodeUtf8 campusPassword
|
|
return . Right $ Right (userDN, credsIdent)
|
|
other -> return . Right $ Left other
|
|
case ldapResult of
|
|
Left err -> do
|
|
$logErrorS apName $ "Error during login: " <> tshow err
|
|
observeLoginOutcome apName LoginError
|
|
loginErrorMessageI LoginR Msg.AuthError
|
|
Right (Left (Ldap.ResponseErrorCode _ errCode _ errTxt))
|
|
| Right adError <- parseADError errCode errTxt
|
|
, isUnusualADError adError -> do
|
|
$logInfoS apName [st|#{campusIdent}: #{toPathPiece adError}|]
|
|
observeLoginOutcome apName LoginADInvalidCredentials
|
|
MsgRenderer mr <- liftHandler getMsgRenderer
|
|
setSessionJson SessionError . PermissionDenied . toPathPiece $ ADInvalidCredentials adError
|
|
loginErrorMessage (tp LoginR) . mr $ ADInvalidCredentials adError
|
|
Right (Left bindErr) -> do
|
|
case bindErr of
|
|
Ldap.ResponseErrorCode _ _ _ errTxt ->
|
|
$logInfoS apName [st|#{campusIdent}: #{errTxt}|]
|
|
_other -> return ()
|
|
$logDebugS apName "Invalid credentials"
|
|
observeLoginOutcome apName LoginInvalidCredentials
|
|
loginErrorMessageI LoginR Msg.InvalidLogin
|
|
Right (Right (Left searchResults))
|
|
| null searchResults -> do
|
|
$logDebugS apName "User not found"
|
|
observeLoginOutcome apName LoginInvalidCredentials
|
|
loginErrorMessageI LoginR Msg.InvalidLogin
|
|
| otherwise -> do
|
|
$logWarnS apName $ "Could not extract principal name: " <> tshow searchResults
|
|
observeLoginOutcome apName LoginError
|
|
loginErrorMessageI LoginR Msg.AuthError
|
|
Right (Right (Right (userDN, credsIdent))) -> do
|
|
observeLoginOutcome apName LoginSuccessful
|
|
setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
|
|
|
|
maybe (redirect $ tp LoginR) return resp
|
|
apDispatch _ [] = badMethod
|
|
apDispatch _ _ = notFound
|
|
|
|
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
|
|
apLogin toMaster = do
|
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormLogin campusForm
|
|
let loginForm = wrapForm login FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute . toMaster $ PluginR apName []
|
|
, formEncoding = loginEnctype
|
|
, formAttrs = [("uw-no-navigate-away-prompt","")]
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just "login--campus" :: Maybe Text
|
|
}
|
|
$(widgetFile "widgets/campus-login/campus-login-form")
|
|
|
|
isInvalidCredentials = \case
|
|
Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _ -> True
|
|
_other -> False
|