{-|
Module      : Gargantext.API.Admin.Auth
Description : Server API Auth Module
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

Main authorization of Gargantext are managed in this module

-- 1: Implement the Server / Client JWT authentication
      -> Client towards Python Backend
      -> Server towards Purescript Front-End

-- 2: Implement the Auth API backend
    https://github.com/haskell-servant/servant-auth

TODO-ACCESS Critical

To see the authors:
- gource src
And you have the main viz

-}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Gargantext.API.Admin.Auth
  ( auth
  , withPolicy
  , withPolicyT
  , withNamedPolicyT
  , forgotPassword
  , forgotPasswordAsync
  , withAccess
  , withNamedAccess

  , ForgotPasswordAsyncParams

  , forgotUserPassword
  )
  where

import Control.Lens (view, (#))
import Data.Text.Lazy.Encoding qualified as LE
import Data.UUID (UUID, fromText, toText)
import Data.UUID.V4 (nextRandom)
import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Auth.PolicyCheck
import Gargantext.API.Errors (BackendInternalError(..), HasAuthenticationError, _AuthenticationError)
import Gargantext.API.Prelude (authenticationError, HasServerError, GargServerC, _ServerError, GargM, IsGargServer)
import Gargantext.API.Routes.Named qualified as Named
import Gargantext.API.Worker (serveWorkerAPI)
import Gargantext.Core.Config (HasJWTSettings(..))
import Gargantext.Core.Mail (MailModel(..), mail)
import Gargantext.Core.Mail.Types (mailSettings)
import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
import Gargantext.Database.Action.User.New (guessUserName)
import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.User
import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
import Gargantext.Database.Query.Tree.Root (getRoot)
import Gargantext.Database.Schema.Node (NodePoly(_node_id))
import Gargantext.Prelude hiding (Handler, reverse, to)
import Gargantext.Prelude.Crypto.Auth qualified as Auth
import Gargantext.Prelude.Crypto.Pass.User (gargPass)
import Servant (HasServer, ServerT, NamedRoutes, errBody, hoistServer, err404)
import Servant.Auth.Server (makeJWT)
import Servant.Server.Generic (AsServerT)

---------------------------------------------------

-- | Main functions of authorization

makeTokenForUser :: (HasJWTSettings env, HasAuthenticationError err)
                 => NodeId
                 -> UserId
                 -> Cmd env err Token
makeTokenForUser nodeId userId = do
  jwtS <- view jwtSettings
  e <- liftBase $ makeJWT (AuthenticatedUser nodeId userId) jwtS Nothing
  -- TODO-SECURITY here we can implement token expiration ^^.
  either (authenticationError . LoginFailed nodeId userId) (pure . toStrict . LE.decodeUtf8) e
  -- TODO not sure about the encoding...

checkAuthRequest :: ( HasJWTSettings env, HasAuthenticationError err, IsDBCmd env err m )
                 => Username
                 -> GargPassword
                 -> m CheckAuth
checkAuthRequest couldBeEmail (GargPassword p) = do
  -- Sometimes user put email instead of username
  -- hence we have to check before
  let usrname = case guessUserName couldBeEmail of
        Nothing      -> couldBeEmail -- we are sure this is not an email
        Just (u,_)   -> u            -- this was an email in fact

  candidate <- head <$> runDBQuery (getUsersWith usrname)
  case candidate of
    Nothing -> pure InvalidUser
    Just (UserLight { userLight_password = GargPassword h, .. }) ->
      case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
        Auth.PasswordCheckFail    -> pure InvalidPassword
        Auth.PasswordCheckSuccess -> do
          muId <- head <$> runDBQuery (getRoot (UserName usrname))
          case _node_id <$> muId of
            Nothing  -> pure InvalidUser
            Just nodeId -> do
              token <- makeTokenForUser nodeId userLight_id
              pure $ Valid token nodeId userLight_id

auth :: (HasJWTSettings env, HasAuthenticationError err, IsDBCmd env err m)
     => AuthRequest -> m AuthResponse
auth (AuthRequest u p) = do
  checkAuthRequest' <- checkAuthRequest u p
  case checkAuthRequest' of
    InvalidUser     -> do
      throwError $ _AuthenticationError # InvalidUsernameOrPassword
    InvalidPassword -> do
      throwError $ _AuthenticationError # InvalidUsernameOrPassword
    Valid to trId uId   -> pure $ AuthResponse to trId uId

--type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)

{-
instance FromBasicAuthData AuthenticatedUser where
  fromBasicAuthData authData authCheckFunction = authCheckFunction authData

authCheck :: forall env. env
          -> BasicAuthData
          -> IO (AuthResult AuthenticatedUser)
authCheck _env (BasicAuthData login password) = pure $
  maybe Indefinite Authenticated $ TODO
-}

withAccessM :: ( IsDBCmd env err m )
            => AuthenticatedUser
            -> PathId
            -> m a
            -> m a
withAccessM (AuthenticatedUser nodeId _userId) (PathNode id) m = do
  d <- runDBQuery (id `isDescendantOf` nodeId)
  if d then m else m -- serverError err401

withAccessM (AuthenticatedUser nodeId _userId) (PathNodeNode cId docId) m = do
  runDBQuery $ do
    void $ isIn cId docId -- TODO use one query for all ?
    void $ (cId `isDescendantOf` nodeId)
  if True -- a && d
     then m
     else m -- serverError err401

withAccess :: forall env err m api.
              (GargServerC env err m, HasServer api '[]) =>
              Proxy api -> Proxy m -> AuthenticatedUser -> PathId ->
              ServerT api m -> ServerT api m
withAccess p _ ur id = hoistServer p f
  where
    f :: forall a. m a -> m a
    f = withAccessM ur id

withNamedAccess :: forall env err m routes.
              ( IsGargServer env err m
              , HasServer (NamedRoutes routes) '[]
              )
              => AuthenticatedUser
              -> PathId
              -> routes (AsServerT m)
              -> routes (AsServerT m)
withNamedAccess ur pathId = hoistServer (Proxy @(NamedRoutes routes)) f
  where
    f :: forall a. m a -> m a
    f = withAccessM ur pathId

-- | Given the 'AuthenticatedUser', a policy check and a function that returns an @a@,
-- it runs the underlying policy check to ensure that the resource is returned only to
-- who is entitled to see it.
withPolicy :: IsGargServer env BackendInternalError m
           => AuthenticatedUser
           -> BoolExpr AccessCheck
           -> m a
           -> AccessPolicyManager
           -> m a
withPolicy ur checks m mgr = case mgr of
  AccessPolicyManager{runAccessPolicy} -> do
    res <- runAccessPolicy ur checks
    case res of
      Allow     -> m
      Deny err  -> throwError $ AccessPolicyError err

-- FIXME(adn) the types are wrong.
withNamedPolicyT :: forall env m routes.
                ( IsGargServer env BackendInternalError m
                , HasServer (NamedRoutes routes) '[]
                )
                => AuthenticatedUser
                -> BoolExpr AccessCheck
                -> routes (AsServerT m)
                -> AccessPolicyManager
                -> routes (AsServerT m)
withNamedPolicyT ur checks m mgr =
  hoistServer (Proxy @(NamedRoutes routes)) (\n -> withPolicy ur checks n mgr) m

withPolicyT :: forall env m api. (
                 IsGargServer env BackendInternalError m
               , HasServer api '[]
               )
            => Proxy api
            -> Proxy m
            -> AuthenticatedUser
            -> BoolExpr AccessCheck
            -> ServerT api m
            -> AccessPolicyManager
            -> ServerT api m
withPolicyT p _ ur checks m0 mgr = hoistServer p f m0
  where
    f :: forall a. m a -> m a
    f m = withPolicy ur checks m mgr

{- | Collaborative Schema
User at his root can create Teams Folder
User can create Team in Teams Folder.
User can invite User in Team as NodeNode only if Team in his parents.
All users can access to the Team folder as if they were owner.
-}

forgotPassword :: IsGargServer env err m => Named.ForgotPasswordAPI (AsServerT m)
forgotPassword = Named.ForgotPasswordAPI
  { forgotPasswordPostEp = forgotPasswordPost
  , forgotPasswordGetEp  = forgotPasswordGet
  }

forgotPasswordPost :: (IsDBEnvExtra env)
     => ForgotPasswordRequest -> Cmd env err ForgotPasswordResponse
forgotPasswordPost (ForgotPasswordRequest _email) = do
  pure $ ForgotPasswordResponse "ok"

forgotPasswordGet :: (IsDBEnvExtra env, HasServerError err)
     => Maybe Text -> Cmd env err ForgotPasswordGet
forgotPasswordGet Nothing = pure $ ForgotPasswordGet ""
forgotPasswordGet (Just uuid) = do
  let mUuid = fromText uuid
  -- FIXME(adn) Sending out \"not found\" is leaking information here, we ought to fix it.
  case mUuid of
    Nothing -> throwError $ _ServerError # err404 { errBody = "Not found" }
    Just uuid' -> do
      -- fetch user
      us <- runDBQuery $ getUsersWithForgotPasswordUUID uuid'
      case us of
        [u] -> forgotPasswordGetUser u
        _ -> throwError $ _ServerError # err404 { errBody = "Not found" }

---------------------

forgotPasswordGetUser :: ( IsDBEnvExtra env)
     => UserLight -> Cmd env err ForgotPasswordGet
forgotPasswordGetUser (UserLight { .. }) = do
  -- pick some random password
  password <- liftBase gargPass

  -- set it as user's password
  hashed <- liftBase $ Auth.hashPassword $ Auth.mkPassword password
  let hashed' = Auth.unPasswordHash hashed
  let userPassword = UserLight { userLight_password = GargPassword hashed', .. }

  runDBTx $ do
    void $ updateUserPassword userPassword
    void $ updateUserForgotPasswordUUID $ UserLight { userLight_forgot_password_uuid = Nothing, .. }

  pure $ ForgotPasswordGet password

forgotUserPassword :: (IsDBEnvExtra env)
     => UserLight -> Cmd env err ()
forgotUserPassword (UserLight { .. }) = do
  --printDebug "[forgotUserPassword] userLight_id" userLight_id
  --logDebug $ "[forgotUserPassword]" :# ["userLight_id" .= userLight_id]
  -- generate uuid for email
  uuid <- generateForgotPasswordUUID

  let userUUID = UserLight { userLight_forgot_password_uuid = Just $ toText uuid, .. }

  -- save user with that uuid
  _ <- runDBTx $ updateUserForgotPasswordUUID userUUID

  -- send email with uuid link
  cfg <- view $ mailSettings
  mail cfg (ForgotPassword { user = userUUID })

  -- on uuid link enter: change user password and present it to the
  -- user

  pure ()

--------------------------

-- Generate a unique (in whole DB) UUID for passwords.
generateForgotPasswordUUID :: (IsDBEnvExtra env)
  => Cmd env err UUID
generateForgotPasswordUUID = do
  uuid <- liftBase $ nextRandom
  us <- runDBQuery $ getUsersWithForgotPasswordUUID uuid
  case us of
    [] -> pure uuid
    _ -> generateForgotPasswordUUID

----------------------------

-- NOTE THe async endpoint is better for the "forget password"
-- request, because the delay in email sending etc won't reveal to
-- malicious users emails of our users in the db
forgotPasswordAsync :: Named.ForgotPasswordAsyncAPI (AsServerT (GargM Env BackendInternalError))
forgotPasswordAsync = Named.ForgotPasswordAsyncAPI $
  serveWorkerAPI $ \p ->
    Jobs.ForgotPasswordAsync { Jobs._fpa_args = p }
-- forgotPasswordAsync = Named.ForgotPasswordAsyncAPI $ AsyncJobs $
--   serveJobsAPI ForgotPasswordJob $ \_jHandle p -> do
--     Jobs.sendJob $ Jobs.ForgotPasswordAsync { Jobs._fpa_args = p }
