Stashing WIP

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

@@ -344,10 +344,10 @@ insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
                         (pgNodeId          <$> p)
                         (sqlStrictText          n)
                         (pgUTCTime         <$> d)
-                        (pgJSONB $ cs $ encode h)
+                
+        (pgJSONB $ cs $ encode h)
               ) ns
 -}
-
 insertNodesR :: [NodeWrite] -> DBCmd err [NodeId]
 insertNodesR ns = mkCmd $ \conn ->
   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
@@ -430,3 +430,29 @@ defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId
 
 getListsWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataList]
 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
+
+------------------------------------------------------------------------
+
+copyNode :: (HasNodeError err) => NodeId -> DBCmd err Int64
+copyNode nodeIdToCopy = do
+  nodeToCopy <- getNode nodeIdToCopy
+  _
+
+-- nodeExists :: (HasNodeError err) => NodeId -> DBCmd err Bool
+-- nodeExists nId = (== [PGS.Only True])
+--   <$> runPGSQuery [sql|SELECT true FROM nodes WHERE id = ? |] (PGS.Only nId)
+-- 
+-- getNode :: HasNodeError err => NodeId -> DBCmd err (Node Value)
+-- getNode nId = do
+--   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
+--   case maybeNode of
+--     Nothing -> nodeError (DoesNotExist nId)
+--     Just  r -> pure r
+-- 
+-- getNodeWith :: (HasNodeError err, JSONB a)
+--             => NodeId -> proxy a -> DBCmd err (Node a)
+-- getNodeWith nId _ = do
+--   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
+--   case maybeNode of
+--     Nothing -> nodeError (DoesNotExist nId)
+--     Just  r -> pure r

src/REPL.hs

+module REPL where
+
+import Gargantext.Prelude
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Core.NodeStory.Types (HasNodeStory)
+import Gargantext.API.Dev (runCmdReplBackendErr)
+import Gargantext.API.Errors.Types (BackendInternalError)
+import Gargantext.Core.Types.Individu (User (..))
+import qualified Gargantext.Database.Query.Table.Node.Document.Add as Document (add)
+import Gargantext.Database.Prelude (DbCmd')
+import Gargantext.Database.Admin.Types.Node (CorpusId, nodeId2ContextId, NodeType (..))
+import Gargantext.Database.Action.Search (searchInCorpus)
+import Gargantext.Database.Action.User (getUserId)
+import Gargantext.Database.Query.Table.Node (insertDefaultNode)
+import Gargantext.Database.Query.Facet.Types (facetDoc_id)
+import qualified Gargantext.Core.Text.Corpus.Query as Q
+
+import Gargantext.Core.Text.List (buildNgramsLists)
+import Gargantext.Core.NLP (HasNLPServer)
+import Gargantext.Database.Query.Tree.Error (HasTreeError)
+import Gargantext.Core.Text.List.Group.WithStem (GroupParams (..))
+import Gargantext.Database.Action.Flow (getOrMkRootWithCorpus)
+import Gargantext.Database.Query.Tree.Root (MkCorpusUser (..))
+import Gargantext.API.Admin.Types (HasSettings)
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus)
+import Gargantext.Database.Action.Flow.List (flowList_DbRepo)
+import Gargantext.Core.Types (HasValidationError)
+import Gargantext.Core.Text.List.Social (FlowSocialListWith (..), FlowSocialListPriority (..))
+
+
+execText :: IO (Maybe CorpusId)
+execText = runCmdReplBackendErr $ testSubcorpusFunction "user1" 133 "information" False
+
+testSubcorpusFunction ::
+  forall env m. ( DbCmd'       env BackendInternalError m
+                , HasNodeStory env BackendInternalError m
+                , HasNLPServer env
+                , HasNLPServer env
+                , HasTreeError     BackendInternalError
+                , HasSettings  env
+                )
+  => Text     -- ^ Username
+  -> CorpusId -- ^ Parent corpus ID
+  -> Text     -- ^ The query, in text form
+  -> Bool     -- ^ Whether to reuse parent term list (True) or compute a new one
+              --   based only on the documents in the subcorpus (False)
+  -> m (Maybe CorpusId)
+testSubcorpusFunction username parentId queryText reuseParentList =
+  let eitherQuery = Q.parseQuery . Q.RawQuery $ queryText in
+  case eitherQuery of
+    Left _      -> return Nothing -- putStrLn ("Error parsing query " <> queryText) >> return Nothing -- TODO emit an actual error
+    Right query -> Just <$> makeSubcorpusFromQuery (UserName username) parentId query reuseParentList
+
+
+-- | (WIP) 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 ::
+  forall env err m. ( DbCmd'             env err m
+                    , HasValidationError     err
+                    , HasNodeError           err
+                    , HasNodeStory       env err m
+                    , HasNLPServer       env
+                    , HasTreeError           err
+                    , HasSettings        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)
+  -> m CorpusId -- ^ The child corpus ID
+makeSubcorpusFromQuery user parentId query reuseParentList = do
+  userId      <- getUserId user
+  subcorpusId <- insertDefaultNode NodeCorpus parentId userId
+  (_, _, masterCorpusId) <- getOrMkRootWithCorpus MkCorpusUserMaster (Nothing :: Maybe HyperdataCorpus)
+  -- Get ahold of all documents that match the query
+  facetDocs   <- searchInCorpus parentId False query Nothing Nothing Nothing
+  -- Create a subcorpus node with all the documents
+  _ <- Document.add subcorpusId $ nodeId2ContextId . facetDoc_id <$> facetDocs
+  -- Create nodes for docs and terms as children of the subcorpus
+  void $ insertDefaultNode NodeTexts subcorpusId userId
+  listId <- insertDefaultNode NodeList subcorpusId userId
+  -- Either simply copy parent terms... (TODO)
+  if reuseParentList then return ()
+  -- ... or rebuild a term list from scratch
+  else do
+    ngrams <- buildNgramsLists
+                user
+                subcorpusId
+                masterCorpusId
+                (Just (FlowSocialListWithPriority MySelfFirst) :: Maybe FlowSocialListWith)
+                GroupIdentity
+    -- Save computed list
+    _ <- flowList_DbRepo listId ngrams
+    return ()
+  -- Reindex 
+  reIndexWith subcorpusId listId NgramsType
+            -- CorpusId
+            -- ListId
+            -- NgramsType
+            -- Set ListType
+            -- m ()
+  return subcorpusId
+
+
+-- TODO
+-- Permettre de (mettre les 2 en option) :
+-- [X] 1a. relancer le buildNgramsLists (cf. module Flow)
+-- [ ] 1b. ou copier la liste
+-- Ajouter l'étape de réindexation reIndexWith
+-- [ ] 2. générer un graphe