fradrive/src/Auth/LDAP.hs

module Auth.LDAP
  ( campusLogin
  , CampusUserException(..)
  , campusUser
  , CampusMessage(..)
  , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
  ) where

import Import.NoFoundation hiding (userEmail, userDisplayName)
import Control.Lens
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 = MsgCampusIdentNote
                   | 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 =
      [ userPrincipalName Ldap.:= Text.encodeUtf8 ident
      , userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
      , userEmail         Ldap.:= Text.encodeUtf8 ident
      , userEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
      , userEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
      , userDisplayName   Ldap.:= Text.encodeUtf8 ident
      ]
    userSearchSettings = mconcat
      [ Ldap.scope ldapScope
      , Ldap.size 2
      , Ldap.time ldapSearchTimeout
      , Ldap.derefAliases Ldap.DerefAlways
      ]

userPrincipalName, userEmail, userDisplayName :: Ldap.Attr
userPrincipalName = Ldap.Attr "userPrincipalName"
userEmail         = Ldap.Attr "mail"
userDisplayName   = Ldap.Attr "displayName"

campusForm :: ( RenderMessage site FormMessage
              , RenderMessage site CampusMessage
              , Button site ButtonSubmit
              ) => AForm (HandlerT site IO) CampusLogin
campusForm = CampusLogin
  <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing
  <*> areq passwordField (fslI MsgCampusPassword) Nothing

campusLogin :: forall site.
               ( YesodAuth site
               , RenderMessage site FormMessage
               , RenderMessage site CampusMessage
               , Button site ButtonSubmit
               ) => LdapConf -> LdapPool -> AuthPlugin site
campusLogin conf@LdapConf{..} pool = 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{ campusIdent = CI.original -> campusIdent, ..} -> do
          ldapResult <- withLdap pool $ \ldap -> do
            Ldap.bind ldap ldapDn ldapPassword
            searchResults <- findUser conf ldap campusIdent [userPrincipalName]
            case searchResults of
              [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] 
                | Just [principalName] <- lookup userPrincipalName userAttrs
                , 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)) ->
              lift . 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 toMaster = do
      (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm 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")

data CampusUserException = CampusUserLdapError LdapPoolError
                         | CampusUserHostNotResolved String
                         | CampusUserLineTooLong
                         | CampusUserHostCannotConnect String [IOException]
                         | CampusUserNoResult
                         | CampusUserAmbiguous
  deriving (Show, Eq, Generic, Typeable)

instance Exception CampusUserException

campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO 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 userPrincipalName
          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
                  ]

-- ldapConfig :: UniWorX -> LDAPConfig
-- ldapConfig _app@(appSettings' -> settings) = LDAPConfig
--   { usernameFilter = \u -> principalName <> "=" <> u
--   , identifierModifier
--   , ldapUri = appLDAPURI settings
--   , initDN = appLDAPDN settings
--   , initPass = appLDAPPw settings
--   , baseDN = appLDAPBaseName settings
--   , ldapScope = LdapScopeSubtree
--   }
--   where
--     principalName :: IsString a => a
--     principalName = "userPrincipalName"
--     identifierModifier _ entry = case lookup principalName $ leattrs entry of
--       Just [n] -> Text.pack n
--       _        -> error "Could not determine user principal name"