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

-}


{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE TypeApplications    #-}

module Gargantext.API.Auth.PolicyCheck (
    AccessCheck(..)
  , AccessResult(..)
  , AccessPolicyManager(..)
  , PolicyChecked
  , BoolExpr(..)

  -- * Smart constructors for access checks
  , nodeDescendant
  , nodeSuper
  , nodeUser
  , nodeReadChecks
  , nodeWriteChecks
  , nodePublishedRead
  , nodePublishedEdit
  , moveChecks
  , publishChecks
  , remoteExportChecks
  , userMe
  , alwaysAllow
  , alwaysDeny
  ) where

import Control.Lens (view)
import Data.BoolExpr (BoolExpr(..), Signed(..))
import Data.Text qualified as T
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..))
import Gargantext.API.Errors (BackendInternalError)
import Gargantext.API.Errors.Types (AccessPolicyErrorReason(..))
import Gargantext.Core.Config (GargConfig(..), HasConfig(hasConfig))
import Gargantext.Core.Config.Types (SecretsConfig(..))
import Gargantext.Core.Types (NodeId, UserId)
import Gargantext.Core.Types.Individu (User(UserName))
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.NodeNode
import Gargantext.Database.Query.Tree (isDescendantOf, isOwnedBy, isSharedWith, lookupPublishPolicy)
import Gargantext.Database.Query.Tree.Root (getRootId)
import Gargantext.Database.Schema.Node (node_user_id)
import Gargantext.Prelude
import Servant (HasServer(..), ServerT)
import Servant.API.Routes (HasRoutes(getRoutes))
import Servant.Auth.Server.Internal.AddSetCookie (AddSetCookieApi, AddSetCookies(..), Nat(S))
import Servant.Client.Core (HasClient(..), Client)
import Servant.Ekg (HasEndpoint(..))
import Servant.OpenApi qualified as OpenAPI
import Servant.Server.Internal.Delayed (addParameterCheck)
import Servant.Server.Internal.DelayedIO (DelayedIO(..))
import Servant.Swagger qualified as Swagger

-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------

-- | Phantom type that allows us to embellish a Servant route with a policy check.
data PolicyChecked a

-- | The result of an access check.
data AccessResult
  = -- | Grants access.
    Allow
    -- | Denies access with the given 'ServerError'.
  | Deny AccessPolicyErrorReason
  deriving Show

instance Semigroup AccessResult where
  Allow <> Allow        = Allow
  Allow <> Deny status  = Deny status
  Deny status <> Allow  = Deny status
  Deny status <> Deny _ = Deny status

instance Monoid AccessResult where
  mempty = Allow

-- | An access policy manager for gargantext that governs how resources are accessed
-- and who is entitled to see what.
data AccessPolicyManager = AccessPolicyManager
  { runAccessPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd BackendInternalError AccessResult }

-- | A type representing all the possible access checks we might want to perform on a resource,
-- typically a 'Node'.
data AccessCheck
  = -- | Grants access if the input 'NodeId' is a descendant of the
    -- one for the logged-in user.
    AC_node_descendant  !NodeId
    -- | Grants access if the input 'NodeId' is shared with the logged-in user.
  | AC_node_shared      !NodeId
    -- | Grants read access if the input 'NodeId' is published.
  | AC_node_published_read   !NodeId
    -- | Grants edit access if the input 'NodeId' is published.
  | AC_node_published_edit   !NodeId
    -- | Grants access if the input 'NodeId' /is/ the logged-in user.
  | AC_user_node        !NodeId
    -- | Grants access if the logged-in user is the user.
  | AC_user             !UserId
    -- | Grants access if the logged-in user is the master user.
  | AC_master_user      !NodeId
    -- | Always grant access, effectively a public route.
  | AC_always_allow
    -- | Always denies access.
  | AC_always_deny
  deriving (Show, Eq)

-------------------------------------------------------------------------------
-- Running access checks
-------------------------------------------------------------------------------

