245 lines
11 KiB
Haskell
245 lines
11 KiB
Haskell
module Auth.LDAP
|
|
( apLdap
|
|
, campusLogin
|
|
, CampusUserException(..)
|
|
, campusUser, campusUser'
|
|
, campusUserReTest, campusUserReTest'
|
|
, campusUserMatr, campusUserMatr'
|
|
, CampusMessage(..)
|
|
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
|
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
|
|
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
|
|
, ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Network.Connection
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Control.Monad.Catch as Exc
|
|
|
|
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 :: CI Text
|
|
, campusPassword :: Text
|
|
} deriving (Generic, Typeable)
|
|
|
|
data CampusMessage = MsgCampusIdentPlaceholder
|
|
| MsgCampusIdent
|
|
| MsgCampusPassword
|
|
| MsgCampusPasswordPlaceholder
|
|
| MsgCampusSubmit
|
|
| MsgCampusInvalidCredentials
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
|
|
findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
|
findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
|
|
where
|
|
userFilters =
|
|
[ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
|
|
, ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
|
] ++
|
|
[ ldapUserEmail' Ldap.:= Text.encodeUtf8 ident'
|
|
| ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@campus.lmu.de|]]
|
|
, ldapUserEmail' <- toList ldapUserEmail
|
|
] ++
|
|
[ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident
|
|
, ldapUserMatriculation Ldap.:= Text.encodeUtf8 ident
|
|
]
|
|
|
|
findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
|
findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
|
|
where
|
|
userFilters =
|
|
[ ldapUserMatriculation Ldap.:= Text.encodeUtf8 userMatr
|
|
]
|
|
|
|
userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search
|
|
userSearchSettings LdapConf{..} = mconcat
|
|
[ Ldap.scope ldapScope
|
|
, Ldap.size 2
|
|
, Ldap.time ldapSearchTimeout
|
|
, Ldap.derefAliases Ldap.DerefAlways
|
|
]
|
|
|
|
ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester :: Ldap.Attr
|
|
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
|
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 "LMU-Stg-Fach"
|
|
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
|
ldapSex = Ldap.Attr "schacGender"
|
|
ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS"
|
|
|
|
ldapUserEmail :: NonEmpty Ldap.Attr
|
|
ldapUserEmail = Ldap.Attr "mail" :|
|
|
[ Ldap.Attr "name"
|
|
]
|
|
|
|
|
|
data CampusUserException = CampusUserLdapError LdapPoolError
|
|
| CampusUserHostNotResolved String
|
|
| CampusUserLineTooLong
|
|
| CampusUserHostCannotConnect String [IOException]
|
|
| CampusUserNoResult
|
|
| CampusUserAmbiguous
|
|
deriving (Show, Eq, Generic, Typeable)
|
|
|
|
instance Exception CampusUserException
|
|
|
|
makePrisms ''CampusUserException
|
|
|
|
campusUserWith :: MonadUnliftIO m
|
|
=> ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
|
|
-> Failover (LdapConf, LdapPool)
|
|
-> FailoverMode
|
|
-> ((LdapConf, Ldap) -> IO (Ldap.AttrList []))
|
|
-> IO (Either LdapPoolError (Ldap.AttrList []))
|
|
)
|
|
-> Failover (LdapConf, LdapPool)
|
|
-> FailoverMode
|
|
-> Creds site
|
|
-> m (Ldap.AttrList [])
|
|
campusUserWith withLdap' pool mode Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
|
|
Ldap.bind ldap ldapDn ldapPassword
|
|
results <- case lookup "DN" credsExtra of
|
|
Just userDN -> do
|
|
let userFilter = Ldap.Present ldapUserPrincipalName
|
|
Ldap.search ldap (Ldap.Dn userDN) (userSearchSettings conf) 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
|
|
]
|
|
|
|
campusUserReTest :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
|
campusUserReTest pool doTest = campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool
|
|
|
|
campusUserReTest' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
|
|
campusUserReTest' pool doTest mode User{userIdent}
|
|
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) [])
|
|
|
|
campusUser :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
|
campusUser = campusUserWith withLdapFailover
|
|
|
|
campusUser' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
|
|
campusUser' pool mode User{userIdent}
|
|
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) [])
|
|
|
|
|
|
campusUserMatr :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
|
|
campusUserMatr pool mode userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
|
|
Ldap.bind ldap ldapDn ldapPassword
|
|
results <- findUserMatr conf ldap userMatr []
|
|
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
|
|
]
|
|
|
|
campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
|
|
campusUserMatr' pool mode
|
|
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode
|
|
|
|
|
|
|
|
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 (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder)) Nothing
|
|
|
|
return $ CampusLogin
|
|
<$> ident
|
|
<*> password
|
|
|
|
apLdap :: Text
|
|
apLdap = "LDAP"
|
|
|
|
campusLogin :: forall site.
|
|
( YesodAuth site
|
|
, RenderMessage site CampusMessage
|
|
, RenderMessage site AFormMessage
|
|
, Button site ButtonSubmit
|
|
) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
|
|
campusLogin pool mode = 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 <- withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, 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")
|