Merge branch 'dev' into 603-dev-istex-zip-file-upload

CHANGELOG.md

+## Version 0.0.6.9.9.8.2
+
+* [FRONT][FIX][[User page] Fix the error message when the page loads (#604)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/604)
+* [FRONT][FIX][[Node content] Breadcrumb: display the full path of a node, as a breadcrumb (with each clickable parent) (#568)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/568)
+* [BACK][FIX][[Node content] Breadcrumb: display the full path of a node, as a breadcrumb (with each clickable parent) (#263)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/263)
+* [BACK][FIX][Post policy-manager fixups (#273)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/273)
+
 ## Version 0.0.6.9.9.8.1
 
 * [BACK][FIX][Security considerations (#259)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/259)

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 2.0
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.6.9.9.8.1
+version: 0.0.6.9.9.8.2
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -995,6 +995,7 @@ test-suite garg-test-hspec
   other-modules:
       Test.API
       Test.API.Authentication
+      Test.API.GraphQL
       Test.API.Private
       Test.API.Setup
       Test.Database.Operations

src/Gargantext/API/GraphQL.hs

@@ -83,6 +83,7 @@ data Query m
     , users               :: GQLUser.UserArgs -> m [GQLUser.User m]
     , tree                :: GQLTree.TreeArgs -> m (GQLTree.TreeFirstLevel m)
     , team                :: GQLTeam.TeamArgs -> m GQLTeam.Team
+    , tree_branch         :: GQLTree.BreadcrumbArgs -> m (GQLTree.BreadcrumbInfo)
     } deriving (Generic, GQLType)
 
 data Mutation m
@@ -130,7 +131,8 @@ rootResolver authenticatedUser policyManager =
                             , user_infos          = GQLUserInfo.resolveUserInfos authenticatedUser policyManager
                             , users               = GQLUser.resolveUsers authenticatedUser policyManager
                             , tree                = GQLTree.resolveTree authenticatedUser policyManager
-                            , team                = GQLTeam.resolveTeam }
+                            , team                = GQLTeam.resolveTeam 
+                            , tree_branch         = GQLTree.resolveBreadcrumb }
     , mutationResolver = Mutation { update_user_info       = GQLUserInfo.updateUserInfo
                                   , update_user_pubmed_api_key = GQLUser.updateUserPubmedAPIKey
                                   , delete_team_membership = GQLTeam.deleteTeamMembership

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

@@ -42,6 +42,16 @@ data TreeFirstLevel m = TreeFirstLevel
   , children :: [TreeNode]
   } deriving (Generic, GQLType)
 
+data BreadcrumbArgs = BreadcrumbArgs
+  {
+    node_id :: Int
+  } deriving (Generic, GQLType)
+
+data BreadcrumbInfo = BreadcrumbInfo
+  {
+    parents :: [TreeNode]
+  } deriving (Generic, GQLType)
+
 type ParentId = Maybe NodeId
 
 resolveTree :: (CmdCommon env)
@@ -97,3 +107,22 @@ nodeToTreeNode N.Node {..} = if (fromNodeTypeId _node_typename /= NN.NodeFolderS
                                            }
                              else
                              Nothing
+
+resolveBreadcrumb :: (CmdCommon env) => BreadcrumbArgs -> GqlM e env (BreadcrumbInfo)
+resolveBreadcrumb BreadcrumbArgs { node_id } = dbRecursiveParents node_id
+
+convertDbTreeToTreeNode :: T.DbTreeNode -> TreeNode
+convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_parentId } = TreeNode
+  { name = _dt_name
+  , id = NN.unNodeId _dt_nodeId
+  , node_type = fromNodeTypeId _dt_typeId
+  , parent_id = NN.unNodeId <$> _dt_parentId
+  }
+
+dbRecursiveParents :: (CmdCommon env) => Int -> GqlM e env (BreadcrumbInfo)
+dbRecursiveParents node_id = do
+  let nId = NodeId node_id
+  dbParents <- lift $ T.recursiveParents nId allNodeTypes
+  let treeNodes = map convertDbTreeToTreeNode dbParents
+  let breadcrumbInfo = BreadcrumbInfo { parents = treeNodes }
+  pure breadcrumbInfo  

src/Gargantext/API/GraphQL/User.hs

@@ -50,7 +50,8 @@ resolveUsers
   -> UserArgs
   -> GqlM e env [User (GqlM e env)]
 resolveUsers autUser mgr UserArgs { user_id } = do
-  withPolicy autUser mgr (nodeChecks (NodeId user_id)) $ dbUsers user_id
+  -- FIXME(adn) we should use a proper policy, not 'alwaysAllow'.
+  withPolicy autUser mgr alwaysAllow $ dbUsers user_id
 
 -- | Inner function to fetch the user from DB.
 dbUsers

src/Gargantext/API/GraphQL/UserInfo.hs

@@ -49,7 +49,7 @@ import Gargantext.API.GraphQL.Types
 import Gargantext.API.Admin.Auth.Types hiding (Valid)
 import Gargantext.API.Auth.PolicyCheck
 import Gargantext.API.GraphQL.PolicyCheck
-import Gargantext.Database.Admin.Types.Node
+-- import Gargantext.Database.Admin.Types.Node
 
 data UserInfo = UserInfo
   { ui_id             :: Int
@@ -108,7 +108,8 @@ resolveUserInfos
   -> AccessPolicyManager
   -> UserInfoArgs -> GqlM e env [UserInfo]
 resolveUserInfos autUser mgr UserInfoArgs { user_id } =
-  withPolicy autUser mgr (nodeChecks (NodeId user_id)) $ dbUsers user_id
+  -- FIXME(adn) we should use a proper policy, not 'alwaysAllow'.
+  withPolicy autUser mgr alwaysAllow $ dbUsers user_id
 
 -- | Mutation for user info
 updateUserInfo

src/Gargantext/Database/Query/Tree.hs

@@ -37,6 +37,7 @@ module Gargantext.Database.Query.Tree
   , sharedTreeUpdate
   , dbTree
   , updateTree
+  , recursiveParents
   )
   where
 
@@ -389,4 +390,27 @@ isIn cId docId = ( == [Only True])
       WHERE nn.node1_id = ?
         AND nn.node2_id = ?;
   |] (cId, docId)
+
+-- Recursive parents function to construct a breadcrumb
+recursiveParents :: NodeId
+       -> [NodeType]
+       -> Cmd err [DbTreeNode]
+recursiveParents nodeId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
+  <$> runPGSQuery [sql|
+    WITH RECURSIVE recursiveParents AS
+    (
+      SELECT id, typename, parent_id, name, 1 as original_order
+        FROM public.nodes WHERE id = ?
+      UNION ALL
+        SELECT n.id, n.typename, n.parent_id, n.name, rp.original_order+1
+          FROM public.nodes n 
+          INNER JOIN recursiveParents rp ON n.id = rp.parent_id
+            WHERE n.typename IN ?
+    ) SELECT id, typename, parent_id, name FROM recursiveParents ORDER BY original_order DESC;
+    |] (nodeId, In typename)
+  where
+    typename = map nodeTypeId ns
+    ns = case nodeTypes of
+      [] -> allNodeTypes
+      _  -> nodeTypes
 -----------------------------------------------------

test/Test/API.hs

@@ -5,8 +5,10 @@ import Prelude
 import Test.Hspec
 import qualified Test.API.Authentication as Auth
 import qualified Test.API.Private as Private
+import qualified Test.API.GraphQL as GraphQL
 
 tests :: Spec
 tests = describe "API" $ do
   Auth.tests
   Private.tests
+  GraphQL.tests

test/Test/API/Authentication.hs

@@ -47,7 +47,9 @@ 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.8")
+        case result of
+          Left err -> fail (show err)
+          Right r  -> r `shouldSatisfy` ((>= 1) . T.length) -- we got something back
 
     describe "POST /api/v1.0/auth" $ do
 

test/Test/API/GraphQL.hs

+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies     #-}
+{-# LANGUAGE QuasiQuotes      #-}
+{-# OPTIONS_GHC -Wno-orphans  #-}
+
+module Test.API.GraphQL (
+    tests
+  ) where
+
+import Gargantext.Core.Types.Individu
+import Prelude
+import Servant.Auth.Client ()
+import Test.API.Private (withValidLogin, protected)
+import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
+import Test.Hspec
+import Test.Hspec.Wai.Internal (withApplication)
+import Test.Utils
+import Text.RawString.QQ (r)
+
+tests :: Spec
+tests = sequential $ aroundAll withTestDBAndPort $ do
+  describe "Prelude" $ do
+    it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
+  describe "GraphQL" $ do
+
+
+    describe "get_user_infos" $ do
+      it "allows 'alice' to see her own info" $ \((testEnv, port), app) -> do
+        createAliceAndBob testEnv
+
+        withApplication app $ do
+          withValidLogin port "alice" (GargPassword "alice") $ \token -> do
+            protected token "POST" "/gql" [r| {
+               "query": "{ user_infos(user_id: 2) { ui_id, ui_email } }"
+               } |] `shouldRespondWith'` [jsonFragment| {"data":{"user_infos":[{"ui_id":2,"ui_email":"alice@gargan.text"}]}} |]

test/Test/API/Private.hs

@@ -3,7 +3,14 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Test.API.Private where
+module Test.API.Private (
+    tests
+
+  -- * Utility functions
+  , withValidLogin
+  , getJSON
+  , protected
+  ) where
 
 import Control.Exception
 import Control.Monad
@@ -11,11 +18,9 @@ import Control.Monad.Reader
 import Data.ByteString (ByteString)
 import Data.Maybe
 import Data.Proxy
-import Fmt
 import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Routes
 import Gargantext.Core.Types.Individu
-import Gargantext.Database.Action.User.New
 import Network.HTTP.Client hiding (Proxy)
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse)
@@ -24,27 +29,16 @@ import Servant
 import Servant.Auth.Client ()
 import Servant.Client
 import Test.API.Authentication (auth_api)
-import Test.API.Setup (withTestDBAndPort, setupEnvironment)
-import Test.Database.Types
+import Test.API.Setup (withTestDBAndPort, setupEnvironment, mkUrl, createAliceAndBob)
 import Test.Hspec
 import Test.Hspec.Wai hiding (pendingWith)
 import Test.Hspec.Wai.Internal (withApplication)
-import Test.Hspec.Wai.JSON (json)
 import Test.Utils (jsonFragment, shouldRespondWith')
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Text.Encoding as TE
 import qualified Network.Wai.Handler.Warp as Wai
 import qualified Servant.Auth.Client as SA
 
-type Env = ((TestEnv, Wai.Port), Application)
-
-curApi :: Builder
-curApi = "v1.0"
-
-mkUrl :: Wai.Port -> Builder -> ByteString
-mkUrl _port urlPiece =
-  "/api/" +| curApi |+ urlPiece
-
 -- | Issue a request with a valid 'Authorization: Bearer' inside.
 protected :: Token -> Method -> ByteString -> L.ByteString -> WaiSession () SResponse
 protected tkn mth url payload =
@@ -57,7 +51,7 @@ getJSON :: ByteString -> WaiSession () SResponse
 getJSON url =
   request "GET" url [(hContentType, "application/json")] ""
 
-withValidLogin :: MonadIO m => Wai.Port -> Username -> GargPassword -> (Token -> m a) -> m a
+withValidLogin :: (MonadFail m, MonadIO m) => Wai.Port -> Username -> GargPassword -> (Token -> m a) -> m a
 withValidLogin port ur pwd act = do
   baseUrl <- liftIO $ parseBaseUrl "http://localhost"
   manager <- liftIO $ newManager defaultManagerSettings
@@ -66,7 +60,11 @@ withValidLogin port ur pwd act = do
   result <- liftIO $ runClientM (auth_api authPayload) clientEnv
   case result of
     Left err  -> liftIO $ throwIO $ userError (show err)
-    Right res -> let token = _authVal_token $ fromJust (_authRes_valid res) in act token
+    Right res
+      | Just tkn <- _authRes_valid res
+      -> act (_authVal_token tkn)
+      | otherwise
+      -> fail $ "No token found in " <> show res
 
 
 tests :: Spec
@@ -83,14 +81,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
       -- FIXME(adn): unclear if this is useful at all. Doesn't do permission checking.
       it "doesn't allow someone with an invalid token to show the results" $ \((testEnv, port), _) -> do
 
-        -- Let's create two users, Alice & Bob. Alice shouldn't be able to see
-        -- Bob's private data and vice-versa.
-        void $ flip runReaderT testEnv $ runTestMonad $ do
-          let nur1 = mkNewUser "alice@gargan.text" (GargPassword "alice")
-          let nur2 = mkNewUser "bob@gargan.text" (GargPassword "bob")
-
-          void $ new_user nur1
-          void $ new_user nur2
+        createAliceAndBob testEnv
 
         let ( roots_api :<|> _nodes_api
               ) = client (Proxy :: Proxy (MkProtectedAPI GargAdminAPI)) (SA.Token "bogus")

test/Test/API/Setup.hs

@@ -3,6 +3,9 @@
 module Test.API.Setup where
 
 import Control.Lens
+import Control.Monad.Reader
+import Data.ByteString (ByteString)
+import Fmt (Builder, (+|), (|+))
 import Gargantext.API (makeApp)
 import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..))
 import Gargantext.API.Admin.Settings
@@ -10,9 +13,12 @@ import Gargantext.API.Admin.Types
 import Gargantext.API.Prelude
 import Gargantext.Core.NLP
 import Gargantext.Core.NodeStory
+import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.Flow
+import Gargantext.Database.Action.User.New
 import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
 import Gargantext.Database.Admin.Trigger.Init
+import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getOrMkList)
 import Gargantext.Prelude.Config
@@ -31,11 +37,8 @@ import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import qualified Gargantext.Utils.Jobs.Queue as Jobs
 import qualified Gargantext.Utils.Jobs.Settings as Jobs
 import qualified Network.Wai.Handler.Warp         as Warp
+import qualified Network.Wai.Handler.Warp as Wai
 import qualified Servant.Job.Async as ServantAsync
-import Gargantext.Database.Admin.Types.Hyperdata
-import Control.Monad.Reader
-import Gargantext.Core.Types.Individu
-import Gargantext.Database.Action.User.New
 
 
 newTestEnv :: TestEnv -> Logger (GargM Env GargError) -> Warp.Port -> IO Env
@@ -99,3 +102,21 @@ setupEnvironment env = flip runReaderT env $ runTestMonad $ do
                                         (Nothing :: Maybe HyperdataCorpus)
   masterListId <- getOrMkList masterCorpusId masterUserId
   void $ initLastTriggers masterListId
+
+-- | Creates two users, Alice & Bob. Alice shouldn't be able to see
+-- Bob's private data and vice-versa.
+createAliceAndBob :: TestEnv -> IO ()
+createAliceAndBob testEnv = do
+  void $ flip runReaderT testEnv $ runTestMonad $ do
+    let nur1 = mkNewUser "alice@gargan.text" (GargPassword "alice")
+    let nur2 = mkNewUser "bob@gargan.text" (GargPassword "bob")
+
+    void $ new_user nur1
+    void $ new_user nur2
+
+curApi :: Builder
+curApi = "v1.0"
+
+mkUrl :: Wai.Port -> Builder -> ByteString
+mkUrl _port urlPiece =
+  "/api/" +| curApi |+ urlPiece