Merge branch 'dev' into 238-dev-async-job-worker

CHANGELOG.md

+## Version 0.0.7.4.2
+
+* [BACK][FIX][Let users create a Subcorpus (#384)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/384)
+* [BACK][FIX][Can not get Tree anymore with shared Team (#426)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/426)
+
 ## Version 0.0.7.4.1
 
 * [FRONT][FEAT] Auto-reload

README.md

@@ -396,6 +396,20 @@ cabal v2-test garg-test-tasty --test-show-details=streaming --flags 'test-crypto
 
 # Async workers <a name="async-workers"></a>
 
+## Steps to configure the worker
+
+1. First create our Worker
+```bash
+createdb gargantext_pgmq
+psql -c "ALTER DATABASE \"gargantext_pgmq\" OWNER TO \"gargantua\""
+```
+2. Then configure you gargantext-settings.toml (see next section)
+
+3. Finally launch the worker
+```bash
+nix-shell --run "cabal v2-run gargantext-cli -- worker run --name default"
+```
+
 ## Configuration
 
 Edit your `gargantext-settings.toml` file and add this section:

bin/gargantext_tmux → bin/scripts/gargantext_tmux

 #!/bin/bash
 
-tmux new -d -s gargantext './server' \; \
+tmux new -d -s gargantext './bin/scripts/server' \; \
             split-window -h -d 'cd ./purescript-gargantext ; ./server' \; \
             select-pane -t 1 \; \
             split-window -d    'cd devops/docker/nlp/stanford/ ; docker-compose up' \; \
             split-window -d    'cd deps/nlp/spacy-server ; docker-compose up' \; \
+            split-window -d    './bin/scripts/start-worker' \; \

bin/scripts/start-worker

+#!/bin/bash
+
+# Create the database for the worker using PostgreSQL first:
+# sudo su postgres
+# createdb -p 5433 gargantext_pgmq
+# psql -p 5433 -c "alter database \"gargantext_pgmq\" owner to \"gargantua\""
+
+
+# Then launch the service
+
+nix-shell --run "cabal v2-run gargantext-cli -- worker run --name default"

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.7.4.1
+version: 0.0.7.4.2
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -323,6 +323,7 @@ library
       Gargantext.API.Node.Corpus.Export
       Gargantext.API.Node.Corpus.Export.Types
       Gargantext.API.Node.Corpus.Searx
+      Gargantext.API.Node.Corpus.Subcorpus
       Gargantext.API.Node.Document.Export
       Gargantext.API.Node.Document.Export.Types
       Gargantext.API.Node.Phylo.Export
@@ -354,6 +355,7 @@ library
       Gargantext.Core.Methods.Similarities.Accelerate.Distributional
       Gargantext.Core.Methods.Similarities.Accelerate.SpeGen
       Gargantext.Core.Statistics
+      Gargantext.Core.Text.Corpus
       Gargantext.Core.Text.Corpus.API.Hal
       Gargantext.Core.Text.Corpus.API.Isidore
       Gargantext.Core.Text.Corpus.API.Istex
@@ -436,7 +438,6 @@ library
       Gargantext.Database.Admin.Types.Hyperdata.User
       Gargantext.Database.Admin.Types.Metrics
       Gargantext.Database.GargDB
-      Gargantext.Database.Query
       Gargantext.Database.Query.Facet.Types
       Gargantext.Database.Query.Filter
       Gargantext.Database.Query.Join

run

@@ -2,4 +2,6 @@
 
 figlet "GarganText"
 
-./bin/gargantext_stop; ./bin/gargantext_tmux && tmux a -t gargantext ; ./bin/gargantext_stop
+./bin/scripts/gargantext_stop
+./bin/scripts/gargantext_tmux && tmux a -t gargantext 
+./bin/scripts/gargantext_stop

src/Gargantext/API/Node/Corpus/Subcorpus.hs

+module Gargantext.API.Node.Corpus.Subcorpus where
+
+import Gargantext.Prelude
+
+import Gargantext.API.Errors.Types (BackendInternalError)
+import Gargantext.API.Routes.Named.Corpus (MakeSubcorpusAPI(..), SubcorpusParams(..))
+import Gargantext.Core.NodeStory.Types (HasNodeStoryEnv)
+import Gargantext.Core.NLP (HasNLPServer)
+import Gargantext.Core.Text.Corpus (makeSubcorpusFromQuery)
+import Gargantext.Core.Text.Corpus.Query (RawQuery(..), parseQuery)
+import Gargantext.Core.Types (UserId)
+import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Database.Prelude (DbCmd')
+import Servant.Server.Generic (AsServerT)
+
+
+makeSubcorpus :: ( HasNodeStoryEnv env
+                 , HasNLPServer    env
+                 , DbCmd' env BackendInternalError m
+                 )
+  => UserId
+  -> MakeSubcorpusAPI (AsServerT m)
+makeSubcorpus user = MakeSubcorpusAPI $ \corpusId params -> do
+  case parseQuery (RawQuery $ _subcorpusParams_query params) of
+    Left _  -> return False
+    Right q -> do
+      _ <- makeSubcorpusFromQuery
+             (UserDBId user)
+             corpusId
+             q
+             (_subcorpusParams_reuseParentList params)
+      return True

src/Gargantext/API/Routes/Named/Corpus.hs

@@ -9,14 +9,20 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Gargantext.API.Routes.Named.Corpus (
   -- * Routes types
     CorpusExportAPI(..)
   , AddWithForm(..)
   , AddWithQuery(..)
+  , MakeSubcorpusAPI(..)
+  -- * Others
+  , SubcorpusParams(..)
   ) where
 
+import Data.Aeson.TH (deriveJSON)
+import Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
 import Data.Text (Text)
 import GHC.Generics
 -- import Gargantext.API.Admin.Orchestrator.Types
@@ -24,7 +30,9 @@ import Gargantext.API.Node.Corpus.Export.Types
 import Gargantext.API.Node.Types
 import Gargantext.API.Worker (WorkerAPI)
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Admin.Types.Node
+import Gargantext.Prelude (Bool)
 import Servant
 
 --------------------------------------------------
@@ -53,3 +61,22 @@ newtype AddWithQuery mode = AddWithQuery
                            :> "query"
                            :> NamedRoutes (WorkerAPI '[JSON] WithQuery)
   } deriving Generic
+
+newtype MakeSubcorpusAPI mode = MakeSubcorpusAPI
+  { makeSubcorpusAPI :: mode :- Summary "Make a subcorpus based on a text search"
+                     :> "corpus"
+                     :> Capture "corpus_id" CorpusId
+                     :> "subcorpus"
+                     :> ReqBody '[JSON] SubcorpusParams
+                     :> Post '[JSON] Bool -- was request successful
+  } deriving Generic
+
+data SubcorpusParams = SubcorpusParams
+  { _subcorpusParams_query           :: Text
+  , _subcorpusParams_reuseParentList :: Bool
+  } deriving Generic
+
+$(deriveJSON (unPrefix "_subcorpusParams_") ''SubcorpusParams)
+
+instance ToSchema SubcorpusParams where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_subcorpusParams_")

src/Gargantext/API/Routes/Named/Private.hs

@@ -93,13 +93,14 @@ data GargPrivateAPI' mode = GargPrivateAPI'
   , treeFlatAPI :: mode :- "treeflat" :> Summary "Flat tree endpoint"
                                       :> Capture "tree_id" NodeId
                                       :> NamedRoutes TreeFlatAPI
-  , membersAPI     :: mode :- "members" :> Summary "Team node members" :> NamedRoutes MembersAPI
-  , addWithFormAPI :: mode :- NamedRoutes AddWithForm
-  , addWithQueryEp :: mode :- NamedRoutes AddWithQuery
-  , listGetAPI     :: mode :- NamedRoutes List.GETAPI
-  , listJsonAPI    :: mode :- NamedRoutes List.JSONAPI
-  , listTsvAPI     :: mode :- NamedRoutes List.TSVAPI
-  , shareUrlAPI    :: mode :- "shareurl" :> NamedRoutes ShareURL
+  , membersAPI       :: mode :- "members" :> Summary "Team node members" :> NamedRoutes MembersAPI
+  , addWithFormAPI   :: mode :- NamedRoutes AddWithForm
+  , addWithQueryEp   :: mode :- NamedRoutes AddWithQuery
+  , makeSubcorpusAPI :: mode :- NamedRoutes MakeSubcorpusAPI
+  , listGetAPI       :: mode :- NamedRoutes List.GETAPI
+  , listJsonAPI      :: mode :- NamedRoutes List.JSONAPI
+  , listTsvAPI       :: mode :- NamedRoutes List.TSVAPI
+  , shareUrlAPI      :: mode :- "shareurl" :> NamedRoutes ShareURL
   } deriving Generic
 
 

src/Gargantext/API/Server/Named/Private.hs

@@ -12,6 +12,7 @@ import Gargantext.API.Node
 import Gargantext.API.Node qualified as Tree
 import Gargantext.API.Node.Contact as Contact
 import Gargantext.API.Node.Corpus.Export qualified as CorpusExport
+import Gargantext.API.Node.Corpus.Subcorpus qualified as Subcorpus
 import Gargantext.API.Node.Document.Export (documentExportAPI)
 import Gargantext.API.Node.Phylo.Export qualified as PhyloExport
 import Gargantext.API.Node.ShareURL ( shareURL )
@@ -60,6 +61,7 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
        , membersAPI        = members
        , addWithFormAPI    = addCorpusWithForm (RootId userNodeId)
        , addWithQueryEp    = addCorpusWithQuery (RootId userNodeId)
+       , makeSubcorpusAPI      = Subcorpus.makeSubcorpus userId
        , listGetAPI        = List.getAPI
        , listJsonAPI       = List.jsonAPI
        , listTsvAPI        = List.tsvAPI

src/Gargantext/Core/Text/Corpus.hs

+module Gargantext.Core.Text.Corpus (makeSubcorpusFromQuery, subcorpusEasy) where
+
+import Control.Lens (view)
+import Data.Set.Internal qualified as Set (singleton)
+import Data.Text qualified as T
+import Gargantext.API.Dev (runCmdReplEasy)
+import Gargantext.API.Errors.Types (BackendInternalError(InternalNodeError))
+import Gargantext.Core (Lang(EN))
+import Gargantext.Core.NodeStory.Types (HasNodeStoryEnv)
+import Gargantext.Core.NLP (HasNLPServer)
+import Gargantext.Core.Text.Corpus.Query qualified as Q
+import Gargantext.Core.Text.List.Social (FlowSocialListWith (..), FlowSocialListPriority (..))
+import Gargantext.Core.Text.Ngrams (NgramsType (..))
+import Gargantext.Core.Types.Individu (User (..))
+import Gargantext.Core.Types.Main (ListType (..))
+import Gargantext.Database.Action.Flow (buildSocialList, reIndexWith)
+import Gargantext.Database.Action.Metrics (updateContextScore, updateNgramsOccurrences)
+import Gargantext.Database.Action.Search (searchInCorpus)
+import Gargantext.Database.Action.User (getUserId)
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus, hc_lang)
+import Gargantext.Database.Admin.Types.Node (CorpusId, NodeId(UnsafeMkNodeId), NodeType(..), nodeId2ContextId)
+import Gargantext.Database.Prelude (DBCmd')
+import Gargantext.Database.Query.Facet.Types (facetDoc_id)
+import Gargantext.Database.Query.Table.Node (insertDefaultNode, copyNodeStories, defaultList, getNodeWithType)
+import Gargantext.Database.Query.Table.Node.Document.Add qualified as Document (add)
+import Gargantext.Database.Query.Table.Node.Error (NodeError(NoCorpusFound))
+import Gargantext.Database.Schema.Node (node_hyperdata)
+import Gargantext.Prelude
+
+
+
+-- | A version of the below function for use in the REPL (so you don't need to
+-- manually import tons of constructors etc.)
+subcorpusEasy :: Text -- ^ Username
+              -> Int  -- ^ Original corpus ID
+              -> Text -- ^ Search string
+              -> Bool -- ^ Whether to reuse the parent term list (True) or recompute one from scratch (False)
+              -> IO ()
+subcorpusEasy username cId rawQuery reuseParentList = do
+  let eitherQuery = Q.parseQuery $ Q.RawQuery rawQuery
+  case eitherQuery of
+    Left msg -> print $ "Error parsing query \"" <> rawQuery <> "\": " <> T.pack msg
+    Right query -> void $ runCmdReplEasy $ makeSubcorpusFromQuery (UserName username) (UnsafeMkNodeId cId) query reuseParentList
+
+
+-- | Given a "parent" corpus and a query, search for all docs in the parent
+--   that match the query, and create a corpus from those. The created corpus
+--   is inserted in the tree as a child of the parent corpus.
+--   Creation of subcorpus "Docs" and "Terms" nodes is handled. The terms can be
+--   either copied from the parent corpus or recomputed based on the subcorpus docs.
+makeSubcorpusFromQuery :: ( HasNodeStoryEnv env
+                          , HasNLPServer    env
+                          )
+  => User     -- ^ The corpus owner
+  -> CorpusId -- ^ ID of the parent corpus
+  -> Q.Query  -- ^ The query to determine the subset of documents that will appear in the subcorpus
+  -> Bool     -- ^ Whether to reuse parent term list (True) or compute a new one based only on the documents in the subcorpus (False)
+  -> DBCmd' env BackendInternalError CorpusId -- ^ The child corpus ID
+makeSubcorpusFromQuery user supercorpusId query reuseParentList = do
+  userId <- getUserId user
+  -- Insert the required nodes:
+  -- 1. The subcorpus root (under the original corpus root)
+  subcorpusId <- insertDefaultNode NodeCorpus supercorpusId userId
+  -- 2. The context (aka "Docs", aka "Terms") node (under the subcorpus root)
+  _ <- insertDefaultNode NodeTexts subcorpusId userId
+  -- 3. The terms (aka "List") node
+  subListId <- insertDefaultNode NodeList subcorpusId userId
+  -- Get the ID of the original terms node
+  superListId <- defaultList supercorpusId
+  -- Get ahold of all contexts that match the query, and add them to the subcorpus
+  -- (note that contexts are attached to a *corpus* node, not a *docs* node,
+  -- notwithstanding what you might think from th UI)
+  facetDocs <- searchInCorpus supercorpusId False query Nothing Nothing Nothing
+  _ <- Document.add subcorpusId $ nodeId2ContextId . facetDoc_id <$> facetDocs
+  if reuseParentList
+    -- Either simply copy parent terms...
+    then void $ copyNodeStories superListId subListId
+    -- ... or rebuild a term list from scratch
+    -- TODO Check whether reusing the parent hyperdata is the right thing to do
+    else do
+      -- Get hyperdata from the original corpus
+      supercorpuses <- getNodeWithType supercorpusId NodeCorpus (Proxy :: Proxy HyperdataCorpus)
+      superHyperdata <- case supercorpuses of
+        [supercorpus] -> return $ view node_hyperdata supercorpus
+        _ -> throwError $ InternalNodeError NoCorpusFound
+      buildSocialList
+           (fromMaybe EN $ view hc_lang superHyperdata)
+           user
+           subcorpusId
+           subListId
+           (Just superHyperdata)
+           -- TODO Not completely sure what the following parameter is for
+           -- but I am guessing there should be a dialog to let the user decide
+           -- what it should be
+           (Just (FlowSocialListWithPriority MySelfFirst) :: Maybe FlowSocialListWith)
+  -- In both cases we'll need to reindex our terms list so it matches the contexts
+  -- in the newly created subcorpus
+  reIndexWith subcorpusId subListId NgramsTerms (Set.singleton MapTerm)
+  _ <- updateContextScore      subcorpusId subListId
+  _ <- updateNgramsOccurrences subcorpusId subListId
+  return subcorpusId

src/Gargantext/Core/Text/List.hs

@@ -63,7 +63,8 @@ goodMapListSize :: Int
 goodMapListSize = 350
     
 
--- | TODO improve grouping functions of Authors, Sources, Institutes..
+-- | Consider using `buildSocialList` instead of this function.
+-- TODO improve grouping functions of Authors, Sources, Institutes..
 buildNgramsLists :: ( HasNodeStory env err m
                     , HasNLPServer env
                     , HasTreeError err

src/Gargantext/Database/Action/Flow.hs

@@ -35,6 +35,7 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
   , flowCorpusUser
   , flowAnnuaire
   , insertMasterDocs
+  , buildSocialList
   , saveDocNgramsWith
   , addDocumentsToHyperCorpus
 

src/Gargantext/Database/Admin/Types/Node.hs

@@ -13,7 +13,6 @@ Portability : POSIX
 
 {-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE DeriveAnyClass      #-}
-{-# LANGUAGE DerivingStrategies  #-}
 {-# LANGUAGE DerivingVia         #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE TemplateHaskell     #-}
@@ -39,6 +38,7 @@ import Data.Text (pack, unpack)
 import Data.Text qualified as T
 import Data.Time (UTCTime)
 import Data.TreeDiff
+import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow, field)
 import Fmt ( Buildable(..) )
 import Gargantext.Core (HasDBid(..))
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
@@ -270,10 +270,13 @@ instance ToField NodeId where
   toField (UnsafeMkNodeId n) = toField n
 instance ToRow NodeId where
   toRow (UnsafeMkNodeId i) = [toField i]
+instance FromRow NodeId where
+  fromRow = UnsafeMkNodeId <$> field
+
 
 instance FromField NodeId where
-  fromField field mdata = do
-    n <- UnsafeMkNodeId <$> fromField field mdata
+  fromField fld mdata = do
+    n <- UnsafeMkNodeId <$> fromField fld mdata
     if isPositive n
        then pure n
        else mzero

src/Gargantext/Database/Query.hs

-{-|
-Module      : Gargantext.Database.Query
-Description : Main Tools of Node to the database
-Copyright   : (c) CNRS, 2017-Present
-License     : AGPL + CECILL v3
-Maintainer  : team@gargantext.org
-Stability   : experimental
-Portability : POSIX
--}
-
-module Gargantext.Database.Query
-  where
-
-

src/Gargantext/Database/Query/Table/Node.hs

@@ -59,23 +59,31 @@ module Gargantext.Database.Query.Table.Node
   , deleteNode
   , deleteNodes
 
+  -- * Copying data
+  , copyNode
+  , copyNodeStories
+
   ) where
 
 import Control.Arrow (returnA)
 import Control.Lens (set, view)
 import Data.Aeson ( encode, Value )
+import Data.Bimap ((!>))
 import Database.PostgreSQL.Simple qualified as PGS
 import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Gargantext.API.Errors.Types (BackendInternalError (..))
 import Gargantext.Core ( HasDBid(toDBid) )
 import Gargantext.Core.Types
 import Gargantext.Core.Types.Query (Limit, Offset)
+import Gargantext.Database.Admin.Config ( nodeTypes )
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataAnnuaire, HyperdataCorpus )
 import Gargantext.Database.Admin.Types.Hyperdata.Default ( defaultHyperdata, DefaultHyperdata(..) )
 import Gargantext.Database.Admin.Types.Hyperdata.Folder (HyperdataFolder)
 import Gargantext.Database.Admin.Types.Hyperdata.List ( HyperdataList )
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude ( Hyperdata )
-import Gargantext.Database.Prelude (DBCmd, JSONB, mkCmd, runPGSQuery, runOpaQuery)
+import Gargantext.Database.Prelude (DBCmd, JSONB, mkCmd, execPGSQuery, runPGSQuery, runOpaQuery)
 import Gargantext.Database.Query.Filter (limit', offset')
+import Gargantext.Database.Query.Table.Node.Children (getChildrenById)
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude hiding (sum, head)
@@ -468,3 +476,69 @@ isUserNode userNodeId = (== [PGS.Only True])
         WHERE n.id = ? AND n.typename = ? AND n.parent_id = NULL
     )
 |] (userNodeId, toDBid NodeUser)
+
+-- | Copy a node somewhere else in the tree
+copyNode :: Bool   -- ^ Whether to copy whole subtree (`True`) or just the node (`False`)
+         -> Bool   -- ^ Whether to deal with ngrams and contexts (`True`) or just the data in the `nodes` table (`False`)
+         -> NodeId -- ^ ID of the node to be copied
+         -> NodeId -- ^ ID of the node which will become the parent of the copied node
+         -> DBCmd BackendInternalError NodeId -- ^ ID of the copied node
+copyNode copySubtree smart idToCopy newParentId = if copySubtree
+  -- Recursive copy:
+  then do
+    -- Non-recursively copy the node itself, then recursively copy its children:
+    copiedNode <- copyNode False smart idToCopy newParentId
+    children   <- getChildrenById idToCopy
+    for_ children $ \child -> copyNode True smart child copiedNode
+    return copiedNode
+  -- Single-node (non-recursive) copy:
+  else do
+    newNodes <- runPGSQuery
+      -- Copy node. Should return exactly one ID, that of the new node:
+      [sql|
+        INSERT INTO public.nodes (typename, user_id, parent_id, name, date, hyperdata)
+        SELECT typename, user_id, ?, name, date, hyperdata FROM public.nodes WHERE id = ?
+        RETURNING id;
+      |] (newParentId, idToCopy)
+    case newNodes of -- Check that we got exactly one node back
+      [copiedNode] -> do
+        -- Copy node stories/contexts if applicable
+        when smart $ do
+          nodeToCopy <- getNode idToCopy
+          case nodeTypes !> view node_typename nodeToCopy of
+            NodeList   -> copyNodeStories  idToCopy copiedNode
+            -- Contexts are attached to a corpus node, not to the docs node:
+            NodeCorpus -> copyNodeContexts idToCopy copiedNode
+            _ -> return ()
+        return copiedNode
+      _ -> throwError $ InternalUnexpectedError $ SomeException $ PatternMatchFail $
+             "SQL insert returned zero or more than one node"
+
+
+-- | Given two IDs of terms nodes, copies the node stories of the first into
+-- node stories of the second. This effectively copies the terms from one terms
+-- node to another.
+-- TODO add a check that we are looking at the right type of node?
+copyNodeStories :: NodeId -- ^ The ID of the node whose stories are to be copied
+                -> NodeId -- ^ The ID of the node under which to copy the stories
+                -> DBCmd BackendInternalError ()
+copyNodeStories oldNodeId newNodeId = void $ execPGSQuery
+  [sql|
+    INSERT INTO node_stories
+      (node_id, version, ngrams_type_id, ngrams_id, ngrams_repo_element)
+    SELECT ?, version, ngrams_type_id, ngrams_id, ngrams_repo_element
+    FROM node_stories
+    WHERE node_id = ?;
+  |] (newNodeId, oldNodeId)
+
+-- | Given two IDs of Docs nodes, add to the second the contexts associated to
+-- the first. Functionally, this copies the contexts from the first node to the
+-- second, although the contexts are not technically duplicated in the database.
+copyNodeContexts :: NodeId -- ^ The ID of the node whose contexts are to be "copied"
+                 -> NodeId -- ^ The ID of the node under which to "copy" the contexts
+                 -> DBCmd BackendInternalError ()
+copyNodeContexts oldNodeId newNodeId = void $ execPGSQuery
+  [sql|
+    INSERT INTO node_contexts (node_id, context_id, score, category)
+    SELECT ?, context_id, score, category FROM node_stories WHERE node_id = ?
+  |] (newNodeId, oldNodeId)

src/Gargantext/Database/Query/Table/Node/Children.hs

@@ -8,18 +8,22 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-{-# LANGUAGE Arrows #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE Arrows               #-}
+{-# LANGUAGE QuasiQuotes          #-}
 
 module Gargantext.Database.Query.Table.Node.Children
   where
 
 import Control.Arrow (returnA)
+import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Gargantext.Core ( HasDBid(toDBid) )
 import Gargantext.Core.Types
 import Gargantext.Core.Types.Query (Limit, Offset)
 import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument )
-import Gargantext.Database.Prelude (DBCmd, JSONB, runCountOpaQuery, runOpaQuery)
+import Gargantext.Database.Prelude (DBCmd, JSONB, runCountOpaQuery, runOpaQuery, runPGSQuery)
 import Gargantext.Database.Query.Filter ( limit', offset' )
 import Gargantext.Database.Query.Table.NodeContext ( NodeContextPoly(NodeContext), queryNodeContextTable )
 import Gargantext.Database.Schema.Context
@@ -58,6 +62,14 @@ getChildren pId p t@(Just NodeContact ) maybeOffset maybeLimit = getChildrenCont
 getChildren a b c d e = getChildrenNode a b c d e
 
 
+-- | Get the list of (IDs of) children of a given node (ID)
+getChildrenById :: NodeId             -- ^ ID of the parent node
+                -> DBCmd err [NodeId] -- ^ List of IDs of the children nodes
+getChildrenById parentId = runPGSQuery
+    [sql| SELECT id FROM public.nodes WHERE parent_id = ?; |]
+    parentId
+
+
 getChildrenNode :: (JSONB a, HasDBid NodeType)
             => ParentId
             -> proxy a

src/Gargantext/Database/Query/Table/Node/Update.hs

@@ -73,7 +73,8 @@ update loggedInUserId (Move sourceId targetId) = do
           -> -- both are not read-only, normal move
              move_db_update sourceId targetId
         (False, True)
-          -> (:[]) <$> publish_node (SourceId sourceId) (TargetId targetId) NPP_publish_no_edits_allowed
+          -> do void $ publish_node (SourceId sourceId) (TargetId targetId) NPP_publish_no_edits_allowed
+                move_db_update sourceId targetId
         (True, False)
           -> -- the source is read only. If we are the owner we allow unpublishing.
              -- FIXME(adn) is this check enough?
@@ -82,7 +83,7 @@ update loggedInUserId (Move sourceId targetId) = do
                   True -> do
                     userPublicFolderNode <- getUserRootPublicNode loggedInUserId
                     unpublishNode (SourceId $ sourceId) (TargetId $ _node_id userPublicFolderNode)
-                    pure [ _NodeId $ sourceId]
+                    move_db_update sourceId targetId
                   False -> nodeError (NodeIsReadOnly targetId "logged user is not allowed to move/unpublish a read-only node")
         (True, True)
           -> -- this case is not allowed.

src/Gargantext/Database/Schema/NodeNode.hs

@@ -76,7 +76,7 @@ instance HasDBid NodeNodeCategory where
     NNC_publish <$> lookupDBid x
 
 instance DefaultFromField SqlInt4 (Maybe NodeNodeCategory) where
-    defaultFromField = lookupDBid <$> fromPGSFromField
+    defaultFromField = (lookupDBid =<<) <$> fromPGSFromField
 
 type NodeNode = NodeNodePoly NodeId NodeId (Maybe Double) (Maybe NodeNodeCategory)