247 lines
11 KiB
Haskell
247 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
|
|
, ldapAffiliation, ldapPrimaryKey
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Utils.Metrics
|
|
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
|
|
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, ldapAffiliation, ldapPrimaryKey :: 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"
|
|
ldapAffiliation = Ldap.Attr "eduPersonAffiliation"
|
|
ldapPrimaryKey = Ldap.Attr "eduPersonPrincipalName"
|
|
|
|
ldapUserEmail :: NonEmpty Ldap.Attr
|
|
ldapUserEmail = Ldap.Attr "mail" :|
|
|
[ Ldap.Attr "name"
|
|
]
|
|
|
|
|
|
data CampusUserException = CampusUserLdapError LdapPoolError
|
|
| CampusUserNoResult
|
|
| CampusUserAmbiguous
|
|
deriving (Show, Eq, Generic, Typeable)
|
|
|
|
instance Exception CampusUserException
|
|
|
|
makePrisms ''CampusUserException
|
|
|
|
campusUserWith :: ( MonadUnliftIO m
|
|
, MonadCatch m
|
|
)
|
|
=> ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
|
|
-> Failover (LdapConf, LdapPool)
|
|
-> FailoverMode
|
|
-> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
|
|
-> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
|
|
)
|
|
-> Failover (LdapConf, LdapPool)
|
|
-> FailoverMode
|
|
-> Creds site
|
|
-> m (Either CampusUserException (Ldap.AttrList []))
|
|
campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do
|
|
lift $ Ldap.bind ldap ldapDn ldapPassword
|
|
results <- case lookup "DN" credsExtra of
|
|
Just userDN -> do
|
|
let userFilter = Ldap.Present ldapUserPrincipalName
|
|
lift $ Ldap.search ldap (Ldap.Dn userDN) (userSearchSettings conf) userFilter []
|
|
Nothing -> do
|
|
lift $ findUser conf ldap credsIdent []
|
|
case results of
|
|
[] -> throwE CampusUserNoResult
|
|
[Ldap.SearchEntry _ attrs] -> return attrs
|
|
_otherwise -> throwE CampusUserAmbiguous
|
|
|
|
campusUserReTest :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
|
campusUserReTest pool doTest mode creds = either throwM return =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
|
|
|
|
campusUserReTest' :: (MonadMask m, MonadLogger 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, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
|
campusUser pool mode creds = either throwM return =<< campusUserWith withLdapFailover pool mode creds
|
|
|
|
campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger 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, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
|
|
campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
|
|
Ldap.bind ldap ldapDn ldapPassword
|
|
results <- findUserMatr conf ldap userMatr []
|
|
case results of
|
|
[] -> throwM CampusUserNoResult
|
|
[Ldap.SearchEntry _ attrs] -> return attrs
|
|
_otherwise -> throwM CampusUserAmbiguous
|
|
|
|
campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger 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) (ValueRequired (HandlerSite m))
|
|
, RenderMessage (HandlerSite m) CampusMessage
|
|
, MonadHandler m
|
|
) => WForm m (FormResult CampusLogin)
|
|
campusForm = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
aFormToWForm $ CampusLogin
|
|
<$> areq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "") Nothing
|
|
<*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder)) Nothing
|
|
|
|
apLdap :: Text
|
|
apLdap = "LDAP"
|
|
|
|
campusLogin :: forall site.
|
|
( YesodAuth site
|
|
, RenderMessage site CampusMessage
|
|
, RenderMessage site AFormMessage
|
|
, RenderMessage site (ValueRequired site)
|
|
, 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 method [] | encodeUtf8 method == methodPost = liftSubHandler $ do
|
|
((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm
|
|
tp <- getRouteToParent
|
|
|
|
resp <- formResultMaybe loginRes $ \CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> Just <$> 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] <- nub $ fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
|
|
, Right credsIdent <- Text.decodeUtf8' principalName
|
|
-> handleIf isInvalidCredentials (return . Left) $ do
|
|
Ldap.bind ldap (Ldap.Dn credsIdent) . Ldap.Password $ Text.encodeUtf8 campusPassword
|
|
return . Right $ Right (userDN, credsIdent)
|
|
other -> return . Right $ Left other
|
|
case ldapResult of
|
|
Left err -> do
|
|
$logErrorS apName $ "Error during login: " <> tshow err
|
|
observeLoginOutcome apName LoginError
|
|
loginErrorMessageI LoginR Msg.AuthError
|
|
Right (Left bindErr) -> do
|
|
case bindErr of
|
|
Ldap.ResponseErrorCode _ _ _ errTxt ->
|
|
$logInfoS apName [st|#{campusIdent}: #{errTxt}|]
|
|
_other -> return ()
|
|
$logDebugS apName "Invalid credentials"
|
|
observeLoginOutcome apName LoginInvalidCredentials
|
|
loginErrorMessageI LoginR Msg.InvalidLogin
|
|
Right (Right (Left searchResults))
|
|
| null searchResults -> do
|
|
$logDebugS apName "User not found"
|
|
observeLoginOutcome apName LoginInvalidCredentials
|
|
loginErrorMessageI LoginR Msg.InvalidLogin
|
|
| otherwise -> do
|
|
$logWarnS apName $ "Could not extract principal name: " <> tshow searchResults
|
|
observeLoginOutcome apName LoginError
|
|
loginErrorMessageI LoginR Msg.AuthError
|
|
Right (Right (Right (userDN, credsIdent))) -> do
|
|
observeLoginOutcome apName LoginSuccessful
|
|
setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
|
|
|
|
maybe (redirect $ tp LoginR) return resp
|
|
apDispatch _ [] = badMethod
|
|
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 apName []
|
|
, formEncoding = loginEnctype
|
|
, formAttrs = [("uw-no-navigate-away-prompt","")]
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just "login--campus" :: Maybe Text
|
|
}
|
|
$(widgetFile "widgets/campus-login/campus-login-form")
|
|
|
|
isInvalidCredentials = \case
|
|
Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _ -> True
|
|
_other -> False
|