fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fallbacks for lack of LDAP in environment

Browse Source
This commit is contained in:
Gregor Kleen 2018-08-01 15:04:41 +02:00
parent 2a5c84e002
commit 64ac12802a
3 changed files with 34 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
src/Auth/LDAP.hs
View File

@ -36,6 +36,20 @@ data CampusMessage = MsgCampusIdentNote
| MsgCampusInvalidCredentials
findUser :: LdapConf -> Ldap.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
@ -53,7 +67,7 @@ campusLogin :: forall site.
, Button site SubmitButton
, Show (ButtonCssClass site)
) => LdapConf -> AuthPlugin site
campusLogin LdapConf{..} = AuthPlugin{..}
campusLogin conf@LdapConf{..} = AuthPlugin{..}
where
apName = "LDAP"
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
@ -68,15 +82,7 @@ campusLogin LdapConf{..} = AuthPlugin{..}
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]
findUser conf ldap campusIdent [userPrincipalName]
case ldapResult of
Left err
| Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err
@ -101,11 +107,7 @@ campusLogin LdapConf{..} = AuthPlugin{..}
(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)
@ -113,19 +115,20 @@ data CampusUserException = CampusUserLdapError Ldap.LdapError
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
]
campusUser conf@LdapConf{..} Creds{..} = liftIO $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
Ldap.bind ldap ldapDn ldapPassword
results <- Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
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

2
src/Foundation.hs
View File

@ -1099,7 +1099,7 @@ instance YesodAuth UniWorX where
case appLdapConf of
Just ldapConf -> do
ldapData <- campusUser ldapConf creds
ldapData <- campusUser ldapConf $ Creds userPlugin userIdent credsExtra
let
userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData

5
src/Settings.hs
View File

@ -125,7 +125,10 @@ instance FromJSON AppSettings where
#endif
appStaticDir <- o .: "static-dir"
appDatabaseConf <- o .: "database"
appLdapConf <- o .:? "ldap"
let nonEmptyHost LdapConf{..} = case ldapHost of
Ldap.Tls host _ -> not $ null host
Ldap.Plain host -> not $ null host
appLdapConf <- (>>= (\c -> c <$ guard (nonEmptyHost c))) <$> o .:? "ldap"
appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host"
appPort <- o .: "port"