Introduce the `PolicyChecked` combinator

It can be used to "bolt-on" policy checking into Servant API routes.

gargantext.cabal

@@ -49,6 +49,7 @@ library
       Gargantext.API.Admin.Settings
       Gargantext.API.Admin.Orchestrator.Types
       Gargantext.API.Admin.Types
+      Gargantext.API.Auth.PolicyCheck
       Gargantext.API.Dev
       Gargantext.API.HashedResponse
       Gargantext.API.Ngrams

src/Gargantext/API/Admin/Auth.hs

@@ -30,6 +30,7 @@ And you have the main viz
 
 module Gargantext.API.Admin.Auth
   ( auth
+  , withPolicy
   , forgotPassword
   , forgotPasswordAsync
   , withAccess
@@ -50,7 +51,7 @@ import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types
-import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer, _ServerError, GargM, GargError, serverError)
+import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer, _ServerError, GargM, GargError (..), serverError)
 import Gargantext.Core.Mail (MailModel(..), mail)
 import Gargantext.Core.Mail.Types (mailSettings)
 import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
@@ -71,6 +72,7 @@ import Servant.Auth.Server
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy.Encoding as LE
 import qualified Gargantext.Prelude.Crypto.Auth as Auth
+import Gargantext.API.Auth.PolicyCheck
 
 ---------------------------------------------------
 
@@ -159,6 +161,24 @@ withAccess p _ ur id = hoistServer p f
     f :: forall a. m a -> m a
     f = withAccessM ur id
 
+withPolicy :: forall env m api. (GargServerC env GargError m, HasServer api '[])
+           => AuthenticatedUser
+           -> BoolExpr AccessCheck
+           -> Proxy api
+           -> Proxy m
+           -> ServerT api m
+           -> AccessPolicyManager
+           -> ServerT api m
+withPolicy ur checks p _ m0 mgr = hoistServer p f m0
+  where
+    f :: forall a. m a -> m a
+    f m = case mgr of
+      AccessPolicyManager{runAccessPolicy} -> do
+        res <- runAccessPolicy ur checks
+        case res of
+          Allow     -> m
+          Deny err  -> throwError $ GargServerError err
+
 {- | Collaborative Schema
 User at his root can create Teams Folder
 User can create Team in Teams Folder.

src/Gargantext/API/Auth/PolicyCheck.hs

+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Gargantext.API.Auth.PolicyCheck (
+    AccessCheck(..)
+  , AccessResult(..)
+  , AccessPolicyManager(..)
+  , PolicyChecked
+  , BoolExpr(..)
+
+  -- * Smart constructors
+  , nodeOwner
+  , nodeSuper
+  ) where
+
+import Control.Lens
+import Gargantext.API.Admin.Auth.Types
+import Gargantext.Core.Types
+import Gargantext.Database.Action.User
+import Gargantext.Database.Prelude (DBCmd, HasConfig (..))
+import Gargantext.Prelude.Config (GargConfig(..))
+import Prelude
+import Servant
+import Servant.Ekg
+import Servant.Server.Internal.Delayed
+import Servant.Server.Internal.DelayedIO
+import qualified Servant.Swagger as Swagger
+import Gargantext.Core.Types.Individu
+import Gargantext.Database.Query.Table.Node.Error
+import Data.BoolExpr
+import Control.Monad
+import Gargantext.API.Prelude
+import Servant.Auth.Server.Internal.AddSetCookie
+
+data AccessResult
+  = Allow
+  | Deny ServerError
+
+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
+
+
+enforce :: Applicative m => ServerError -> Bool -> m AccessResult
+enforce errStatus p = pure $ if p then Allow else Deny errStatus
+
+-- | 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 GargError AccessResult }
+
+data AccessCheck
+  = AC_node_owner NodeId
+  | AC_master_user NodeId
+
+nodeOwner :: NodeId -> BoolExpr AccessCheck
+nodeOwner = BConst . Positive . AC_node_owner
+
+nodeSuper :: NodeId -> BoolExpr AccessCheck
+nodeSuper = BConst . Positive . AC_master_user
+
+check :: HasNodeError err => AuthenticatedUser -> AccessCheck -> DBCmd err AccessResult
+check (AuthenticatedUser nodeId) = \case
+  AC_node_owner requestedNodeId
+    -> enforce err403 $ nodeId == requestedNodeId
+  AC_master_user _requestedNodeId
+    -> do
+      masterUsername <- _gc_masteruser <$> view hasConfig
+      masterNodeId   <- getUserId (UserName masterUsername)
+      enforce err403 $ (NodeId masterNodeId) == nodeId
+
+accessPolicyManager :: AccessPolicyManager
+accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
+
+interpretPolicy :: AuthenticatedUser -> BoolExpr AccessCheck -> DBCmd GargError AccessResult
+interpretPolicy ur = \case
+  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 err403
+        Deny _ -> pure Allow
+  BTrue
+    -> pure Allow
+  BFalse
+    -> pure $ Deny err403
+  BConst (Positive b)
+    -> check ur b
+  BConst (Negative b)
+    -> check ur b
+
+data PolicyChecked a
+
+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 HasEndpoint sub => HasEndpoint (PolicyChecked sub) where
+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
+  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)