-- | The static access manager returned as part of a 'Servant' handler every time
-- we use the 'PolicyChecked' combinator.
accessPolicyManager :: AccessPolicyManager
accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
  where
    interpretPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd BackendInternalError AccessResult
    interpretPolicy ur chk = case chk of
      BAnd b1 b2
        -> liftM2 (<>) (interpretPolicy ur b1) (interpretPolicy ur b2)
      BOr b1 b2
        -> do
          c1 <- interpretPolicy ur b1
          case c1 of
            Allow  -> pure Allow
            Deny{} -> interpretPolicy ur b2
      BNot b1
        -> do
          res <- interpretPolicy ur b1
          case res of
            Allow  -> pure $ Deny invalidUserPermissions
            Deny _ -> pure Allow
      BTrue
        -> pure Allow
      BFalse
        -> pure $ Deny invalidUserPermissions
      BConst (Positive b)
        -> check' ur b
      BConst (Negative b)
        -> check' ur b


check' :: HasNodeError err => AuthenticatedUser -> AccessCheck -> DBCmd err AccessResult
check' (AuthenticatedUser loggedUserNodeId loggedUserUserId) c = do
  cfg <- view hasConfig
  runDBQuery $ case c of
    AC_always_deny
      -> pure $ Deny invalidUserPermissions
    AC_always_allow
      -> pure Allow
    AC_user_node requestedNodeId
      -> do ownedByMe <- requestedNodeId `isOwnedBy` loggedUserUserId
            enforce invalidUserPermissions $ (loggedUserNodeId == requestedNodeId || ownedByMe)
    AC_user requestedUserId
      -> enforce invalidUserPermissions $ (loggedUserUserId == requestedUserId)
    AC_master_user _requestedNodeId
      -> do
        let masterUsername = _s_master_user . _gc_secrets $ cfg
        masterNodeId   <- getRootId (UserName masterUsername)
        enforce invalidUserPermissions $ masterNodeId == loggedUserNodeId
    AC_node_descendant nodeId
      -> enforce nodeNotDescendant =<< nodeId `isDescendantOf` loggedUserNodeId
    AC_node_shared nodeId
      -> enforce nodeNotShared =<< nodeId `isSharedWith` loggedUserNodeId
    AC_node_published_read nodeId
      -> enforce nodeNotShared =<< isNodeReadOnly nodeId
    AC_node_published_edit nodeId
      -> do
        mb_pp <- lookupPublishPolicy nodeId
        targetNode <- getNode nodeId
        let allowedOrNot = do
              case mb_pp of
                Nothing -> pure Allow
                Just NPP_publish_no_edits_allowed
                  -> throwError not_editable
                Just NPP_publish_edits_only_owner_or_super
                  -> enforce (nodeNotShared' not_editable) (targetNode ^. node_user_id == loggedUserUserId)
        case allowedOrNot of
          Left err -> enforce (nodeNotShared' err) False
          Right _  -> pure Allow

-------------------------------------------------------------------------------
-- Errors
-------------------------------------------------------------------------------

nodeNotShared :: AccessPolicyErrorReason
nodeNotShared = nodeNotShared' not_shared_with_user

not_shared_with_user :: T.Text
not_shared_with_user = "Node is not published or shared with user."

not_editable :: T.Text
not_editable = "Node is published and not editable by anyone."

nodeNotShared' :: T.Text -> AccessPolicyErrorReason
nodeNotShared' = AccessPolicyErrorReason

nodeNotDescendant :: AccessPolicyErrorReason
nodeNotDescendant = AccessPolicyErrorReason "Node is not a direct descendant."

invalidUserPermissions :: AccessPolicyErrorReason
invalidUserPermissions = AccessPolicyErrorReason "User not authorized to perform the operation (typically due to wrong ownership)."

-------------------------------------------------------------------------------
-- Smart constructors of access checks
-------------------------------------------------------------------------------

nodeUser :: NodeId -> BoolExpr AccessCheck
nodeUser = BConst . Positive . AC_user_node

userMe :: UserId -> BoolExpr AccessCheck
userMe = BConst . Positive . AC_user

nodeSuper :: NodeId -> BoolExpr AccessCheck
nodeSuper = BConst . Positive . AC_master_user

nodeDescendant :: NodeId -> BoolExpr AccessCheck
nodeDescendant = BConst . Positive . AC_node_descendant

nodeShared :: NodeId -> BoolExpr AccessCheck
nodeShared = BConst . Positive . AC_node_shared

nodePublishedRead :: NodeId -> BoolExpr AccessCheck
nodePublishedRead = BConst . Positive . AC_node_published_read

nodePublishedEdit :: NodeId -> BoolExpr AccessCheck
nodePublishedEdit = BConst . Positive . AC_node_published_edit

nodeReadChecks :: NodeId -> BoolExpr AccessCheck
nodeReadChecks nid =
  nodeUser nid  `BOr`
  nodeSuper nid `BOr`
  nodeDescendant nid `BOr`
  nodeShared nid `BOr`
  nodePublishedRead nid

-- | A user can edit a node iff:
-- * The node is not published or Is published, but using a policy that allows modifications
-- /OR/
-- * The user is the owner
-- * The user is a super
-- * The node has been shared with the user
-- * The node is a discendant (adn: really needed?)
nodeWriteChecks :: NodeId -> BoolExpr AccessCheck
nodeWriteChecks nid =
  (nodeUser nid  `BOr`
   nodeSuper nid `BOr`
   nodeDescendant nid `BOr`
   nodeShared nid
  ) `BAnd` nodePublishedEdit nid

-- | A user can move a node from source to target only
-- if:
-- * He/she is a super user
-- * He/she owns the target or the source
-- * The node has been shared with the user
moveChecks :: SourceId -> TargetId -> BoolExpr AccessCheck
moveChecks (SourceId sourceId) (TargetId targetId) =
  BAnd (nodeUser sourceId `BOr` nodeSuper sourceId `BOr` nodeShared sourceId)
       (nodeUser targetId `BOr` nodeUser targetId `BOr` nodeShared targetId)

publishChecks :: NodeId -> BoolExpr AccessCheck
publishChecks nodeId =
  (nodeUser nodeId `BOr` nodeSuper nodeId)

-- | A user can export a node if he/she owns it, or if that's a super.
remoteExportChecks :: NodeId -> BoolExpr AccessCheck
remoteExportChecks nodeId =
  (nodeUser nodeId `BOr` nodeSuper nodeId)

alwaysAllow :: BoolExpr AccessCheck
alwaysAllow = BConst . Positive $ AC_always_allow

alwaysDeny :: BoolExpr AccessCheck
alwaysDeny = BConst . Positive $ AC_always_deny

-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------

instance (HasServer subApi ctx) => HasServer (PolicyChecked subApi) ctx where
  type ServerT (PolicyChecked subApi) m = AccessPolicyManager -> ServerT subApi m
  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s
  route Proxy ctx d = route (Proxy :: Proxy subApi) ctx (d `addParameterCheck` getStockAccessPolicy)
    where
      getStockAccessPolicy :: DelayedIO AccessPolicyManager
      getStockAccessPolicy = DelayedIO $ pure accessPolicyManager

type instance AddSetCookieApi (PolicyChecked a) = AddSetCookieApi a

instance AddSetCookies ('S n) old new => AddSetCookies ('S n) (AccessPolicyManager -> old) new where
  addSetCookies lst old = addSetCookies lst (old accessPolicyManager)

instance Swagger.HasSwagger sub => Swagger.HasSwagger (PolicyChecked sub) where
    toSwagger _ = Swagger.toSwagger (Proxy :: Proxy sub)

instance OpenAPI.HasOpenApi sub => OpenAPI.HasOpenApi (PolicyChecked sub) where
    toOpenApi _ = OpenAPI.toOpenApi (Proxy :: Proxy sub)

instance HasEndpoint sub => HasEndpoint (PolicyChecked sub) where
  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)

instance HasClient m sub => HasClient m (PolicyChecked sub) where
  -- Clients don't need to be aware of the AccessPolicyManager
  type Client m (PolicyChecked sub) = Client m sub
  clientWithRoute m _ req = clientWithRoute m (Proxy :: Proxy sub) req

  hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt $ cl

instance (HasRoutes subApi) => HasRoutes (PolicyChecked subApi) where
  getRoutes =
    let apiRoutes = getRoutes @subApi
    in  apiRoutes

-------------------------------------------------------------------------------
-- Utility functions
-------------------------------------------------------------------------------

-- | If the given predicate holds then grant access, otherwise denies access
-- with the given 'ServerError'.
enforce :: Applicative m => AccessPolicyErrorReason -> Bool -> m AccessResult
enforce errStatus p = pure $ if p then Allow else Deny errStatus