Commit 65debf70 authored by Alexandre Delanoë's avatar Alexandre Delanoë

[Merge]

parents 7d98c7bc 8672282b
...@@ -11,14 +11,16 @@ import Data.Proxy ...@@ -11,14 +11,16 @@ import Data.Proxy
import Data.Swagger hiding (URL, url, port) import Data.Swagger hiding (URL, url, port)
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics hiding (to) import GHC.Generics hiding (to)
import Gargantext.Core.Types (TODO(..)) import Servant
import Gargantext.Prelude
import Servant.Job.Async import Servant.Job.Async
import Servant.Job.Types import Servant.Job.Types
import Servant.Job.Utils (jsonOptions) import Servant.Job.Utils (jsonOptions)
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary import Test.QuickCheck.Arbitrary
import Gargantext.Core.Types (TODO(..))
import Gargantext.Prelude
------------------------------------------------------------------------ ------------------------------------------------------------------------
instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
arbitrary = panic "TODO" arbitrary = panic "TODO"
...@@ -126,3 +128,7 @@ instance ToParamSchema Limit -- where ...@@ -126,3 +128,7 @@ instance ToParamSchema Limit -- where
type ScrapersEnv = JobEnv JobLog JobLog type ScrapersEnv = JobEnv JobLog JobLog
type ScraperAPI = AsyncJobsAPI JobLog ScraperInput JobLog type ScraperAPI = AsyncJobsAPI JobLog ScraperInput JobLog
------------------------------------------------------------------------
type AsyncJobs event ctI input output =
AsyncJobsAPI' 'Unsafe 'Safe ctI '[JSON] Maybe event input output
...@@ -22,7 +22,13 @@ import Data.Map (Map, toList, fromList) ...@@ -22,7 +22,13 @@ import Data.Map (Map, toList, fromList)
import Data.Swagger (ToSchema, declareNamedSchema, genericDeclareNamedSchema) import Data.Swagger (ToSchema, declareNamedSchema, genericDeclareNamedSchema)
import Data.Text (Text, concat, pack) import Data.Text (Text, concat, pack)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Gargantext.API.Node.Corpus.New import Network.HTTP.Media ((//), (/:))
import Servant
import Servant.Job.Async
import Servant.Job.Utils (jsonOptions)
import Web.FormUrlEncoded (FromForm)
import Gargantext.Prelude
import Gargantext.API.Node.Corpus.New.File (FileType(..)) import Gargantext.API.Node.Corpus.New.File (FileType(..))
import Gargantext.API.Ngrams import Gargantext.API.Ngrams
import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
...@@ -31,12 +37,6 @@ import Gargantext.Core.Utils.Prefix (unPrefixSwagger) ...@@ -31,12 +37,6 @@ import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
import Gargantext.Database.Action.Flow (FlowCmdM) import Gargantext.Database.Action.Flow (FlowCmdM)
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Schema.Ngrams (NgramsType(..), ngramsTypes) import Gargantext.Database.Schema.Ngrams (NgramsType(..), ngramsTypes)
import Gargantext.Prelude
import Network.HTTP.Media ((//), (/:))
import Servant
import Servant.Job.Async
import Servant.Job.Utils (jsonOptions)
import Web.FormUrlEncoded (FromForm)
------------------------------------------------------------------------ ------------------------------------------------------------------------
type NgramsList = (Map NgramsType (Versioned NgramsTableMap)) type NgramsList = (Map NgramsType (Versioned NgramsTableMap))
......
...@@ -150,6 +150,7 @@ type NodeAPI a = Get '[JSON] (Node a) ...@@ -150,6 +150,7 @@ type NodeAPI a = Get '[JSON] (Node a)
:<|> "unpublish" :> Share.Unpublish :<|> "unpublish" :> Share.Unpublish
:<|> "file" :> FileApi :<|> "file" :> FileApi
:<|> "async" :> FileAsyncApi
-- TODO-ACCESS: check userId CanRenameNode nodeId -- TODO-ACCESS: check userId CanRenameNode nodeId
-- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited... -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
...@@ -228,6 +229,7 @@ nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode ...@@ -228,6 +229,7 @@ nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode
:<|> Share.unPublish id' :<|> Share.unPublish id'
:<|> fileApi uId id' :<|> fileApi uId id'
:<|> fileAsyncApi uId id'
------------------------------------------------------------------------ ------------------------------------------------------------------------
......
...@@ -29,12 +29,12 @@ import Data.Maybe (Maybe(..)) ...@@ -29,12 +29,12 @@ import Data.Maybe (Maybe(..))
import Data.Swagger import Data.Swagger
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..)) import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Settings (HasSettings) import Gargantext.API.Admin.Settings (HasSettings)
import Gargantext.API.Node import Gargantext.API.Node
import Gargantext.API.Node.Corpus.New (AsyncJobs)
import Gargantext.API.Prelude (GargServer, simuLogs) import Gargantext.API.Prelude (GargServer, simuLogs)
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Terms (TermType(..))
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Flow (flow) import Gargantext.Database.Action.Flow (flow)
import Gargantext.Database.Action.Flow.Types (FlowCmdM) import Gargantext.Database.Action.Flow.Types (FlowCmdM)
...@@ -42,7 +42,6 @@ import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAnnuaire(..), Hyperda ...@@ -42,7 +42,6 @@ import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAnnuaire(..), Hyperda
import Gargantext.Database.Admin.Types.Hyperdata.Contact (hyperdataContact) import Gargantext.Database.Admin.Types.Hyperdata.Contact (hyperdataContact)
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Prelude (($), liftBase, (.), printDebug, pure) import Gargantext.Prelude (($), liftBase, (.), printDebug, pure)
import Gargantext.Core.Text.Terms (TermType(..))
import Servant import Servant
import Servant.Job.Async (JobFunction(..), serveJobsAPI) import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
......
...@@ -19,18 +19,19 @@ import Data.Aeson ...@@ -19,18 +19,19 @@ import Data.Aeson
import Data.Swagger import Data.Swagger
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.Core (Lang(..))
import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
import Gargantext.Database.Action.Flow (FlowCmdM) -- flowAnnuaire
import Gargantext.Database.Admin.Types.Node (AnnuaireId)
import Gargantext.Prelude
import Servant import Servant
import Servant.Job.Core import Servant.Job.Core
import Servant.Job.Types import Servant.Job.Types
import Servant.Job.Utils (jsonOptions) import Servant.Job.Utils (jsonOptions)
import Web.FormUrlEncoded (FromForm) import Web.FormUrlEncoded (FromForm)
import qualified Gargantext.API.Node.Corpus.New.File as NewFile import qualified Gargantext.API.Node.Corpus.New.File as NewFile
import Gargantext.API.Admin.Orchestrator.Types hiding (AsyncJobs)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
import Gargantext.Database.Action.Flow (FlowCmdM) -- flowAnnuaire
import Gargantext.Database.Admin.Types.Node (AnnuaireId)
import Gargantext.Prelude
type Api = Summary "New Annuaire endpoint" type Api = Summary "New Annuaire endpoint"
......
...@@ -14,7 +14,6 @@ New corpus means either: ...@@ -14,7 +14,6 @@ New corpus means either:
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.API.Node.Corpus.New module Gargantext.API.Node.Corpus.New
where where
...@@ -22,30 +21,25 @@ module Gargantext.API.Node.Corpus.New ...@@ -22,30 +21,25 @@ module Gargantext.API.Node.Corpus.New
import Control.Lens hiding (elements, Empty) import Control.Lens hiding (elements, Empty)
import Data.Aeson import Data.Aeson
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BSB64
import Data.Either import Data.Either
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Swagger import Data.Swagger
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Servant import Servant
import Servant.Job.Core
import Servant.Job.Types
import Servant.Job.Utils (jsonOptions) import Servant.Job.Utils (jsonOptions)
-- import Servant.Multipart -- import Servant.Multipart
-- import Test.QuickCheck (elements) -- import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary import Test.QuickCheck.Arbitrary
import Web.FormUrlEncoded (FromForm)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..)) import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import qualified Gargantext.API.Admin.Orchestrator.Types as T import qualified Gargantext.API.Admin.Orchestrator.Types as T
import Gargantext.API.Admin.Settings (HasSettings) import Gargantext.API.Admin.Settings (HasSettings)
import Gargantext.API.Node.Corpus.New.File import Gargantext.API.Node.Corpus.New.File
import Gargantext.API.Node.Types
import Gargantext.Core (Lang(..){-, allLangs-}) import Gargantext.Core (Lang(..){-, allLangs-})
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
...@@ -163,49 +157,6 @@ instance FromJSON WithQuery where ...@@ -163,49 +157,6 @@ instance FromJSON WithQuery where
instance ToSchema WithQuery where instance ToSchema WithQuery where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wq_") declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wq_")
-------------------------------------------------------
data NewWithForm = NewWithForm
{ _wf_filetype :: !FileType
, _wf_data :: !Text
, _wf_lang :: !(Maybe Lang)
, _wf_name :: !Text
} deriving (Eq, Show, Generic)
makeLenses ''NewWithForm
instance FromForm NewWithForm
instance FromJSON NewWithForm where
parseJSON = genericParseJSON $ jsonOptions "_wf_"
instance ToSchema NewWithForm where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
-------------------------------------------------------
data NewWithFile = NewWithFile
{ _wfi_b64_data :: !Text
, _wfi_lang :: !(Maybe Lang)
, _wfi_name :: !Text
} deriving (Eq, Show, Generic)
makeLenses ''NewWithFile
instance FromForm NewWithFile
instance FromJSON NewWithFile where
parseJSON = genericParseJSON $ jsonOptions "_wfi_"
instance ToSchema NewWithFile where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wfi_")
instance GPU.SaveFile NewWithFile where
saveFile' fp (NewWithFile b64d _ _) = do
let eDecoded = BSB64.decode $ TE.encodeUtf8 b64d
case eDecoded of
Left err -> panic $ T.pack $ "Error decoding: " <> err
Right decoded -> BS.writeFile fp decoded
-- BS.writeFile fp $ BSB64.decodeLenient $ TE.encodeUtf8 b64d
--instance GPU.ReadFile NewWithFile where
-- readFile' = TIO.readFile
------------------------------------------------------------------------
type AsyncJobs event ctI input output =
AsyncJobsAPI' 'Unsafe 'Safe ctI '[JSON] Maybe event input output
------------------------------------------------------------------------ ------------------------------------------------------------------------
type AddWithQuery = Summary "Add with Query to corpus endpoint" type AddWithQuery = Summary "Add with Query to corpus endpoint"
......
...@@ -26,11 +26,7 @@ import Data.Monoid (mempty) ...@@ -26,11 +26,7 @@ import Data.Monoid (mempty)
import Data.Swagger import Data.Swagger
import Data.Text (Text()) import Data.Text (Text())
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Gargantext.API.Ngrams (TODO)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude -- (Cmd, CmdM)
import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Hash (hash)
import Servant import Servant
import Servant.Multipart import Servant.Multipart
import Servant.Swagger (HasSwagger(toSwagger)) import Servant.Swagger (HasSwagger(toSwagger))
...@@ -38,6 +34,12 @@ import Servant.Swagger.Internal ...@@ -38,6 +34,12 @@ import Servant.Swagger.Internal
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Gargantext.API.Ngrams (TODO)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude -- (Cmd, CmdM)
import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Hash (hash)
------------------------------------------------------------- -------------------------------------------------------------
type Hash = Text type Hash = Text
data FileType = CSV data FileType = CSV
......
...@@ -18,17 +18,25 @@ import qualified Network.HTTP.Media as M ...@@ -18,17 +18,25 @@ import qualified Network.HTTP.Media as M
import Network.Wai.Application.Static import Network.Wai.Application.Static
import Servant import Servant
import Servant.API.Raw (Raw) import Servant.API.Raw (Raw)
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import Servant.Job.Core
import Servant.Job.Types
import Servant.Job.Utils (jsonOptions)
import Servant.Server.Internal import Servant.Server.Internal
import Gargantext.Prelude import Gargantext.Prelude
import qualified Gargantext.Prelude.Utils as GPU import qualified Gargantext.Prelude.Utils as GPU
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Settings (HasSettings) import Gargantext.API.Admin.Settings (HasSettings)
import Gargantext.API.Node.Types
import Gargantext.API.Prelude import Gargantext.API.Prelude
import Gargantext.Database.Action.Flow.Types import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Types.Hyperdata.File import Gargantext.Database.Admin.Types.Hyperdata.File
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.Node (getNodeWith) import Gargantext.Database.Query.Table.Node (getNodeWith)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata) import Gargantext.Database.Schema.Node (node_hyperdata)
data RESPONSE deriving Typeable data RESPONSE deriving Typeable
...@@ -89,3 +97,55 @@ fileDownload uId nId = do ...@@ -89,3 +97,55 @@ fileDownload uId nId = do
-- let settings = embeddedSettings [("", "hello")] -- let settings = embeddedSettings [("", "hello")]
-- Tagged $ staticApp settings -- Tagged $ staticApp settings
type FileAsyncApi = Summary "File Async Api"
:> "file"
:> "add"
:> AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog
fileAsyncApi :: UserId -> NodeId -> GargServer FileAsyncApi
fileAsyncApi uId nId =
serveJobsAPI $
JobFunction (\i l ->
let
log' x = do
printDebug "addWithFile" x
liftBase $ l x
in addWithFile uId nId i log')
addWithFile :: (HasSettings env, FlowCmdM env err m)
=> UserId
-> NodeId
-> NewWithFile
-> (JobLog -> m ())
-> m JobLog
addWithFile uId nId nwf@(NewWithFile _d _l fName) logStatus = do
printDebug "[addWithFile] Uploading file: " nId
logStatus JobLog { _scst_succeeded = Just 0
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_events = Just []
}
fPath <- GPU.writeFile nwf
printDebug "[addWithFile] File saved as: " fPath
nIds <- mkNodeWithParent NodeFile (Just nId) uId fName
_ <- case nIds of
[nId'] -> do
node <- getNodeWith nId' (Proxy :: Proxy HyperdataFile)
let hl = node ^. node_hyperdata
_ <- updateHyperdata nId' $ hl { _hff_name = fName
, _hff_path = pack fPath }
printDebug "[addWithFile] Created node with id: " nId'
_ -> pure ()
printDebug "[addWithFile] File upload finished: " nId
pure $ JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 0
, _scst_events = Just []
}
...@@ -30,8 +30,7 @@ import Test.QuickCheck (elements) ...@@ -30,8 +30,7 @@ import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary import Test.QuickCheck.Arbitrary
import Web.FormUrlEncoded (FromForm) import Web.FormUrlEncoded (FromForm)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..)) import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Node.Corpus.New (AsyncJobs)
import Gargantext.API.Prelude import Gargantext.API.Prelude
import Gargantext.Database.Action.Flow.Types import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Node import Gargantext.Database.Action.Node
......
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Node.Types where
import Control.Lens hiding (elements, Empty)
import Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BSB64
import Data.Either
import Data.Swagger
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import GHC.Generics (Generic)
import Servant.Job.Utils (jsonOptions)
import Web.FormUrlEncoded (FromForm)
import Gargantext.Core (Lang(..){-, allLangs-})
import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
import Gargantext.Prelude
import qualified Gargantext.Prelude.Utils as GPU
import Gargantext.API.Node.Corpus.New.File (FileType)
-------------------------------------------------------
data NewWithForm = NewWithForm
{ _wf_filetype :: !FileType
, _wf_data :: !Text
, _wf_lang :: !(Maybe Lang)
, _wf_name :: !Text
} deriving (Eq, Show, Generic)
makeLenses ''NewWithForm
instance FromForm NewWithForm
instance FromJSON NewWithForm where
parseJSON = genericParseJSON $ jsonOptions "_wf_"
instance ToSchema NewWithForm where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
-------------------------------------------------------
data NewWithFile = NewWithFile
{ _wfi_b64_data :: !Text
, _wfi_lang :: !(Maybe Lang)
, _wfi_name :: !Text
} deriving (Eq, Show, Generic)
makeLenses ''NewWithFile
instance FromForm NewWithFile
instance FromJSON NewWithFile where
parseJSON = genericParseJSON $ jsonOptions "_wfi_"
instance ToSchema NewWithFile where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wfi_")
instance GPU.SaveFile NewWithFile where
saveFile' fp (NewWithFile b64d _ _) = do
let eDecoded = BSB64.decode $ TE.encodeUtf8 b64d
case eDecoded of
Left err -> panic $ T.pack $ "Error decoding: " <> err
Right decoded -> BS.writeFile fp decoded
-- BS.writeFile fp $ BSB64.decodeLenient $ TE.encodeUtf8 b64d
--instance GPU.ReadFile NewWithFile where
-- readFile' = TIO.readFile
...@@ -20,24 +20,21 @@ import Data.Aeson ...@@ -20,24 +20,21 @@ import Data.Aeson
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
import Data.Swagger import Data.Swagger
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Gargantext.Prelude import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
import Gargantext.API.Admin.Settings (HasSettings) import Gargantext.API.Admin.Settings (HasSettings)
import Gargantext.API.Node.Corpus.New (AsyncJobs)
import Gargantext.API.Prelude (GargServer, simuLogs) import Gargantext.API.Prelude (GargServer, simuLogs)
import Gargantext.Core.Viz.Graph.API (recomputeGraph)
import Gargantext.Core.Viz.Graph.Distances (GraphMetric(..), Distance(..))
import Gargantext.Database.Action.Flow.Pairing (pairing) import Gargantext.Database.Action.Flow.Pairing (pairing)
import Gargantext.Database.Action.Flow.Types (FlowCmdM) import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Prelude (Ord, Eq, (<$>), ($), liftBase, (.), printDebug, pure) import Gargantext.Prelude (Ord, Eq, (<$>), ($), liftBase, (.), printDebug, pure, show, cs, (<>), panic)
import Gargantext.Core.Viz.Graph.API (recomputeGraph)
import Gargantext.Core.Viz.Graph.Distances (GraphMetric(..), Distance(..))
import Prelude (Enum, Bounded, minBound, maxBound) import Prelude (Enum, Bounded, minBound, maxBound)
import Servant import Servant
import Servant.Job.Async (JobFunction(..), serveJobsAPI) import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary import Test.QuickCheck.Arbitrary
------------------------------------------------------------------------ ------------------------------------------------------------------------
type API = Summary " Update node according to NodeType params" type API = Summary " Update node according to NodeType params"
:> AsyncJobs JobLog '[JSON] UpdateNodeParams JobLog :> AsyncJobs JobLog '[JSON] UpdateNodeParams JobLog
......
...@@ -33,6 +33,10 @@ import Crypto.JOSE.Error as Jose ...@@ -33,6 +33,10 @@ import Crypto.JOSE.Error as Jose
import Data.Aeson.Types import Data.Aeson.Types
import Data.Typeable import Data.Typeable
import Data.Validity import Data.Validity
import Servant
import Servant.Job.Async
import Servant.Job.Core (HasServerError(..), serverError)
import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Settings import Gargantext.API.Admin.Settings
import Gargantext.API.Ngrams import Gargantext.API.Ngrams
...@@ -41,9 +45,6 @@ import Gargantext.Database.Prelude ...@@ -41,9 +45,6 @@ import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..)) import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
import Gargantext.Database.Query.Tree import Gargantext.Database.Query.Tree
import Gargantext.Prelude import Gargantext.Prelude
import Servant
import Servant.Job.Async (HasJobEnv)
import Servant.Job.Core (HasServerError(..), serverError)
class HasJoseError e where class HasJoseError e where
_JoseError :: Prism' e Jose.Error _JoseError :: Prism' e Jose.Error
......
...@@ -24,6 +24,7 @@ module Gargantext.API.Routes ...@@ -24,6 +24,7 @@ module Gargantext.API.Routes
where where
--------------------------------------------------------------------- ---------------------------------------------------------------------
-- import qualified Gargantext.API.Search as Search
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Data.Text (Text) import Data.Text (Text)
import Data.Validity import Data.Validity
...@@ -33,29 +34,27 @@ import Gargantext.API.Count (CountAPI, count, Query) ...@@ -33,29 +34,27 @@ import Gargantext.API.Count (CountAPI, count, Query)
import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableDoc) import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableDoc)
import Gargantext.API.Node import Gargantext.API.Node
import Gargantext.API.Prelude import Gargantext.API.Prelude
-- import qualified Gargantext.API.Search as Search
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Viz.Graph.API
import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Admin.Types.Node (NodeId, CorpusId, AnnuaireId) import Gargantext.Database.Admin.Types.Node (NodeId, CorpusId, AnnuaireId)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Viz.Graph.API
import Servant import Servant
import Servant.Auth as SA import Servant.Auth as SA
import Servant.Auth.Swagger () import Servant.Auth.Swagger ()
import Servant.Job.Async import Servant.Job.Async
import Servant.Swagger.UI import Servant.Swagger.UI
import qualified Gargantext.API.Ngrams.List as List import qualified Gargantext.API.Ngrams.List as List
import qualified Gargantext.API.Node.Contact as Contact
import qualified Gargantext.API.Node.Corpus.Annuaire as Annuaire import qualified Gargantext.API.Node.Corpus.Annuaire as Annuaire
import qualified Gargantext.API.Node.Corpus.Export as Export import qualified Gargantext.API.Node.Corpus.Export as Export
import qualified Gargantext.API.Node.Corpus.New as New import qualified Gargantext.API.Node.Corpus.New as New
import qualified Gargantext.API.Public as Public import qualified Gargantext.API.Public as Public
import qualified Gargantext.API.Node.Contact as Contact
type GargAPI = "api" :> Summary "API " :> GargAPIVersion type GargAPI = "api" :> Summary "API " :> GargAPIVersion
-- | TODO :<|> Summary "Latest API" :> GargAPI' -- | TODO :<|> Summary "Latest API" :> GargAPI'
type GargAPIVersion = "v1.0" type GargAPIVersion = "v1.0"
:> Summary "Garg API Version " :> Summary "Garg API Version "
:> GargAPI' :> GargAPI'
......
...@@ -23,12 +23,12 @@ module Gargantext.Core.Text.Metrics.TFICF ( TFICF ...@@ -23,12 +23,12 @@ module Gargantext.Core.Text.Metrics.TFICF ( TFICF
) )
where where
import Data.Map.Strict (Map, toList)
import Data.Text (Text) import Data.Text (Text)
import Gargantext.Prelude
import Gargantext.Core.Types (Ordering(..)) import Gargantext.Core.Types (Ordering(..))
import Data.Map.Strict (Map, toList) import Gargantext.Prelude
import qualified Data.Ord as DO (Down(..))
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Ord as DO (Down(..))
path :: Text path :: Text
path = "[G.T.Metrics.TFICF]" path = "[G.T.Metrics.TFICF]"
......
...@@ -20,17 +20,19 @@ import Control.Lens (makeLenses) ...@@ -20,17 +20,19 @@ import Control.Lens (makeLenses)
import Data.ByteString.Lazy as DBL (readFile, writeFile) import Data.ByteString.Lazy as DBL (readFile, writeFile)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import GHC.IO (FilePath) import GHC.IO (FilePath)
import Gargantext.Core.Types (ListId)
import Gargantext.Database.Admin.Types.Hyperdata.Prelude
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Core.Viz.Graph.Distances (GraphMetric)
import Gargantext.Prelude
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import qualified Data.Aeson as DA import qualified Data.Aeson as DA
import qualified Data.Text as T import qualified Data.Text as T
import qualified Text.Read as T import qualified Text.Read as T
import Gargantext.Core.Types (ListId)
import Gargantext.Database.Admin.Types.Hyperdata.Prelude
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Core.Viz.Graph.Distances (GraphMetric)
import Gargantext.Prelude
data TypeNode = Terms | Unknown data TypeNode = Terms | Unknown
deriving (Show, Generic) deriving (Show, Generic)
...@@ -97,12 +99,13 @@ makeLenses ''ListForGraph ...@@ -97,12 +99,13 @@ makeLenses ''ListForGraph
-- --
data GraphMetadata = data GraphMetadata =
GraphMetadata { _gm_title :: Text -- title of the graph GraphMetadata { _gm_title :: Text -- title of the graph
, _gm_metric :: GraphMetric , _gm_metric :: GraphMetric
, _gm_corpusId :: [NodeId] -- we can map with different corpus , _gm_corpusId :: [NodeId] -- we can map with different corpus
, _gm_legend :: [LegendField] -- legend of the Graph , _gm_legend :: [LegendField] -- legend of the Graph
, _gm_list :: ListForGraph , _gm_list :: ListForGraph
-- , _gm_version :: Int , _gm_startForceAtlas :: Bool
-- , _gm_version :: Int
} }
deriving (Show, Generic) deriving (Show, Generic)
$(deriveJSON (unPrefix "_gm_") ''GraphMetadata) $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
...@@ -122,7 +125,7 @@ makeLenses ''Graph ...@@ -122,7 +125,7 @@ makeLenses ''Graph
instance ToSchema Graph where instance ToSchema Graph where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_") declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
-- | Intances for the mack -- | Intances for the mock
instance Arbitrary Graph where instance Arbitrary Graph where
arbitrary = elements $ [defaultGraph] arbitrary = elements $ [defaultGraph]
...@@ -158,15 +161,28 @@ data GraphV3 = GraphV3 { go_links :: [EdgeV3] ...@@ -158,15 +161,28 @@ data GraphV3 = GraphV3 { go_links :: [EdgeV3]
deriving (Show, Generic) deriving (Show, Generic)
$(deriveJSON (unPrefix "go_") ''GraphV3) $(deriveJSON (unPrefix "go_") ''GraphV3)
-----------------------------------------------------------
data Camera = Camera { _camera_ratio :: Double
, _camera_x :: Double
, _camera_y :: Double }
deriving (Show, Generic)
$(deriveJSON (unPrefix "_camera_") ''Camera)
makeLenses ''Camera
instance ToSchema Camera where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_camera_")
----------------------------------------------------------- -----------------------------------------------------------
data HyperdataGraph = data HyperdataGraph =
HyperdataGraph { _hyperdataGraph :: !(Maybe Graph) HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
, _hyperdataCamera :: !(Maybe Camera)
} deriving (Show, Generic) } deriving (Show, Generic)
$(deriveJSON (unPrefix "") ''HyperdataGraph) $(deriveJSON (unPrefix "_") ''HyperdataGraph)
instance ToSchema HyperdataGraph where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
defaultHyperdataGraph :: HyperdataGraph defaultHyperdataGraph :: HyperdataGraph
defaultHyperdataGraph = HyperdataGraph Nothing defaultHyperdataGraph = HyperdataGraph Nothing Nothing
instance Hyperdata HyperdataGraph instance Hyperdata HyperdataGraph
...@@ -180,6 +196,23 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataGraph ...@@ -180,6 +196,23 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
where where
queryRunnerColumnDefault = fieldQueryRunnerColumn queryRunnerColumnDefault = fieldQueryRunnerColumn
-----------------------------------------------------------
-- This type is used to return graph via API
-- hyperdataGraphAPI field is not a Maybe anymore – graph is always computed
data HyperdataGraphAPI =
HyperdataGraphAPI { _hyperdataAPIGraph :: Graph
, _hyperdataAPICamera :: !(Maybe Camera)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_hyperdataAPI") ''HyperdataGraphAPI)
instance ToSchema HyperdataGraphAPI where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hyperdataAPI")
makeLenses ''HyperdataGraphAPI
instance FromField HyperdataGraphAPI
where
fromField = fromField'
----------------------------------------------------------- -----------------------------------------------------------
graphV3ToGraph :: GraphV3 -> Graph graphV3ToGraph :: GraphV3 -> Graph
graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
......
...@@ -36,15 +36,17 @@ import Gargantext.API.Ngrams.Tools ...@@ -36,15 +36,17 @@ import Gargantext.API.Ngrams.Tools
import Gargantext.API.Prelude import Gargantext.API.Prelude
import Gargantext.Core.Types.Main import Gargantext.Core.Types.Main
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser) import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Config import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd) import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Query.Table.Node import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.User (getNodeUser)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Ngrams import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata) import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata, node_name, node_userId)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Viz.Graph import Gargantext.Core.Viz.Graph
import Gargantext.Core.Viz.Graph.GEXF () import Gargantext.Core.Viz.Graph.GEXF ()
...@@ -54,9 +56,12 @@ import Gargantext.Core.Viz.Graph.Distances (Distance(..), GraphMetric(..)) ...@@ -54,9 +56,12 @@ import Gargantext.Core.Viz.Graph.Distances (Distance(..), GraphMetric(..))
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | There is no Delete specific API for Graph since it can be deleted -- | There is no Delete specific API for Graph since it can be deleted
-- as simple Node. -- as simple Node.
type GraphAPI = Get '[JSON] Graph type GraphAPI = Get '[JSON] HyperdataGraphAPI
:<|> "async" :> GraphAsyncAPI
:<|> "clone"
:> ReqBody '[JSON] HyperdataGraphAPI
:> Post '[JSON] NodeId
:<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph) :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
:<|> GraphAsyncAPI
:<|> "versions" :> GraphVersionsAPI :<|> "versions" :> GraphVersionsAPI
data GraphVersions = data GraphVersions =
...@@ -69,16 +74,18 @@ instance ToJSON GraphVersions ...@@ -69,16 +74,18 @@ instance ToJSON GraphVersions
instance ToSchema GraphVersions instance ToSchema GraphVersions
graphAPI :: UserId -> NodeId -> GargServer GraphAPI graphAPI :: UserId -> NodeId -> GargServer GraphAPI
graphAPI u n = getGraph u n graphAPI u n = getGraph u n
:<|> getGraphGexf u n :<|> graphAsync u n
:<|> graphAsync u n :<|> graphClone u n
:<|> graphVersionsAPI u n :<|> getGraphGexf u n
:<|> graphVersionsAPI u n
------------------------------------------------------------------------ ------------------------------------------------------------------------
getGraph :: UserId -> NodeId -> GargNoServer Graph getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
getGraph _uId nId = do getGraph _uId nId = do
nodeGraph <- getNodeWith nId HyperdataGraph nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
repo <- getRepo repo <- getRepo
...@@ -90,21 +97,23 @@ getGraph _uId nId = do ...@@ -90,21 +97,23 @@ getGraph _uId nId = do
case graph of case graph of
Nothing -> do Nothing -> do
graph' <- computeGraph cId Conditional NgramsTerms repo graph' <- computeGraph cId Conditional NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph') mt <- defaultGraphMetadata cId "Title" repo
pure $ trace "[G.V.G.API] Graph empty, computing" graph' let graph'' = set graph_metadata (Just mt) graph'
let hg = HyperdataGraphAPI graph'' camera
_ <- updateHyperdata nId hg
pure $ trace "[G.V.G.API] Graph empty, computing" hg
Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" graph' Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
HyperdataGraphAPI graph' camera
recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
recomputeGraph _uId nId d = do recomputeGraph _uId nId d = do
nodeGraph <- getNodeWith nId HyperdataGraph nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let listVersion = graph ^? _Just let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
. graph_metadata let graphMetadata = graph ^? _Just . graph_metadata . _Just
. _Just let listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
. gm_list
. lfg_version
repo <- getRepo repo <- getRepo
let v = repo ^. r_version let v = repo ^. r_version
...@@ -115,15 +124,18 @@ recomputeGraph _uId nId d = do ...@@ -115,15 +124,18 @@ recomputeGraph _uId nId d = do
case graph of case graph of
Nothing -> do Nothing -> do
graph' <- computeGraph cId d NgramsTerms repo graph' <- computeGraph cId d NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph') mt <- defaultGraphMetadata cId "Title" repo
pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph' let graph'' = set graph_metadata (Just mt) graph'
_ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
Just graph' -> if listVersion == Just v Just graph' -> if listVersion == Just v
then pure graph' then pure graph'
else do else do
graph'' <- computeGraph cId d NgramsTerms repo graph'' <- computeGraph cId d NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph'') let graph''' = set graph_metadata graphMetadata graph''
pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'' _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
-- TODO use Database Monad only here ? -- TODO use Database Monad only here ?
...@@ -147,49 +159,61 @@ computeGraph cId d nt repo = do ...@@ -147,49 +159,61 @@ computeGraph cId d nt repo = do
graph <- liftBase $ cooc2graph d 0 myCooc graph <- liftBase $ cooc2graph d 0 myCooc
pure graph
let metadata = GraphMetadata "Title"
Order1
[cId]
[ LegendField 1 "#FFF" "Cluster1"
, LegendField 2 "#FFF" "Cluster2"
, LegendField 3 "#FFF" "Cluster3"
, LegendField 4 "#FFF" "Cluster4"
]
(ListForGraph lId (repo ^. r_version))
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
pure $ set graph_metadata (Just metadata) graph defaultGraphMetadata :: HasNodeError err
=> CorpusId
-> Text
-> NgramsRepo
-> Cmd err GraphMetadata
defaultGraphMetadata cId t repo = do
lId <- defaultList cId
pure $ GraphMetadata {
_gm_title = t
, _gm_metric = Order1
, _gm_corpusId = [cId]
, _gm_legend = [
LegendField 1 "#FFF" "Cluster1"
, LegendField 2 "#FFF" "Cluster2"
, LegendField 3 "#FFF" "Cluster3"
, LegendField 4 "#FFF" "Cluster4"
]
, _gm_list = (ListForGraph lId (repo ^. r_version))
, _gm_startForceAtlas = True
}
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
------------------------------------------------------------ ------------------------------------------------------------
type GraphAsyncAPI = Summary "Update graph" type GraphAsyncAPI = Summary "Recompute graph"
:> "async" :> "recompute"
:> AsyncJobsAPI JobLog () JobLog :> AsyncJobsAPI JobLog () JobLog
graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
graphAsync u n = graphAsync u n =
serveJobsAPI $ serveJobsAPI $
JobFunction (\_ log' -> graphAsync' u n (liftBase . log')) JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
graphAsync' :: UserId graphRecompute :: UserId
-> NodeId -> NodeId
-> (JobLog -> GargNoServer ()) -> (JobLog -> GargNoServer ())
-> GargNoServer JobLog -> GargNoServer JobLog
graphAsync' u n logStatus = do graphRecompute u n logStatus = do
logStatus JobLog { _scst_succeeded = Just 0 logStatus JobLog { _scst_succeeded = Just 0
, _scst_failed = Just 0 , _scst_failed = Just 0
, _scst_remaining = Just 1 , _scst_remaining = Just 1
, _scst_events = Just [] , _scst_events = Just []
} }
_g <- trace (show u) $ recomputeGraph u n Conditional _g <- trace (show u) $ recomputeGraph u n Conditional
pure JobLog { _scst_succeeded = Just 1 pure JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0 , _scst_failed = Just 0
, _scst_remaining = Just 0 , _scst_remaining = Just 0
, _scst_events = Just [] , _scst_events = Just []
} }
------------------------------------------------------------ ------------------------------------------------------------
type GraphVersionsAPI = Summary "Graph versions" type GraphVersionsAPI = Summary "Graph versions"
...@@ -204,7 +228,7 @@ graphVersionsAPI u n = ...@@ -204,7 +228,7 @@ graphVersionsAPI u n =
graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
graphVersions _uId nId = do graphVersions _uId nId = do
nodeGraph <- getNodeWith nId HyperdataGraph nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let listVersion = graph ^? _Just let listVersion = graph ^? _Just
. graph_metadata . graph_metadata
...@@ -221,13 +245,32 @@ graphVersions _uId nId = do ...@@ -221,13 +245,32 @@ graphVersions _uId nId = do
recomputeVersions :: UserId -> NodeId -> GargNoServer Graph recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
recomputeVersions uId nId = recomputeGraph uId nId Conditional recomputeVersions uId nId = recomputeGraph uId nId Conditional
------------------------------------------------------------
graphClone :: UserId
-> NodeId
-> HyperdataGraphAPI
-> GargNoServer NodeId
graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
, _hyperdataAPICamera = camera }) = do
let nodeType = NodeGraph
nodeUser <- getNodeUser (NodeId uId)
nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
let uId' = nodeUser ^. node_userId
nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
case nIds of
[] -> pure pId
(nId:_) -> do
let graphP = graph
let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
_ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
pure nId
------------------------------------------------------------ ------------------------------------------------------------
getGraphGexf :: UserId getGraphGexf :: UserId
-> NodeId -> NodeId
-> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph) -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf uId nId = do getGraphGexf uId nId = do
graph <- getGraph uId nId HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
pure $ addHeader "attachment; filename=graph.gexf" graph pure $ addHeader "attachment; filename=graph.gexf" graph
...@@ -24,6 +24,12 @@ import Data.Tuple.Extra (second, swap) ...@@ -24,6 +24,12 @@ import Data.Tuple.Extra (second, swap)
import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..)) import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Debug.Trace (trace) import Debug.Trace (trace)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Database.PostgreSQL.Simple as DPS
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.Database.Admin.Config (nodeTypeId) import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId) import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
...@@ -31,11 +37,6 @@ import Gargantext.Database.Prelude (Cmd, runPGSQuery) ...@@ -31,11 +37,6 @@ import Gargantext.Database.Prelude (Cmd, runPGSQuery)
import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..)) import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..))
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Text.Terms.Mono.Stem (stem) import Gargantext.Core.Text.Terms.Mono.Stem (stem)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Database.PostgreSQL.Simple as DPS
-- | TODO: group with 2 terms only can be -- | TODO: group with 2 terms only can be
-- discussed. Main purpose of this is offering -- discussed. Main purpose of this is offering
......
...@@ -17,12 +17,13 @@ module Gargantext.Database.Admin.Trigger.NodeNodeNgrams ...@@ -17,12 +17,13 @@ module Gargantext.Database.Admin.Trigger.NodeNodeNgrams
where where
import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.SqlQQ (sql)
import qualified Database.PostgreSQL.Simple as DPS
import Gargantext.Core.Types.Main (listTypeId, ListType(CandidateTerm)) import Gargantext.Core.Types.Main (listTypeId, ListType(CandidateTerm))
import Gargantext.Database.Admin.Config (nodeTypeId) import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId) import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, execPGSQuery) import Gargantext.Database.Prelude (Cmd, execPGSQuery)
import Gargantext.Prelude import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
triggerCountInsert :: Cmd err Int64 triggerCountInsert :: Cmd err Int64
triggerCountInsert = execPGSQuery query (nodeTypeId NodeDocument, nodeTypeId NodeList) triggerCountInsert = execPGSQuery query (nodeTypeId NodeDocument, nodeTypeId NodeList)
......
...@@ -17,11 +17,12 @@ module Gargantext.Database.Admin.Trigger.Nodes ...@@ -17,11 +17,12 @@ module Gargantext.Database.Admin.Trigger.Nodes
where where
import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.SqlQQ (sql)
import qualified Database.PostgreSQL.Simple as DPS
import Gargantext.Database.Admin.Config (nodeTypeId) import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId) import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, execPGSQuery) import Gargantext.Database.Prelude (Cmd, execPGSQuery)
import Gargantext.Prelude import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
triggerSearchUpdate :: Cmd err Int64 triggerSearchUpdate :: Cmd err Int64
......
...@@ -84,12 +84,14 @@ mkCmd k = do ...@@ -84,12 +84,14 @@ mkCmd k = do
withResource pool (liftBase . k) withResource pool (liftBase . k)
runCmd :: (HasConnectionPool env) runCmd :: (HasConnectionPool env)
=> env -> Cmd' env err a => env
-> Cmd' env err a
-> IO (Either err a) -> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env runCmd env m = runExceptT $ runReaderT m env
runOpaQuery :: Default FromFields fields haskells runOpaQuery :: Default FromFields fields haskells
=> Select fields -> Cmd err [haskells] => Select fields
-> Cmd err [haskells]
runOpaQuery q = mkCmd $ \c -> runQuery c q runOpaQuery q = mkCmd $ \c -> runQuery c q
runCountOpaQuery :: Select a -> Cmd err Int runCountOpaQuery :: Select a -> Cmd err Int
......
...@@ -15,6 +15,7 @@ Portability : POSIX ...@@ -15,6 +15,7 @@ Portability : POSIX
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
...@@ -26,7 +27,13 @@ import Control.Lens (set, view) ...@@ -26,7 +27,13 @@ import Control.Lens (set, view)
import Data.Aeson import Data.Aeson
import Data.Maybe (Maybe(..), fromMaybe, maybe) import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Database.PostgreSQL.Simple as DPS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import GHC.Int (Int64) import GHC.Int (Int64)
import Opaleye hiding (FromField)
import Opaleye.Internal.QueryArr (Query)
import Prelude hiding (null, id, map, sum)
import Gargantext.Core.Types import Gargantext.Core.Types
import Gargantext.Database.Admin.Config (nodeTypeId) import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
...@@ -37,9 +44,6 @@ import Gargantext.Database.Query.Filter (limit', offset') ...@@ -37,9 +44,6 @@ import Gargantext.Database.Query.Filter (limit', offset')
import Gargantext.Database.Query.Table.Node.Error import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Schema.Node import Gargantext.Database.Schema.Node
import Gargantext.Prelude hiding (sum, head) import Gargantext.Prelude hiding (sum, head)
import Opaleye hiding (FromField)
import Opaleye.Internal.QueryArr (Query)
import Prelude hiding (null, id, map, sum)
queryNodeSearchTable :: Query NodeSearchRead queryNodeSearchTable :: Query NodeSearchRead
...@@ -107,6 +111,31 @@ getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n' ...@@ -107,6 +111,31 @@ getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
Just n'' -> n'' Just n'' -> n''
Nothing -> 0 Nothing -> 0
-- | Given a node id, find it's closest parent of given type
-- NOTE: This isn't too optimal: can make successive queries depending on how
-- deeply nested the child is.
getClosestParentIdByType :: NodeId
-> NodeType
-> Cmd err (Maybe NodeId)
getClosestParentIdByType nId nType = do
result <- runPGSQuery query (nId, 0 :: Int)
case result of
[DPS.Only parentId, DPS.Only pTypename] -> do
if nodeTypeId nType == pTypename then
pure $ Just $ NodeId parentId
else
getClosestParentIdByType (NodeId parentId) nType
_ -> pure Nothing
where
query :: DPS.Query
query = [sql|
SELECT n2.id, n2.typename
FROM nodes n1
JOIN nodes n2 ON n1.parent_id = n2.id
WHERE n1.id = ? AND 0 = ?;
|]
------------------------------------------------------------------------ ------------------------------------------------------------------------
getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3] getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument) getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment