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

import Import.NoFoundation
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
  }

data CampusMessage = MsgCampusIdentNote
                   | MsgCampusIdent
                   | MsgCampusPassword
                   | MsgCampusSubmit
                   | MsgCampusInvalidCredentials
  

findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
  where
    userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
    userSearchSettings = mconcat
      [ Ldap.scope ldapScope
      , Ldap.size 2
      , Ldap.time ldapTimeout
      , Ldap.derefAliases Ldap.DerefAlways
      ]
  
userPrincipalName :: Ldap.Attr
userPrincipalName = Ldap.Attr "userPrincipalName"

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

campusLogin :: forall site.
               ( YesodAuth site
               , RenderMessage site FormMessage
               , RenderMessage site CampusMessage
               , Button site SubmitButton
               , Show (ButtonCssClass site)
               ) => 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 (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
            Ldap.bind ldap ldapDn ldapPassword
            findUser conf ldap campusIdent [userPrincipalName]
          case ldapResult of
            Left err
              | 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 searchResults
              | [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults
              , Just [principalName] <- lookup userPrincipalName userAttrs
              , Right credsIdent <- Text.decodeUtf8' principalName
                -> do
                  $logDebugS "LDAP" $ tshow searchResults
                  lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
              | otherwise -> 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
      $(widgetFile "widgets/campus-login-form")

data CampusUserException = CampusUserLdapError Ldap.LdapError
                         | CampusUserHostNotResolved String
                         | CampusUserLineTooLong
                         | CampusUserHostCannotConnect String [IOException]
                         | CampusUserNoResult
                         | CampusUserAmbiguous
  deriving (Show, Eq, 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 ldapTimeout
            , 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"