192 lines
8.0 KiB
Haskell
192 lines
8.0 KiB
Haskell
module Auth.LDAP
|
|
( apLdap
|
|
, campusLogin
|
|
, CampusUserException(..)
|
|
, campusUser, campusUser'
|
|
, CampusMessage(..)
|
|
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
|
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
|
|
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
|
|
, ldapUserSchoolAssociation
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
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
|
|
} deriving (Generic, Typeable)
|
|
|
|
data CampusMessage = MsgCampusIdentPlaceholder
|
|
| MsgCampusIdent
|
|
| MsgCampusPassword
|
|
| MsgCampusSubmit
|
|
| MsgCampusInvalidCredentials
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
|
|
findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
|
findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase userSearchSettings) retAttrs) userFilters
|
|
where
|
|
userFilters =
|
|
[ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
|
|
, ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
|
, ldapUserEmail Ldap.:= Text.encodeUtf8 ident
|
|
, ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
|
|
, ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
|
, ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident
|
|
]
|
|
userSearchSettings = mconcat
|
|
[ Ldap.scope ldapScope
|
|
, Ldap.size 2
|
|
, Ldap.time ldapSearchTimeout
|
|
, Ldap.derefAliases Ldap.DerefAlways
|
|
]
|
|
|
|
ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation :: Ldap.Attr
|
|
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
|
ldapUserEmail = Ldap.Attr "mail"
|
|
ldapUserDisplayName = Ldap.Attr "displayName"
|
|
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
|
ldapUserFirstName = Ldap.Attr "givenName"
|
|
ldapUserSurname = Ldap.Attr "sn"
|
|
ldapUserTitle = Ldap.Attr "title"
|
|
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
|
ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString"
|
|
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
|
|
|
|
|
data CampusUserException = CampusUserLdapError LdapPoolError
|
|
| CampusUserHostNotResolved String
|
|
| CampusUserLineTooLong
|
|
| CampusUserHostCannotConnect String [IOException]
|
|
| CampusUserNoResult
|
|
| CampusUserAmbiguous
|
|
deriving (Show, Eq, Generic, Typeable)
|
|
|
|
instance Exception CampusUserException
|
|
|
|
makePrisms ''CampusUserException
|
|
|
|
campusUser :: MonadUnliftIO 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 ldapUserPrincipalName
|
|
userSearchSettings = mconcat
|
|
[ Ldap.scope Ldap.BaseObject
|
|
, Ldap.size 2
|
|
, Ldap.time ldapSearchTimeout
|
|
, 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
|
|
]
|
|
|
|
campusUser' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
|
|
campusUser' conf pool User{userIdent}
|
|
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
|
|
|
|
|
|
campusForm :: ( RenderMessage (HandlerSite m) FormMessage
|
|
, RenderMessage (HandlerSite m) CampusMessage
|
|
, MonadHandler m
|
|
) => WForm m (FormResult CampusLogin)
|
|
campusForm = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
ident <- wreq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "") Nothing
|
|
password <- wreq passwordField (fslI MsgCampusPassword) Nothing
|
|
|
|
return $ CampusLogin
|
|
<$> ident
|
|
<*> password
|
|
|
|
apLdap :: Text
|
|
apLdap = "LDAP"
|
|
|
|
campusLogin :: forall site.
|
|
( YesodAuth site
|
|
, RenderMessage site CampusMessage
|
|
, RenderMessage site AFormMessage
|
|
, Button site ButtonSubmit
|
|
) => LdapConf -> LdapPool -> AuthPlugin site
|
|
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
|
where
|
|
apName :: Text
|
|
apName = apLdap
|
|
|
|
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
|
|
apDispatch "POST" [] = liftSubHandler $ do
|
|
((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm
|
|
tp <- getRouteToParent
|
|
case loginRes of
|
|
FormFailure errs -> do
|
|
forM_ errs $ addMessage Error . toHtml
|
|
redirect $ tp LoginR
|
|
FormMissing -> redirect $ tp LoginR
|
|
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
|
|
ldapResult <- withLdap pool $ \ldap -> liftIO $ do
|
|
Ldap.bind ldap ldapDn ldapPassword
|
|
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
|
|
case searchResults of
|
|
[Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
|
|
| [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
|
|
, Right credsIdent <- Text.decodeUtf8' principalName
|
|
-> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
|
|
other -> return $ Left other
|
|
case ldapResult of
|
|
Left err
|
|
| LdapError (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 (Right (userDN, credsIdent)) ->
|
|
setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
|
|
Right (Left searchResults) -> do
|
|
$logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
|
|
loginErrorMessageI LoginR Msg.AuthError
|
|
apDispatch _ _ = notFound
|
|
|
|
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
|
|
apLogin toMaster = do
|
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm
|
|
let loginForm = wrapForm login FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute . toMaster $ PluginR "LDAP" []
|
|
, formEncoding = loginEnctype
|
|
, formAttrs = [("uw-no-navigate-away-prompt","")]
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just "login--campus" :: Maybe Text
|
|
}
|
|
$(widgetFile "widgets/campus-login/campus-login-form")
|