Add route for making a subcorpus

gargantext.cabal

@@ -315,6 +315,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
@@ -435,7 +436,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

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

-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators   #-}
 
 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
 import Gargantext.API.Node.Corpus.Export.Types
 import Gargantext.API.Node.Types
 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
 
 --------------------------------------------------
@@ -42,3 +50,22 @@ newtype AddWithQuery mode = AddWithQuery
                            :> "query"
                            :> NamedRoutes (AsyncJobs JobLog '[JSON] WithQuery JobLog)
   } 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

@@ -84,13 +84,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/Database/Admin/Types/Node.hs

@@ -38,10 +38,7 @@ import Data.Text (pack, unpack)
 import Data.Text qualified as T
 import Data.Time (UTCTime)
 import Data.TreeDiff
-import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
-import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
 import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow, field)
-import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
 import Fmt ( Buildable(..) )
 import Gargantext.Core (HasDBid(..))
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)

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
-
-