7aa2703319
Only Bind and Search operations are (partially) implemented. More tests and documentation are needed.
103 lines
3.8 KiB
Haskell
103 lines
3.8 KiB
Haskell
{-# LANGUAGE OverloadedLists #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
-- | An example of how to do LDAP logins with ldap-client.
|
||
--
|
||
-- First, the assumptions this example makes. It defaults to LDAP over TLS,
|
||
-- so if you only have a plaintext server, please replace `Secure` with `Plain`.
|
||
-- It also assumes the accounts you may want to log in as all have
|
||
-- `objectClass` "Person".
|
||
--
|
||
-- To run the example you have to provide a bunch of environment variables:
|
||
--
|
||
-- - `HOST` is the LDAP host to connect to (without "ldap://", "ldaps://", etc).
|
||
-- - `POST` is the port LDAP server listens on.
|
||
-- - `MANAGER_DN` is the DN of the account the first bind is made with.
|
||
-- - `MANAGER_PASSWORD` is its password.
|
||
-- - `BASE_OBJECT` is the search root
|
||
module Main (main) where
|
||
|
||
import Control.Exception (bracket_) -- base
|
||
import Control.Monad (when) -- base
|
||
import Data.Function (fix) -- base
|
||
import Data.Text (Text) -- text
|
||
import qualified Data.Text.Encoding as Text -- text
|
||
import qualified Data.Text.IO as Text -- text
|
||
import Env -- envparse
|
||
import qualified Ldap.Client as Ldap -- ldap-client
|
||
import Ldap.Client -- ldap-client
|
||
( LdapError
|
||
, Scope(..)
|
||
, Filter(..)
|
||
, Attr(..)
|
||
)
|
||
import System.Exit (die) -- base
|
||
import qualified System.IO as IO -- base
|
||
|
||
|
||
data Conf = Conf
|
||
{ host :: String
|
||
, port :: Ldap.PortNumber
|
||
, dn :: Ldap.Dn
|
||
, password :: Ldap.Password
|
||
, base :: Ldap.Dn
|
||
} deriving (Show, Eq)
|
||
|
||
getConf :: IO Conf
|
||
getConf = Env.parse (header "LDAP login example") $ Conf
|
||
<$> var str "HOST" (help "LDAP hostname")
|
||
<*> var (fmap fromIntegral . auto) "PORT" (help "LDAP port")
|
||
<*> var (fmap Ldap.Dn . str) "MANAGER_DN" (help "Manager login DN")
|
||
<*> var (fmap Ldap.Password . str) "MANAGER_PASSWORD" (help "Manager password")
|
||
<*> var (fmap Ldap.Dn . str) "BASE_OBJECT" (help "Search root")
|
||
|
||
main :: IO ()
|
||
main = do
|
||
conf <- getConf
|
||
res <- login conf
|
||
case res of
|
||
Left e -> die (show e)
|
||
Right _ -> return ()
|
||
|
||
login :: Conf -> IO (Either LdapError ())
|
||
login conf =
|
||
Ldap.with (Ldap.Secure (host conf)) (port conf) $ \l -> do
|
||
Ldap.bind l (dn conf) (password conf)
|
||
fix $ \loop -> do
|
||
uid <- prompt "Username: "
|
||
us <- Ldap.search l (base conf)
|
||
(Ldap.scope WholeSubtree <> Ldap.typesOnly True)
|
||
(And [ Attr "objectClass" := "Person"
|
||
, Attr "uid" := Text.encodeUtf8 uid
|
||
])
|
||
[]
|
||
case us of
|
||
Ldap.SearchEntry udn _ : _ ->
|
||
fix $ \loop' -> do
|
||
pwd <- bracket_ hideOutput
|
||
showOutput
|
||
(do pwd <- prompt ("Password for ‘" <> uid <> "’: ")
|
||
Text.putStr "\n"
|
||
return pwd)
|
||
res <- Ldap.bindEither l udn (Ldap.Password (Text.encodeUtf8 pwd))
|
||
case res of
|
||
Left _ -> do again <- question "Invalid password. Try again? [y/n] "
|
||
when again loop'
|
||
Right _ -> Text.putStrLn "OK"
|
||
[] -> do again <- question "Invalid username. Try again? [y/n] "
|
||
when again loop
|
||
|
||
prompt :: Text -> IO Text
|
||
prompt msg = do Text.putStr msg; IO.hFlush IO.stdout; Text.getLine
|
||
|
||
question :: Text -> IO Bool
|
||
question msg = fix $ \loop -> do
|
||
res <- prompt msg
|
||
case res of
|
||
"y" -> return True
|
||
"n" -> return False
|
||
_ -> do Text.putStrLn "Please, answer either ‘y’ or ‘n’."; loop
|
||
|
||
hideOutput, showOutput :: IO ()
|
||
hideOutput = IO.hSetEcho IO.stdout False
|
||
showOutput = IO.hSetEcho IO.stdout True
|