import GHC.Generics (Generic)
import Servant
-import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams)
+import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, HasRepoVar, HasRepoSaver)
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.Database.Utils -- (Cmd, CmdM)
+import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mkNodeWithParent, JSONB, NodeError(..), HasNodeError(..))
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.Metrics.Count (getCoocByDocDev)
+import Gargantext.Database.Schema.Node (defaultList)
import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
+
-- Graph
---import Gargantext.Text.Flow
+import Gargantext.Text.Flow (cooc2graph)
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.Core.Types.Main (Tree, NodeTree)
+import Gargantext.Database.Types.Node (CorpusId, ContactId)
-- import Gargantext.Text.Terms (TermType(..))
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-type GargServer api = forall env m. CmdM env ServantErr m => ServerT api m
+type GargServer api =
+ forall env m.
+ (CmdM env ServantErr m, HasRepoVar env, HasRepoSaver env)
+ => ServerT api m
-------------------------------------------------------------------
--- | TODO : access by admin only
+-- 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*]}
type NodesAPI = Delete '[JSON] Int
-- | Delete Nodes
nodesAPI ids = deleteNodes ids
------------------------------------------------------------------------
--- | TODO: access by admin only
--- To manager the Users roots
+-- | 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] [NodeAny]
:<|> Put '[JSON] Int -- TODO
-------------------------------------------------------------------
-- | 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
+ :<|> PostNodeApi -- TODO move to children POST
:<|> Put '[JSON] Int
:<|> Delete '[JSON] Int
:<|> "children" :> ChildrenApi a
:> QueryParam "order" OrderBy
:> SearchAPI
-type RenameApi = Summary " RenameNode Node"
+-- 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
:> Get '[JSON] [Node a]
------------------------------------------------------------------------
-- 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
+nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
+nodeAPI p uId id
+ = getNode id p
:<|> rename id
- :<|> postNode id
+ :<|> postNode uId id
:<|> putNode id
:<|> deleteNode id
:<|> getChildren id p
-- :<|> "query" :> Capture "string" Text :> Get '[JSON] Text
------------------------------------------------------------------------
+-- TODO-ACCESS: CanGetNode
+-- TODO-EVENTS: No events as this is a read only query.
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
+ let title = "Title"
+ let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph]
+ [ LegendField 1 "#FFF" "Cluster"
+ , LegendField 2 "#FFF" "Cluster"
+ ]
+ -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
+ let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
+ lId <- defaultList cId
+ myCooc <- getCoocByDocDev cId lId
+ liftIO $ set graph_metadata (Just metadata)
+ <$> cooc2graph myCooc
+
+ -- <$> maybe defaultGraph identity
+ -- <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
-- t <- textFlow (Mono EN) (Contexts contextText)
-- liftIO $ liftIO $ pure $ maybe t identity maybeGraph
-- TODO what do we get about the node? to replace contextText
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
- mk NoListFound = err404 { errBody = "NodeError: No list found" }
- mk MkNodeError = err404 { errBody = "NodeError: Cannot mk node" }
+ e = "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 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
- mk NoRoot = err404 { errBody = "Root node not found" }
- mk EmptyRoot = err500 { errBody = "Root node should not be empty" }
- mk TooManyRoots = err500 { errBody = "Too many root nodes" }
+ 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 = Get '[JSON] (Tree NodeTree)
+-- TODO-ACCESS: CanTree or CanGetNode
+-- TODO-EVENTS: No events as this is a read only query.
treeAPI :: NodeId -> GargServer TreeAPI
treeAPI = treeDB
-> Cmd err [FacetChart]
getChart _ _ _ = undefined -- TODO
-postNode :: NodeId -> PostNode -> Cmd err [Int]
-postNode pId (PostNode name nt) = mk nt (Just pId) name
+postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
+postNode uId pId (PostNode name nt) = mkNodeWithParent nt (Just pId) uId name
putNode :: NodeId -> Cmd err Int
putNode = undefined -- TODO