src/Gargantext/API/Node.hs

@@ -34,7 +34,7 @@ import Data.Maybe
 import Data.Swagger
 import Data.Text (Text())
 import GHC.Generics (Generic)
-import Gargantext.API.Admin.Auth (withAccess)
+import Gargantext.API.Admin.Auth (withAccess, withPolicy)
 import Gargantext.API.Admin.Auth.Types (PathId(..), AuthenticatedUser (..))
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Metrics
@@ -75,6 +75,7 @@ import qualified Gargantext.API.Node.Update as Update
 import qualified Gargantext.API.Search as Search
 import qualified Gargantext.Database.Action.Delete as Action (deleteNode)
 import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
+import Gargantext.API.Auth.PolicyCheck
 
 
 -- | Admin NodesAPI
@@ -118,7 +119,7 @@ roots = getNodesWithParentId Nothing
 -- CanFavorite
 -- CanMoveToTrash
 
-type NodeAPI a = Get '[JSON] (Node a)
+type NodeAPI a = PolicyChecked (Get '[JSON] (Node a))
              :<|> "rename" :> RenameApi
              :<|> PostNodeApi -- TODO move to children POST
              :<|> PostNodeAsync
@@ -197,10 +198,17 @@ nodeAPI :: forall proxy a.
          -> AuthenticatedUser
          -> NodeId
          -> ServerT (NodeAPI a) (GargM Env GargError)
-nodeAPI p authenticatedUser@(AuthenticatedUser (NodeId uId)) id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy authenticatedUser (PathNodeOwner id') nodeAPI'
+nodeAPI p authenticatedUser@(AuthenticatedUser (NodeId uId)) id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy authenticatedUser (PathNode id') nodeAPI'
   where
+
+    api :: Proxy (NodeNodeAPI a)
+    api = Proxy
+
+    m   :: Proxy (GargM Env GargError)
+    m   = Proxy
+
     nodeAPI' :: ServerT (NodeAPI a) (GargM Env GargError)
-    nodeAPI' =  getNodeWith   id' p
+    nodeAPI' =  withPolicy authenticatedUser (nodeOwner id' `BOr` nodeSuper id') api m (getNodeWith   id' p)
            :<|> rename        id'
            :<|> postNode  uId id'
            :<|> postNodeAsyncAPI  uId id'

src/Gargantext/API/Server.hs

@@ -40,6 +40,7 @@ import Gargantext.Database.Query.Table.Node.Error (NodeError(..))
 import Gargantext.Database.Prelude (hasConfig)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (gc_url_backend_api)
+import Gargantext.API.Auth.PolicyCheck ()
 
 
 serverGargAPI :: Text -> ServerT GargAPI (GargM Env GargError)

test/Test/API/Authentication.hs

@@ -47,7 +47,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
       let version_api = client (Proxy :: Proxy (MkGargAPI (GargAPIVersion GargVersion)))
       it "requires no auth and returns the current version" $ \((_testEnv, port), _) -> do
         result <- runClientM version_api (clientEnv port)
-        result `shouldBe` (Right "0.0.6.9.9.7.9")
+        result `shouldBe` (Right "0.0.6.9.9.8")
 
     describe "POST /api/v1.0/auth" $ do
 

test/Test/API/Private.hs

@@ -125,4 +125,4 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \token -> do
             protected token "GET" (mkUrl port "/node/1") ""
-              `shouldRespondWith` 401
+              `shouldRespondWith` 403