{-# LANGUAGE OverloadedStrings #-}
-- | Module for using LDAP as an authentication service
-- 
-- This code was written for yesod-auth-ldap, but maybe it can be used in any 
-- given Haskell web framwork?
-- For now, the only usage examples will be Yesod specific. So you can find
-- them in the yesod-auth-ldap repo 

module Web.Authenticate.LDAP
  ( loginLDAP
  , LDAPAuthResult (..)
  ) where

import Data.Text (Text,unpack)
import LDAP
import Control.Exception

  
data LDAPAuthResult = Ok [LDAPEntry]
                    | NoSuchUser
                    | WrongPassword

instance Show LDAPAuthResult where
  show (Ok _            )         = "Login successful"
  show NoSuchUser                 = "Wrong username"
  show WrongPassword              = "Wrong password"
   
loginLDAP :: Text -> -- user's identifier
             String -> -- user's password
             String -> -- LDAPHost
             LDAPInt -> -- LDAP port
             String -> -- DN for initial bind
             String -> -- Password for initial bind
             Maybe String -> --  Base DN for user search, if any
             LDAPScope -> -- Scope of User search
             IO LDAPAuthResult
loginLDAP user pass ldapHost ldapPort' initDN initPassword searchDN ldapScope =
  do
   ldapOBJ <- ldapInit ldapHost ldapPort'
   initBindResult <- try (ldapSimpleBind ldapOBJ initDN initPassword) 
                                                 :: IO (Either LDAPException ())
   case initBindResult of
     Right _ -> do -- Successful initial bind
       ldapOBJ' <- ldapInit ldapHost ldapPort'
       userBindResult <- try (ldapSimpleBind ldapOBJ' (unpack user) pass) 
                                                 :: IO (Either LDAPException ())
       case userBindResult of
         Right _ -> do -- Successful user bind
           entry <- ldapSearch ldapOBJ  
                               searchDN 
                               ldapScope
                               (Just ("sAMAccountName=" ++ (unpack user)))
                               LDAPAllUserAttrs
                               False
           return $ Ok entry
         Left _ -> return WrongPassword
     Left _ -> return NoSuchUser