162 lines
6.3 KiB
Haskell
162 lines
6.3 KiB
Haskell
module Auth.LDAP
|
|
( campusLogin
|
|
, CampusUserException(..)
|
|
, campusUser
|
|
, CampusMessage(..)
|
|
, Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Control.Lens
|
|
import Network.Connection
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Control.Monad.Catch as Exc
|
|
|
|
import Utils.Form
|
|
|
|
import Ldap.Client (Ldap)
|
|
import qualified Ldap.Client as Ldap
|
|
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import qualified Yesod.Auth.Message as Msg
|
|
|
|
|
|
data CampusLogin = CampusLogin
|
|
{ campusIdent :: CI Text
|
|
, campusPassword :: Text
|
|
}
|
|
|
|
data CampusMessage = MsgCampusIdentNote
|
|
| MsgCampusIdent
|
|
| MsgCampusPassword
|
|
| MsgCampusSubmit
|
|
| MsgCampusInvalidCredentials
|
|
|
|
|
|
findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
|
findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
|
|
where
|
|
userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
|
|
userSearchSettings = mconcat
|
|
[ Ldap.scope ldapScope
|
|
, Ldap.size 2
|
|
, Ldap.time ldapTimeout
|
|
, Ldap.derefAliases Ldap.DerefAlways
|
|
]
|
|
|
|
userPrincipalName :: Ldap.Attr
|
|
userPrincipalName = Ldap.Attr "userPrincipalName"
|
|
|
|
campusForm :: ( RenderMessage site FormMessage
|
|
, RenderMessage site CampusMessage
|
|
, Button site SubmitButton
|
|
, Show (ButtonCssClass site)
|
|
) => AForm (HandlerT site IO) CampusLogin
|
|
campusForm = CampusLogin
|
|
<$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
|
|
<*> areq passwordField (fslI MsgCampusPassword) Nothing
|
|
<* submitButton
|
|
|
|
campusLogin :: forall site.
|
|
( YesodAuth site
|
|
, RenderMessage site FormMessage
|
|
, RenderMessage site CampusMessage
|
|
, Button site SubmitButton
|
|
, Show (ButtonCssClass site)
|
|
) => LdapConf -> LdapPool -> AuthPlugin site
|
|
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
|
where
|
|
apName = "LDAP"
|
|
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
|
apDispatch "POST" [] = do
|
|
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
|
|
case loginRes of
|
|
FormFailure errs -> do
|
|
forM_ errs $ addMessage Error . toHtml
|
|
redirect LoginR
|
|
FormMissing -> redirect LoginR
|
|
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
|
|
ldapResult <- withLdap pool $ \ldap -> do
|
|
Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
|
|
Ldap.bind ldap ldapDn ldapPassword
|
|
findUser conf ldap campusIdent [userPrincipalName]
|
|
case ldapResult of
|
|
Left err
|
|
| Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err
|
|
-> do
|
|
$logDebugS "LDAP" "Invalid credentials"
|
|
loginErrorMessageI LoginR Msg.InvalidLogin
|
|
| otherwise -> do
|
|
$logErrorS "LDAP" $ "Error during login: " <> tshow err
|
|
loginErrorMessageI LoginR Msg.AuthError
|
|
Right searchResults
|
|
| [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults
|
|
, Just [principalName] <- lookup userPrincipalName userAttrs
|
|
, Right credsIdent <- Text.decodeUtf8' principalName
|
|
-> do
|
|
$logDebugS "LDAP" $ tshow searchResults
|
|
lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
|
|
| otherwise -> do
|
|
$logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
|
|
loginErrorMessageI LoginR Msg.AuthError
|
|
apDispatch _ _ = notFound
|
|
apLogin toMaster = do
|
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
|
|
$(widgetFile "widgets/campus-login-form")
|
|
|
|
data CampusUserException = CampusUserLdapError Ldap.LdapError
|
|
| CampusUserHostNotResolved String
|
|
| CampusUserLineTooLong
|
|
| CampusUserHostCannotConnect String [IOException]
|
|
| CampusUserNoResult
|
|
| CampusUserAmbiguous
|
|
deriving (Show, Eq, Typeable)
|
|
|
|
instance Exception CampusUserException
|
|
|
|
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
|
|
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
|
Ldap.bind ldap ldapDn ldapPassword
|
|
results <- case lookup "DN" credsExtra of
|
|
Just userDN -> do
|
|
let userFilter = Ldap.Present userPrincipalName
|
|
userSearchSettings = mconcat
|
|
[ Ldap.scope Ldap.BaseObject
|
|
, Ldap.size 2
|
|
, Ldap.time ldapTimeout
|
|
, Ldap.derefAliases Ldap.DerefAlways
|
|
]
|
|
Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
|
|
Nothing -> do
|
|
findUser conf ldap credsIdent []
|
|
case results of
|
|
[] -> throwM CampusUserNoResult
|
|
[Ldap.SearchEntry _ attrs] -> return attrs
|
|
_otherwise -> throwM CampusUserAmbiguous
|
|
where
|
|
errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
|
|
, Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
|
|
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
|
]
|
|
|
|
-- ldapConfig :: UniWorX -> LDAPConfig
|
|
-- ldapConfig _app@(appSettings -> settings) = LDAPConfig
|
|
-- { usernameFilter = \u -> principalName <> "=" <> u
|
|
-- , identifierModifier
|
|
-- , ldapUri = appLDAPURI settings
|
|
-- , initDN = appLDAPDN settings
|
|
-- , initPass = appLDAPPw settings
|
|
-- , baseDN = appLDAPBaseName settings
|
|
-- , ldapScope = LdapScopeSubtree
|
|
-- }
|
|
-- where
|
|
-- principalName :: IsString a => a
|
|
-- principalName = "userPrincipalName"
|
|
-- identifierModifier _ entry = case lookup principalName $ leattrs entry of
|
|
-- Just [n] -> Text.pack n
|
|
-- _ -> error "Could not determine user principal name"
|