Stability : experimental
Portability : POSIX
+-- TODO-SECURITY: Critical
+
+-- TODO-ACCESS: CanGetNode
+-- TODO-EVENTS: No events as this is a read only query.
Node API
+-------------------------------------------------------------------
+-- TODO-ACCESS: access by admin only.
+-- At first let's just have an isAdmin check.
+-- Later: check userId CanDeleteNodes Nothing
+-- TODO-EVENTS: DeletedNodes [NodeId]
+-- {"tag": "DeletedNodes", "nodes": [Int*]}
+
-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
--------------------------------------------------------------------
module Gargantext.API.Node
- ( module Gargantext.API.Node
- , HyperdataAny(..)
- , HyperdataAnnuaire(..)
- , HyperdataCorpus(..)
- , HyperdataResource(..)
- , HyperdataUser(..)
- , HyperdataDocument(..)
- , HyperdataDocumentV3(..)
- ) where
--------------------------------------------------------------------
-import Control.Lens (prism', set)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad ((>>))
---import System.IO (putStrLn, readFile)
+ where
+import Control.Lens ((^.))
import Data.Aeson (FromJSON, ToJSON)
-import Data.Text (Text())
+import Data.Maybe
import Data.Swagger
+import Data.Text (Text())
import Data.Time (UTCTime)
-
import GHC.Generics (Generic)
-import Servant
-
-import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams)
-import Gargantext.Prelude
-import Gargantext.Database.Types.Node
-import Gargantext.Database.Utils (Cmd, CmdM)
-import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB, NodeError(..), HasNodeError(..))
+import Gargantext.API.Auth (withAccess, PathId(..))
+import Gargantext.API.Metrics
+import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR)
+import Gargantext.API.Ngrams.NTree (MyTree)
+import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
+import Gargantext.API.Table
+import Gargantext.API.Types
+import Gargantext.Core.Types (NodeTableResult)
+import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
+import Gargantext.Database.Config (nodeTypeId)
+import Gargantext.Database.Flow.Pairing (pairing)
+import Gargantext.Database.Facet (FacetDoc, OrderBy(..))
import Gargantext.Database.Node.Children (getChildren)
-import qualified Gargantext.Database.Node.Update as U (update, Update(..))
-import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),FacetChart,runViewAuthorsDoc)
-import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
-import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
-import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
--- Graph
---import Gargantext.Text.Flow
-import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
--- import Gargantext.Core (Lang(..))
-import Gargantext.Core.Types (Offset, Limit)
-import Gargantext.Core.Types.Main (Tree, NodeTree, CorpusId, ContactId)
--- import Gargantext.Text.Terms (TermType(..))
-
+import Gargantext.Database.Node.User (NodeUser)
+import Gargantext.Database.Schema.Node (getNodesWithParentId, getNodeWith, getNode, deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..), getNodeUser)
+import Gargantext.Database.Schema.NodeNode -- (nodeNodesCategory, insertNodeNode, NodeNode(..))
+import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Tree (treeDB)
+import Gargantext.Database.Types.Node
+import Gargantext.Database.Utils -- (Cmd, CmdM)
+import Gargantext.Prelude
+import Gargantext.Viz.Chart
+import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
+import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import qualified Gargantext.Database.Node.Update as U (update, Update(..))
-type GargServer api = forall env m. CmdM env ServantErr m => ServerT api m
+{-
+import qualified Gargantext.Text.List.Learn as Learn
+import qualified Data.Vector as Vec
+--}
--------------------------------------------------------------------
--- | TODO : access by admin only
type NodesAPI = Delete '[JSON] Int
-- | Delete Nodes
nodesAPI ids = deleteNodes ids
------------------------------------------------------------------------
--- | TODO: access by admin only
--- To manager the Users roots
-type Roots = Get '[JSON] [NodeAny]
+-- | TODO-ACCESS: access by admin only.
+-- At first let's just have an isAdmin check.
+-- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
+-- To manage the Users roots
+-- TODO-EVENTS:
+-- PutNode ?
+-- TODO needs design discussion.
+type Roots = Get '[JSON] [NodeUser]
:<|> Put '[JSON] Int -- TODO
-- | TODO: access by admin only
roots :: GargServer Roots
-roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
- :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
+roots = getNodesWithParentId Nothing
+ :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
-------------------------------------------------------------------
-- | Node API Types management
--- TODO : access by users
+-- TODO-ACCESS : access by users
+-- No ownership check is needed if we strictly follow the capability model.
+--
+-- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
+-- SearchAPI)
+-- CanRenameNode (or part of CanEditNode?)
+-- CanCreateChildren (PostNodeApi)
+-- CanEditNode / CanPutNode TODO not implemented yet
+-- CanDeleteNode
+-- CanPatch (TableNgramsApi)
+-- CanFavorite
+-- CanMoveToTrash
+
type NodeAPI a = Get '[JSON] (Node a)
:<|> "rename" :> RenameApi
- :<|> PostNodeApi
- :<|> Put '[JSON] Int
+ :<|> PostNodeApi -- TODO move to children POST
+ :<|> ReqBody '[JSON] a :> Put '[JSON] Int
:<|> Delete '[JSON] Int
:<|> "children" :> ChildrenApi a
-- TODO gather it
:<|> "table" :> TableApi
- :<|> "list" :> TableNgramsApi
- :<|> "listGet" :> TableNgramsApiGet
- :<|> "pairing" :> PairingApi
+ :<|> "ngrams" :> TableNgramsApi
+
+ :<|> "category" :> CatApi
+ :<|> "search" :> SearchDocsAPI
+
+ -- Pairing utilities
+ :<|> "pairwith" :> PairWith
+ :<|> "pairs" :> Pairs
+ :<|> "pairing" :> PairingApi
+ :<|> "searchPair" :> SearchPairsAPI
+ -- VIZ
+ :<|> "metrics" :> ScatterAPI
:<|> "chart" :> ChartApi
- :<|> "favorites" :> FavApi
- :<|> "documents" :> DocsApi
- :<|> "search":> Summary "Node Search"
- :> ReqBody '[JSON] SearchInQuery
- :> QueryParam "offset" Int
- :> QueryParam "limit" Int
- :> QueryParam "order" OrderBy
- :> SearchAPI
-
-type RenameApi = Summary " RenameNode Node"
+ :<|> "pie" :> PieApi
+ :<|> "tree" :> TreeApi
+ :<|> "phylo" :> PhyloAPI
+ -- :<|> "add" :> NodeAddAPI
+
+-- TODO-ACCESS: check userId CanRenameNode nodeId
+-- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
+type RenameApi = Summary " Rename Node"
:> ReqBody '[JSON] RenameNode
:> Put '[JSON] [Int]
type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
:> ReqBody '[JSON] PostNode
- :> Post '[JSON] [Int]
+ :> Post '[JSON] [NodeId]
type ChildrenApi a = Summary " Summary children"
:> QueryParam "type" NodeType
:> QueryParam "offset" Int
:> QueryParam "limit" Int
- :> Get '[JSON] [Node a]
+ -- :> Get '[JSON] [Node a]
+ :> Get '[JSON] (NodeTableResult a)
+
+------------------------------------------------------------------------
+type NodeNodeAPI a = Get '[JSON] (Node a)
+
+nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a)
+ => proxy a
+ -> UserId
+ -> CorpusId
+ -> NodeId
+ -> GargServer (NodeNodeAPI a)
+nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
+ where
+ nodeNodeAPI' :: GargServer (NodeNodeAPI a)
+ nodeNodeAPI' = getNodeWith nId p
+
------------------------------------------------------------------------
-- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
-nodeAPI :: JSONB a => proxy a -> NodeId -> GargServer (NodeAPI a)
-nodeAPI p id = getNode id p
- :<|> rename id
- :<|> postNode id
- :<|> putNode id
- :<|> deleteNode id
- :<|> getChildren id p
+nodeAPI :: forall proxy a. (JSONB a, FromJSON a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
+nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
+ where
+ nodeAPI' :: GargServer (NodeAPI a)
+ nodeAPI' = getNodeWith id p
+ :<|> rename id
+ :<|> postNode uId id
+ :<|> putNode id
+ :<|> deleteNodeApi id
+ :<|> getChildren id p
-- TODO gather it
- :<|> getTable id
- :<|> tableNgramsPatch id
- :<|> getTableNgrams id
- :<|> getPairing id
-
- :<|> getChart id
- :<|> favApi id
- :<|> delDocs id
- :<|> searchIn id
- -- Annuaire
- -- :<|> upload
- -- :<|> query
+ :<|> tableApi id
+ :<|> apiNgramsTableCorpus id
+
+ :<|> catApi id
+
+ :<|> searchDocs id
+ -- Pairing Tools
+ :<|> pairWith id
+ :<|> pairs id
+ :<|> getPair id
+ :<|> searchPairs id
+
+ :<|> getScatter id
+ :<|> getChart id
+ :<|> getPie id
+ :<|> getTree id
+ :<|> phyloAPI id uId
+ -- :<|> nodeAddAPI id
+ -- :<|> postUpload id
+
+ deleteNodeApi id' = do
+ node <- getNode id'
+ if _node_typename node == nodeTypeId NodeUser
+ then panic "not allowed" -- TODO add proper Right Management Type
+ else deleteNode id'
+
------------------------------------------------------------------------
data RenameNode = RenameNode { r_name :: Text }
deriving (Generic)
+-- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
instance FromJSON RenameNode
instance ToJSON RenameNode
instance ToSchema RenameNode
, pn_typename :: NodeType}
deriving (Generic)
+-- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
instance FromJSON PostNode
instance ToJSON PostNode
instance ToSchema PostNode
arbitrary = elements [PostNode "Node test" NodeCorpus]
------------------------------------------------------------------------
-type DocsApi = Summary "Docs : Move to trash"
- :> ReqBody '[JSON] Documents
- :> Delete '[JSON] [Int]
-
-data Documents = Documents { documents :: [NodeId]}
- deriving (Generic)
-
-instance FromJSON Documents
-instance ToJSON Documents
-instance ToSchema Documents
-
-delDocs :: CorpusId -> Documents -> Cmd err [Int]
-delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
-
-------------------------------------------------------------------------
-type FavApi = Summary " Favorites label"
- :> ReqBody '[JSON] Favorites
+type CatApi = Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
+ :> ReqBody '[JSON] NodesToCategory
:> Put '[JSON] [Int]
- :<|> Summary " Favorites unlabel"
- :> ReqBody '[JSON] Favorites
- :> Delete '[JSON] [Int]
-data Favorites = Favorites { favorites :: [NodeId]}
+data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
+ , ntc_category :: Int
+ }
deriving (Generic)
-instance FromJSON Favorites
-instance ToJSON Favorites
-instance ToSchema Favorites
+-- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
+instance FromJSON NodesToCategory
+instance ToJSON NodesToCategory
+instance ToSchema NodesToCategory
-putFav :: CorpusId -> Favorites -> Cmd err [Int]
-putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
-
-delFav :: CorpusId -> Favorites -> Cmd err [Int]
-delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
-
-favApi :: CorpusId -> GargServer FavApi
-favApi cId = putFav cId :<|> delFav cId
+catApi :: CorpusId -> GargServer CatApi
+catApi = putCat
+ where
+ putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
+ putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
------------------------------------------------------------------------
-type TableApi = Summary " Table API"
- :> QueryParam "view" TabType
- :> QueryParam "offset" Int
- :> QueryParam "limit" Int
- :> QueryParam "order" OrderBy
- :> Get '[JSON] [FacetDoc]
-
-- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
+-- Pairing utilities to move elsewhere
type PairingApi = Summary " Pairing API"
- :> QueryParam "view" TabType -- TODO change TabType -> DocType (CorpusId for pairing)
+ :> QueryParam "view" TabType
+ -- TODO change TabType -> DocType (CorpusId for pairing)
:> QueryParam "offset" Int
:> QueryParam "limit" Int
:> QueryParam "order" OrderBy
:> Get '[JSON] [FacetDoc]
+----------
+type Pairs = Summary "List of Pairs"
+ :> Get '[JSON] [AnnuaireId]
+pairs :: CorpusId -> GargServer Pairs
+pairs cId = do
+ ns <- getNodeNode cId
+ pure $ map _nn_node2_id ns
+
+type PairWith = Summary "Pair a Corpus with an Annuaire"
+ :> "annuaire" :> Capture "annuaire_id" AnnuaireId
+ :> "list" :> Capture "list_id" ListId
+ :> Post '[JSON] Int
+
+pairWith :: CorpusId -> GargServer PairWith
+pairWith cId aId lId = do
+ r <- pairing cId aId lId
+ _ <- insertNodeNode [ NodeNode cId aId Nothing Nothing]
+ pure r
+
------------------------------------------------------------------------
type ChartApi = Summary " Chart API"
:> QueryParam "from" UTCTime
:> QueryParam "to" UTCTime
- :> Get '[JSON] [FacetChart]
+ :> Get '[JSON] (ChartMetrics Histo)
+
+type PieApi = Summary " Chart API"
+ :> QueryParam "from" UTCTime
+ :> QueryParam "to" UTCTime
+ :> QueryParamR "ngramsType" TabType
+ :> Get '[JSON] (ChartMetrics Histo)
+
+type TreeApi = Summary " Tree API"
+ :> QueryParam "from" UTCTime
+ :> QueryParam "to" UTCTime
+ :> QueryParamR "ngramsType" TabType
+ :> QueryParamR "listType" ListType
+ :> Get '[JSON] (ChartMetrics [MyTree])
-- Depending on the Type of the Node, we could post
-- New documents for a corpus
-- New map list terms
-- :<|> "process" :> MultipartForm MultipartData :> Post '[JSON] Text
-
- -- To launch a query and update the corpus
- -- :<|> "query" :> Capture "string" Text :> Get '[JSON] Text
------------------------------------------------------------------------
-type GraphAPI = Get '[JSON] Graph
-graphAPI :: NodeId -> GargServer GraphAPI
-graphAPI nId = do
-
- nodeGraph <- getNode nId HyperdataGraph
-
- let title = "IMT - Scientific publications - 1982-2017 - English"
- let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph] [ LegendField 6 "#FFF" "Data processing"
- , LegendField 7 "#FFF" "Networks"
- , LegendField 1 "#FFF" "Material science"
- , LegendField 5 "#FFF" "Energy / Environment"
- ]
- -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
-
- graph <- set graph_metadata (Just metadata)
- <$> maybe defaultGraph identity
- <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
-
- pure graph
- -- t <- textFlow (Mono EN) (Contexts contextText)
- -- liftIO $ liftIO $ pure $ maybe t identity maybeGraph
- -- TODO what do we get about the node? to replace contextText
+{-
+NOTE: These instances are not necessary. However, these messages could be part
+ of a display function for NodeError/TreeError.
instance HasNodeError ServantErr where
- _NodeError = prism' mk (const $ panic "HasNodeError ServantErr: not a prism")
+ _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
where
- e = "NodeError: "
+ e = "Gargantext NodeError: "
mk NoListFound = err404 { errBody = e <> "No list found" }
mk NoRootFound = err404 { errBody = e <> "No Root found" }
mk NoCorpusFound = err404 { errBody = e <> "No Corpus found" }
mk NoUserFound = err404 { errBody = e <> "No User found" }
-
+
mk MkNode = err500 { errBody = e <> "Cannot mk node" }
- mk NegativeId = err500 { errBody = e <> "Node Id non positive" }
+ mk NegativeId = err500 { errBody = e <> "Node with negative Id" }
mk UserNoParent = err500 { errBody = e <> "Should not have parent"}
mk HasParent = err500 { errBody = e <> "NodeType has parent" }
mk NotImplYet = err500 { errBody = e <> "Not implemented yet" }
mk ManyParents = err500 { errBody = e <> "Too many parents" }
mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user" }
--- TODO(orphan): There should be a proper APIError data type with a case TreeError.
instance HasTreeError ServantErr where
- _TreeError = prism' mk (const $ panic "HasTreeError ServantErr: not a prism")
+ _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
where
e = "TreeError: "
mk NoRoot = err404 { errBody = e <> "Root node not found" }
mk EmptyRoot = err500 { errBody = e <> "Root node should not be empty" }
mk TooManyRoots = err500 { errBody = e <> "Too many root nodes" }
+-}
+
+type TreeAPI = QueryParams "type" NodeType :> Get '[JSON] (Tree NodeTree)
-type TreeAPI = Get '[JSON] (Tree NodeTree)
treeAPI :: NodeId -> GargServer TreeAPI
treeAPI = treeDB
------------------------------------------------------------------------
-- | Check if the name is less than 255 char
rename :: NodeId -> RenameNode -> Cmd err [Int]
-rename nId (RenameNode name) = U.update (U.Rename nId name)
-
-getTable :: NodeId -> Maybe TabType
- -> Maybe Offset -> Maybe Limit
- -> Maybe OrderBy -> Cmd err [FacetDoc]
-getTable cId ft o l order = case ft of
- (Just Docs) -> runViewDocuments cId False o l order
- (Just Trash) -> runViewDocuments cId True o l order
- _ -> panic "not implemented"
-
-getPairing :: ContactId -> Maybe TabType
- -> Maybe Offset -> Maybe Limit
- -> Maybe OrderBy -> Cmd err [FacetDoc]
-getPairing cId ft o l order = case ft of
- (Just Docs) -> runViewAuthorsDoc cId False o l order
- (Just Trash) -> runViewAuthorsDoc cId True o l order
- _ -> panic "not implemented"
-
-
-getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
- -> Cmd err [FacetChart]
-getChart _ _ _ = undefined -- TODO
-
-postNode :: NodeId -> PostNode -> Cmd err [Int]
-postNode pId (PostNode name nt) = mk nt (Just pId) name
-
-putNode :: NodeId -> Cmd err Int
-putNode = undefined -- TODO
-
-query :: Monad m => Text -> m Text
-query s = pure s
-
-
--- | Upload files
--- TODO Is it possible to adapt the function according to iValue input ?
---upload :: MultipartData -> Handler Text
---upload multipartData = do
--- liftIO $ do
--- putStrLn "Inputs:"
--- forM_ (inputs multipartData) $ \input ->
--- putStrLn $ " " <> show (iName input)
--- <> " -> " <> show (iValue input)
---
--- forM_ (files multipartData) $ \file -> do
--- content <- readFile (fdFilePath file)
--- putStrLn $ "Content of " <> show (fdFileName file)
--- <> " at " <> fdFilePath file
--- putStrLn content
--- pure (pack "Data loaded")
+rename nId (RenameNode name') = U.update (U.Rename nId name')
+
+postNode :: HasNodeError err
+ => UserId
+ -> NodeId
+ -> PostNode
+ -> Cmd err [NodeId]
+postNode uId pId (PostNode nodeName nt) = do
+ nodeUser <- getNodeUser (NodeId uId)
+ let uId' = nodeUser ^. node_userId
+ mkNodeWithParent nt (Just pId) uId' nodeName
+
+putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
+ => NodeId
+ -> a
+ -> Cmd err Int
+putNode n h = fromIntegral <$> updateHyperdata n h
+-------------------------------------------------------------