module Yesod.Auth.Ldap where

import Prelude
import Yesod.Core
import Yesod.Auth
import Yesod.Form
import Control.Monad
import Data.Text (Text)
import qualified Data.Text as Text
import Control.Applicative
import LDAP.Init
import LDAP.Exceptions
import Data.Monoid
import Data.Aeson

data LdapCreds = LdapCreds 
  { ldapUser     :: Text
  , ldapPassword :: Text
  , ldapPort     :: Int
  , ldapHost     :: Text
  , ldapPrefix   :: Text
  }

instance FromJSON LdapCreds where
  parseJSON (Object o) = LdapCreds
    <$> o .: "user"
    <*> o .: "password"
    <*> o .: "port"
    <*> o .: "host"
    <*> o .: "prefix"
  parseJSON _ = mzero

ldapPluginName :: Text
ldapPluginName = "ldap"

class YesodLdap site where
  getLdapCreds :: HandlerT site IO LdapCreds

l3AuthLdap :: (RenderMessage site FormMessage, YesodAuth site, YesodLdap site) => AuthPlugin site
l3AuthLdap = AuthPlugin ldapPluginName dispatch $ \tp -> [whamlet|
<h2>AD Login
<form action="@{tp (PluginR "ldap" ["login"])}" method=post>
  <p>Log in below using your active directory credentials.
  <div.form-group>
    <label>Username
    <input.form-control type="text" name="username">
  <div.form-group>
    <label>Password
    <input.form-control type="password" name="password">
  <button.btn.btn-primary type="submit">Submit
|]

dispatch :: (RenderMessage site FormMessage, YesodAuth site, YesodLdap site) => Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
dispatch "POST" ["login"] = dispatchLdap
dispatch _ _ = notFound

dispatchLdap :: (RenderMessage site FormMessage, YesodAuth site, YesodLdap site) => HandlerT Auth (HandlerT site IO) TypedContent
dispatchLdap = do
  tp <- getRouteToParent
  creds <- lift getLdapCreds
  (username,password) <- lift $ runInputPost $ (,)
    <$> ireq textField "username"
    <*> ireq textField "password"
  let qualifiedUsername = ldapPrefix creds <> username
  success <- liftIO $ do 
    conn <- ldapOpen (Text.unpack $ ldapHost creds) (fromInteger $ toInteger $ ldapPort creds)
    ldapBoolifyExceptions $ ldapSimpleBind conn (Text.unpack qualifiedUsername) (Text.unpack password)
  lift $ if success
    then do
      -- setMessage $ toHtml $ ("Login was successful" :: Text)
      setCredsRedirect $ Creds ldapPluginName username []
    else do
      setMessage $ [shamlet|<div.alert.alert-danger>Could not log in|]
      redirect $ tp LoginR

ldapBoolifyExceptions :: IO () -> IO Bool
ldapBoolifyExceptions a = catchLDAP (True <$ a) (\_ -> return False)