Get new LDAP to run
This commit is contained in:
Gregor Kleen
parent
69ca22fdde
commit
2a5c84e002
@ -42,6 +42,7 @@ ldap:
|
||||
pass: "_env:LDAPPASS:"
|
||||
baseDN: "_env:LDAPBASE:"
|
||||
scope: "_env:LDAPSCOPE:WholeSubtree"
|
||||
timeout: "_env:LDAPTIMEOUT:5"
|
||||
|
||||
default-favourites: 12
|
||||
default-theme: Default
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
CampusIdentNote: Campus-Kennung bitte inkl. Domain-Teil (@campus.lmu.de) angeben.
|
||||
CampusIdent: Campus-Kennung
|
||||
CampusPassword: Passwort
|
||||
CampusSubmit: Abschicken
|
||||
CampusSubmit: Abschicken
|
||||
CampusInvalidCredentials: Ungültige Logindaten
|
||||
@ -5,11 +5,14 @@
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, NoImplicitPrelude
|
||||
, ScopedTypeVariables
|
||||
#-}
|
||||
|
||||
module Auth.LDAP
|
||||
( campusLogin
|
||||
, campusUser
|
||||
, CampusMessage(..)
|
||||
, Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -17,6 +20,12 @@ import Control.Lens
|
||||
|
||||
import Utils.Form
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
|
||||
|
||||
data CampusLogin = CampusLogin { campusIdent, campusPassword :: Text }
|
||||
|
||||
@ -24,6 +33,7 @@ data CampusMessage = MsgCampusIdentNote
|
||||
| MsgCampusIdent
|
||||
| MsgCampusPassword
|
||||
| MsgCampusSubmit
|
||||
| MsgCampusInvalidCredentials
|
||||
|
||||
|
||||
campusForm :: ( RenderMessage site FormMessage
|
||||
@ -36,20 +46,91 @@ campusForm = CampusLogin
|
||||
<*> areq passwordField (fslI MsgCampusPassword) Nothing
|
||||
<* submitButton
|
||||
|
||||
campusLogin :: ( YesodAuth site
|
||||
campusLogin :: forall site.
|
||||
( YesodAuth site
|
||||
, RenderMessage site FormMessage
|
||||
, RenderMessage site CampusMessage
|
||||
, Button site SubmitButton
|
||||
, Show (ButtonCssClass site)
|
||||
) => LdapConf -> AuthPlugin site
|
||||
campusLogin conf = AuthPlugin{..}
|
||||
campusLogin LdapConf{..} = 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{..} -> do
|
||||
ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do
|
||||
Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
let
|
||||
userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope ldapScope
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
Ldap.search ldap ldapBase userSearchSettings userFilter [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")
|
||||
|
||||
userPrincipalName :: Ldap.Attr
|
||||
userPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
|
||||
data CampusUserException = CampusUserLdapError Ldap.LdapError
|
||||
| CampusUserNoDN
|
||||
| CampusUserNoResult
|
||||
| CampusUserAmbiguous
|
||||
deriving (Show, Eq, Typeable)
|
||||
|
||||
instance Exception CampusUserException
|
||||
|
||||
campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser LdapConf{..} Creds{..} = liftIO $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
|
||||
userDN <- case lookup "DN" credsExtra of
|
||||
Just userDN -> return userDN
|
||||
Nothing -> throwM CampusUserNoDN
|
||||
let userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 credsIdent
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope Ldap.BaseObject
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
|
||||
case results of
|
||||
[] -> throwM CampusUserNoResult
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
|
||||
-- ldapConfig :: UniWorX -> LDAPConfig
|
||||
-- ldapConfig _app@(appSettings -> settings) = LDAPConfig
|
||||
-- { usernameFilter = \u -> principalName <> "=" <> u
|
||||
|
||||
@ -1093,49 +1093,76 @@ instance YesodAuth UniWorX where
|
||||
isPWFile = credsPlugin == "PWFile"
|
||||
uAuth = UniqueAuthentication userPlugin userIdent
|
||||
|
||||
$logDebugS "auth" $ tshow ((userPlugin, userIdent), creds)
|
||||
|
||||
when (isDummy || isPWFile) . (throwError =<<) . lift $
|
||||
maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||
|
||||
let
|
||||
userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra
|
||||
userEmail' = lookup "mail" credsExtra
|
||||
userDisplayName' = lookup "displayName" credsExtra
|
||||
|
||||
userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") (return . CI.mk) userEmail'
|
||||
userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName'
|
||||
$logDebugS "auth" $ tshow creds
|
||||
|
||||
AppSettings{..} <- getsYesod appSettings
|
||||
|
||||
let
|
||||
userMaxFavourites = appDefaultMaxFavourites
|
||||
userTheme = appDefaultTheme
|
||||
userDateTimeFormat = appDefaultDateTimeFormat
|
||||
userDateFormat = appDefaultDateFormat
|
||||
userTimeFormat = appDefaultTimeFormat
|
||||
newUser = User{..}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
, UserDisplayName =. userDisplayName
|
||||
, UserEmail =. userEmail
|
||||
case appLdapConf of
|
||||
Just ldapConf -> do
|
||||
ldapData <- campusUser ldapConf creds
|
||||
|
||||
let
|
||||
userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
|
||||
userEmail' = lookup (Attr "mail") ldapData
|
||||
userDisplayName' = lookup (Attr "displayName") ldapData
|
||||
|
||||
userEmail <- if
|
||||
| Just [bs] <- userEmail'
|
||||
, Right userEmail <- Text.decodeUtf8' bs
|
||||
-> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user email"
|
||||
userDisplayName <- if
|
||||
| Just [bs] <- userDisplayName'
|
||||
, Right userDisplayName <- Text.decodeUtf8' bs
|
||||
-> return userDisplayName
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user name"
|
||||
userMatrikelnummer <- if
|
||||
| Just [bs] <- userMatrikelnummer'
|
||||
, Right userMatrikelnummer <- Text.decodeUtf8' bs
|
||||
-> return $ Just userMatrikelnummer
|
||||
| Nothing <- userMatrikelnummer'
|
||||
-> return Nothing
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not decode user matriculation"
|
||||
|
||||
let
|
||||
userMaxFavourites = appDefaultMaxFavourites
|
||||
userTheme = appDefaultTheme
|
||||
userDateTimeFormat = appDefaultDateTimeFormat
|
||||
userDateFormat = appDefaultDateFormat
|
||||
userTimeFormat = appDefaultTimeFormat
|
||||
newUser = User{..}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
, UserDisplayName =. userDisplayName
|
||||
, UserEmail =. userEmail
|
||||
]
|
||||
|
||||
userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
|
||||
userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
|
||||
|
||||
let
|
||||
userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
|
||||
userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ]
|
||||
let
|
||||
userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
|
||||
userStudyFeatures' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
|
||||
fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
|
||||
|
||||
lift $ deleteWhere [StudyFeaturesUser ==. userId]
|
||||
lift $ deleteWhere [StudyFeaturesUser ==. userId]
|
||||
|
||||
forM_ fs $ \StudyFeatures{..} -> do
|
||||
lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
||||
forM_ fs $ \StudyFeatures{..} -> do
|
||||
lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
||||
|
||||
lift $ insertMany_ fs
|
||||
return $ Authenticated userId
|
||||
Nothing -> (throwError =<<) . lift $
|
||||
maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||
|
||||
lift $ insertMany_ fs
|
||||
return $ Authenticated userId
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
|
||||
|
||||
@ -91,6 +91,7 @@ data LdapConf = LdapConf
|
||||
, ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
|
||||
, ldapBase :: Ldap.Dn
|
||||
, ldapScope :: Ldap.Scope
|
||||
, ldapTimeout :: Int32
|
||||
}
|
||||
|
||||
deriveFromJSON defaultOptions ''Ldap.Scope
|
||||
@ -111,6 +112,7 @@ instance FromJSON LdapConf where
|
||||
ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .: "pass"
|
||||
ldapBase <- Ldap.Dn <$> o .: "baseDN"
|
||||
ldapScope <- o .: "scope"
|
||||
ldapTimeout <- o .: "timeout"
|
||||
return LdapConf{..}
|
||||
|
||||
instance FromJSON AppSettings where
|
||||
|
||||
Loading…
Reference in New Issue
Block a user