module Auth.LDAP
  ( apLdap
  , campusLogin
  , CampusUserException(..)
  , campusUser, campusUser'
  , CampusMessage(..)
  , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
  , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
  , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
  , ldapUserSchoolAssociation
  ) where

import Import.NoFoundation
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 =
      [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
      , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
      , ldapUserEmail         Ldap.:= Text.encodeUtf8 ident
      , ldapUserEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
      , ldapUserEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
      , ldapUserDisplayName   Ldap.:= Text.encodeUtf8 ident
      ]
    userSearchSettings = mconcat
      [ Ldap.scope ldapScope
      , Ldap.size 2
      , Ldap.time ldapSearchTimeout
      , Ldap.derefAliases Ldap.DerefAlways
      ]

ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation :: Ldap.Attr
ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
ldapUserEmail             = Ldap.Attr "mail"
ldapUserDisplayName       = Ldap.Attr "displayName"
ldapUserMatriculation     = Ldap.Attr "LMU-Stud-Matrikelnummer"
ldapUserFirstName         = Ldap.Attr "givenName"
ldapUserSurname           = Ldap.Attr "sn"
ldapUserTitle             = Ldap.Attr "title"
ldapUserStudyFeatures     = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
ldapUserFieldName         = Ldap.Attr "dfnEduPersonFieldOfStudyString" 
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" 


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

instance Exception CampusUserException

makePrisms ''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 ldapUserPrincipalName
          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
                  ]

campusUser' :: (MonadBaseControl IO m, MonadCatch m, MonadIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
campusUser' conf pool User{userIdent}
  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])


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

apLdap :: Text
apLdap = "LDAP"

campusLogin :: forall site.
               ( YesodAuth site
               , RenderMessage site FormMessage
               , RenderMessage site CampusMessage
               , RenderMessage site AFormMessage
               , Button site ButtonSubmit
               ) => LdapConf -> LdapPool -> AuthPlugin site
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
  where
    apName = apLdap
    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 [ldapUserPrincipalName]
            case searchResults of
              [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
                | [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
                , 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")