Skip to content

H
haskell-gargantext
Commit 65debf70 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[Merge]

parents 7d98c7bc 8672282b
Show whitespace changes
Inline Side-by-side
Showing with 364 additions and 174 deletions
src/Gargantext/API/Admin/Orchestrator/Types.hs
View file @ 65debf70
......@@ -11,14 +11,16 @@ import Data.Proxy
import Data.Swagger hiding (URL, url, port)
import Data.Text (Text)
import GHC.Generics hiding (to)
import Gargantext.Core.Types (TODO(..))
import Gargantext.Prelude
import Servant
import Servant.Job.Async
import Servant.Job.Types
import Servant.Job.Utils (jsonOptions)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import Gargantext.Core.Types (TODO(..))
import Gargantext.Prelude
------------------------------------------------------------------------
instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
arbitrary = panic "TODO"
......@@ -126,3 +128,7 @@ instance ToParamSchema Limit -- where
type ScrapersEnv = JobEnv JobLog JobLog
type ScraperAPI = AsyncJobsAPI JobLog ScraperInput JobLog
------------------------------------------------------------------------
type AsyncJobs event ctI input output =
AsyncJobsAPI' 'Unsafe 'Safe ctI '[JSON] Maybe event input output
src/Gargantext/API/Ngrams/List.hs
View file @ 65debf70
......@@ -22,7 +22,13 @@ import Data.Map (Map, toList, fromList)
import Data.Swagger (ToSchema, declareNamedSchema, genericDeclareNamedSchema)
import Data.Text (Text, concat, pack)
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.Ngrams
import Gargantext.API.Admin.Orchestrator.Types
......@@ -31,12 +37,6 @@ import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
import Gargantext.Database.Action.Flow (FlowCmdM)
import Gargantext.Database.Admin.Types.Node
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))
......
src/Gargantext/API/Node.hs
View file @ 65debf70
......@@ -150,6 +150,7 @@ type NodeAPI a = Get '[JSON] (Node a)
:<|> "unpublish" :> Share.Unpublish
:<|> "file" :> FileApi
:<|> "async" :> FileAsyncApi
-- TODO-ACCESS: check userId CanRenameNode nodeId
-- 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
:<|> Share.unPublish id'
:<|> fileApi uId id'
:<|> fileAsyncApi uId id'
------------------------------------------------------------------------
......
src/Gargantext/API/Node/Contact.hs
View file @ 65debf70
......@@ -29,12 +29,12 @@ import Data.Maybe (Maybe(..))
import Data.Swagger
import Data.Text (Text)
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.Node
import Gargantext.API.Node.Corpus.New (AsyncJobs)
import Gargantext.API.Prelude (GargServer, simuLogs)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Terms (TermType(..))
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Flow (flow)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
......@@ -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.Node
import Gargantext.Prelude (($), liftBase, (.), printDebug, pure)
import Gargantext.Core.Text.Terms (TermType(..))
import Servant
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import Test.QuickCheck (elements)
......
src/Gargantext/API/Node/Corpus/Annuaire.hs
View file @ 65debf70
......@@ -19,18 +19,19 @@ import Data.Aeson
import Data.Swagger
import Data.Text (Text)
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.Job.Core
import Servant.Job.Types
import Servant.Job.Utils (jsonOptions)
import Web.FormUrlEncoded (FromForm)
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"
......
src/Gargantext/API/Node/Corpus/New.hs
View file @ 65debf70
......@@ -14,7 +14,6 @@ New corpus means either:
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.API.Node.Corpus.New
where
......@@ -22,30 +21,25 @@ module Gargantext.API.Node.Corpus.New
import Control.Lens hiding (elements, Empty)
import Data.Aeson
import Data.Aeson.TH (deriveJSON)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BSB64
import Data.Either
import Data.Maybe (fromMaybe)
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
import Servant.Job.Core
import Servant.Job.Types
import Servant.Job.Utils (jsonOptions)
-- import Servant.Multipart
-- import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import Web.FormUrlEncoded (FromForm)
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 Gargantext.API.Admin.Settings (HasSettings)
import Gargantext.API.Node.Corpus.New.File
import Gargantext.API.Node.Types
import Gargantext.Core (Lang(..){-, allLangs-})
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
......@@ -163,49 +157,6 @@ instance FromJSON WithQuery where
instance ToSchema WithQuery where
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"
......
src/Gargantext/API/Node/Corpus/New/File.hs
View file @ 65debf70
......@@ -26,11 +26,7 @@ import Data.Monoid (mempty)
import Data.Swagger
import Data.Text (Text())
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.Multipart
import Servant.Swagger (HasSwagger(toSwagger))
......@@ -38,6 +34,12 @@ import Servant.Swagger.Internal
import Test.QuickCheck (elements)
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
data FileType = CSV
......
src/Gargantext/API/Node/File.hs
View file @ 65debf70
......@@ -18,17 +18,25 @@ import qualified Network.HTTP.Media as M
import Network.Wai.Application.Static
import Servant
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 Gargantext.Prelude
import qualified Gargantext.Prelude.Utils as GPU
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Settings (HasSettings)
import Gargantext.API.Node.Types
import Gargantext.API.Prelude
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Types.Hyperdata.File
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.Node (getNodeWith)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata)
data RESPONSE deriving Typeable
......@@ -89,3 +97,55 @@ fileDownload uId nId = do
-- let settings = embeddedSettings [("", "hello")]
-- 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 []
}
src/Gargantext/API/Node/New.hs
View file @ 65debf70
......@@ -30,8 +30,7 @@ import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import Web.FormUrlEncoded (FromForm)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
import Gargantext.API.Node.Corpus.New (AsyncJobs)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Prelude
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Node
......
src/Gargantext/API/Node/Types.hs 0 → 100644
View file @ 65debf70
{-# 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
src/Gargantext/API/Node/Update.hs
View file @ 65debf70
......@@ -20,24 +20,21 @@ import Data.Aeson
import Data.Maybe (Maybe(..))
import Data.Swagger
import GHC.Generics (Generic)
import Gargantext.Prelude
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Settings (HasSettings)
import Gargantext.API.Node.Corpus.New (AsyncJobs)
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.Types (FlowCmdM)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Prelude (Ord, Eq, (<$>), ($), liftBase, (.), printDebug, pure)
import Gargantext.Core.Viz.Graph.API (recomputeGraph)
import Gargantext.Core.Viz.Graph.Distances (GraphMetric(..), Distance(..))
import Gargantext.Prelude (Ord, Eq, (<$>), ($), liftBase, (.), printDebug, pure, show, cs, (<>), panic)
import Prelude (Enum, Bounded, minBound, maxBound)
import Servant
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
------------------------------------------------------------------------
type API = Summary " Update node according to NodeType params"
:> AsyncJobs JobLog '[JSON] UpdateNodeParams JobLog
......
src/Gargantext/API/Prelude.hs
View file @ 65debf70
......@@ -33,6 +33,10 @@ import Crypto.JOSE.Error as Jose
import Data.Aeson.Types
import Data.Typeable
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.Settings
import Gargantext.API.Ngrams
......@@ -41,9 +45,6 @@ import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
import Gargantext.Database.Query.Tree
import Gargantext.Prelude
import Servant
import Servant.Job.Async (HasJobEnv)
import Servant.Job.Core (HasServerError(..), serverError)
class HasJoseError e where
_JoseError :: Prism' e Jose.Error
......
src/Gargantext/API/Routes.hs
View file @ 65debf70
......@@ -24,6 +24,7 @@ module Gargantext.API.Routes
where
---------------------------------------------------------------------
-- import qualified Gargantext.API.Search as Search
import Control.Concurrent (threadDelay)
import Data.Text (Text)
import Data.Validity
......@@ -33,29 +34,27 @@ import Gargantext.API.Count (CountAPI, count, Query)
import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableDoc)
import Gargantext.API.Node
import Gargantext.API.Prelude
-- import qualified Gargantext.API.Search as Search
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Viz.Graph.API
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Admin.Types.Node (NodeId, CorpusId, AnnuaireId)
import Gargantext.Prelude
import Gargantext.Core.Viz.Graph.API
import Servant
import Servant.Auth as SA
import Servant.Auth.Swagger ()
import Servant.Job.Async
import Servant.Swagger.UI
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.Export as Export
import qualified Gargantext.API.Node.Corpus.New as New
import qualified Gargantext.API.Public as Public
import qualified Gargantext.API.Node.Contact as Contact
type GargAPI = "api" :> Summary "API " :> GargAPIVersion
-- | TODO :<|> Summary "Latest API" :> GargAPI'
type GargAPIVersion = "v1.0"
:> Summary "Garg API Version "
:> GargAPI'
......
src/Gargantext/Core/Text/Metrics/TFICF.hs
View file @ 65debf70
......@@ -23,12 +23,12 @@ module Gargantext.Core.Text.Metrics.TFICF ( TFICF
)
where
import Data.Map.Strict (Map, toList)
import Data.Text (Text)
import Gargantext.Prelude
import Gargantext.Core.Types (Ordering(..))
import Data.Map.Strict (Map, toList)
import qualified Data.Ord as DO (Down(..))
import Gargantext.Prelude
import qualified Data.List as List
import qualified Data.Ord as DO (Down(..))
path :: Text
path = "[G.T.Metrics.TFICF]"
......
src/Gargantext/Core/Viz/Graph.hs
View file @ 65debf70
......@@ -20,17 +20,19 @@ import Control.Lens (makeLenses)
import Data.ByteString.Lazy as DBL (readFile, writeFile)
import Data.Text (Text, pack)
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.Arbitrary (Arbitrary, arbitrary)
import qualified Data.Aeson as DA
import qualified Data.Text 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
deriving (Show, Generic)
......@@ -102,6 +104,7 @@ data GraphMetadata =
, _gm_corpusId :: [NodeId] -- we can map with different corpus
, _gm_legend :: [LegendField] -- legend of the Graph
, _gm_list :: ListForGraph
, _gm_startForceAtlas :: Bool
-- , _gm_version :: Int
}
deriving (Show, Generic)
......@@ -122,7 +125,7 @@ makeLenses ''Graph
instance ToSchema Graph where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
-- | Intances for the mack
-- | Intances for the mock
instance Arbitrary Graph where
arbitrary = elements $ [defaultGraph]
......@@ -158,15 +161,28 @@ data GraphV3 = GraphV3 { go_links :: [EdgeV3]
deriving (Show, Generic)
$(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 =
HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
, _hyperdataCamera :: !(Maybe Camera)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "") ''HyperdataGraph)
$(deriveJSON (unPrefix "_") ''HyperdataGraph)
instance ToSchema HyperdataGraph where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
defaultHyperdataGraph :: HyperdataGraph
defaultHyperdataGraph = HyperdataGraph Nothing
defaultHyperdataGraph = HyperdataGraph Nothing Nothing
instance Hyperdata HyperdataGraph
......@@ -180,6 +196,23 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
where
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 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ 65debf70
......@@ -36,15 +36,17 @@ import Gargantext.API.Ngrams.Tools
import Gargantext.API.Prelude
import Gargantext.Core.Types.Main
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd)
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.Select
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
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.Core.Viz.Graph
import Gargantext.Core.Viz.Graph.GEXF ()
......@@ -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
-- 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)
:<|> GraphAsyncAPI
:<|> "versions" :> GraphVersionsAPI
data GraphVersions =
......@@ -70,15 +75,17 @@ instance ToSchema GraphVersions
graphAPI :: UserId -> NodeId -> GargServer GraphAPI
graphAPI u n = getGraph u n
:<|> getGraphGexf u n
:<|> graphAsync u n
:<|> graphClone u n
:<|> getGraphGexf u n
:<|> graphVersionsAPI u n
------------------------------------------------------------------------
getGraph :: UserId -> NodeId -> GargNoServer Graph
getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
getGraph _uId nId = do
nodeGraph <- getNodeWith nId HyperdataGraph
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
repo <- getRepo
......@@ -90,21 +97,23 @@ getGraph _uId nId = do
case graph of
Nothing -> do
graph' <- computeGraph cId Conditional NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph')
pure $ trace "[G.V.G.API] Graph empty, computing" graph'
mt <- defaultGraphMetadata cId "Title" repo
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 _uId nId d = do
nodeGraph <- getNodeWith nId HyperdataGraph
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let listVersion = graph ^? _Just
. graph_metadata
. _Just
. gm_list
. lfg_version
let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
let graphMetadata = graph ^? _Just . graph_metadata . _Just
let listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
repo <- getRepo
let v = repo ^. r_version
......@@ -115,15 +124,18 @@ recomputeGraph _uId nId d = do
case graph of
Nothing -> do
graph' <- computeGraph cId d NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph')
pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph'
mt <- defaultGraphMetadata cId "Title" repo
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
then pure graph'
else do
graph'' <- computeGraph cId d NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
pure $ trace "[G.V.G.API] Graph exists, recomputing" graph''
let graph''' = set graph_metadata graphMetadata graph''
_ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
-- TODO use Database Monad only here ?
......@@ -147,38 +159,50 @@ computeGraph cId d nt repo = do
graph <- liftBase $ cooc2graph d 0 myCooc
pure graph
defaultGraphMetadata :: HasNodeError err
=> CorpusId
-> Text
-> NgramsRepo
-> Cmd err GraphMetadata
defaultGraphMetadata cId t repo = do
lId <- defaultList cId
let metadata = GraphMetadata "Title"
Order1
[cId]
[ LegendField 1 "#FFF" "Cluster1"
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"
]
(ListForGraph lId (repo ^. r_version))
, _gm_list = (ListForGraph lId (repo ^. r_version))
, _gm_startForceAtlas = True
}
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
pure $ set graph_metadata (Just metadata) graph
------------------------------------------------------------
type GraphAsyncAPI = Summary "Update graph"
:> "async"
type GraphAsyncAPI = Summary "Recompute graph"
:> "recompute"
:> AsyncJobsAPI JobLog () JobLog
graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
graphAsync u n =
serveJobsAPI $
JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
graphAsync' :: UserId
graphRecompute :: UserId
-> NodeId
-> (JobLog -> GargNoServer ())
-> GargNoServer JobLog
graphAsync' u n logStatus = do
graphRecompute u n logStatus = do
logStatus JobLog { _scst_succeeded = Just 0
, _scst_failed = Just 0
, _scst_remaining = Just 1
......@@ -204,7 +228,7 @@ graphVersionsAPI u n =
graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
graphVersions _uId nId = do
nodeGraph <- getNodeWith nId HyperdataGraph
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let listVersion = graph ^? _Just
. graph_metadata
......@@ -221,13 +245,32 @@ graphVersions _uId nId = do
recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
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
-> NodeId
-> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf uId nId = do
graph <- getGraph uId nId
HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
pure $ addHeader "attachment; filename=graph.gexf" graph
src/Gargantext/Database/Action/Metrics/NgramsByNode.hs
View file @ 65debf70
......@@ -24,6 +24,12 @@ import Data.Tuple.Extra (second, swap)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
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.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
......@@ -31,11 +37,6 @@ import Gargantext.Database.Prelude (Cmd, runPGSQuery)
import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..))
import Gargantext.Prelude
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
-- discussed. Main purpose of this is offering
......
src/Gargantext/Database/Admin/Trigger/NodeNodeNgrams.hs
View file @ 65debf70
......@@ -17,12 +17,13 @@ module Gargantext.Database.Admin.Trigger.NodeNodeNgrams
where
import Database.PostgreSQL.Simple.SqlQQ (sql)
import qualified Database.PostgreSQL.Simple as DPS
import Gargantext.Core.Types.Main (listTypeId, ListType(CandidateTerm))
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, execPGSQuery)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
triggerCountInsert :: Cmd err Int64
triggerCountInsert = execPGSQuery query (nodeTypeId NodeDocument, nodeTypeId NodeList)
......
src/Gargantext/Database/Admin/Trigger/Nodes.hs
View file @ 65debf70
......@@ -17,11 +17,12 @@ module Gargantext.Database.Admin.Trigger.Nodes
where
import Database.PostgreSQL.Simple.SqlQQ (sql)
import qualified Database.PostgreSQL.Simple as DPS
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, execPGSQuery)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
triggerSearchUpdate :: Cmd err Int64
......
src/Gargantext/Database/Prelude.hs
View file @ 65debf70
......@@ -84,12 +84,14 @@ mkCmd k = do
withResource pool (liftBase . k)
runCmd :: (HasConnectionPool env)
=> env -> Cmd' env err a
=> env
-> Cmd' env err a
-> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env
runOpaQuery :: Default FromFields fields haskells
=> Select fields -> Cmd err [haskells]
=> Select fields
-> Cmd err [haskells]
runOpaQuery q = mkCmd $ \c -> runQuery c q
runCountOpaQuery :: Select a -> Cmd err Int
......
src/Gargantext/Database/Query/Table/Node.hs
View file @ 65debf70
......@@ -15,6 +15,7 @@ Portability : POSIX
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
......@@ -26,7 +27,13 @@ import Control.Lens (set, view)
import Data.Aeson
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Text (Text)
import qualified Database.PostgreSQL.Simple as DPS
import Database.PostgreSQL.Simple.SqlQQ (sql)
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.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Hyperdata
......@@ -37,9 +44,6 @@ import Gargantext.Database.Query.Filter (limit', offset')
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Schema.Node
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
......@@ -107,6 +111,31 @@ getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
Just n'' -> n''
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 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