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 = MsgCampusIdentPlaceholder
                   | 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 :: MonadUnliftIO 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' :: (MonadCatch m, MonadUnliftIO 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 (HandlerSite m) FormMessage
              , RenderMessage (HandlerSite m) CampusMessage
              , MonadHandler m
              ) => WForm m (FormResult CampusLogin)
campusForm = do
  MsgRenderer mr <- getMsgRenderer
  
  ident <- wreq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "") Nothing
  password <- wreq passwordField (fslI MsgCampusPassword) Nothing

  return $ CampusLogin
    <$> ident
    <*> password

apLdap :: Text
apLdap = "LDAP"

campusLogin :: forall site.
               ( YesodAuth site
               , RenderMessage site CampusMessage
               , RenderMessage site AFormMessage
               , Button site ButtonSubmit
               ) => LdapConf -> LdapPool -> AuthPlugin site
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
  where
    apName :: Text
    apName = apLdap
  
    apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
    apDispatch "POST" [] = liftSubHandler $ do
      ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm
      tp <- getRouteToParent
      case loginRes of
        FormFailure errs -> do
          forM_ errs $ addMessage Error . toHtml
          redirect $ tp LoginR
        FormMissing -> redirect $ tp LoginR
        FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
          ldapResult <- withLdap pool $ \ldap -> liftIO $ 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)) ->
              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 :: (Route Auth -> Route site) -> WidgetFor site ()
    apLogin toMaster = do
      (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm 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")