Merge branch 'dev-phylo' of https://gitlab.iscpif.fr/gargantext/haskell-gargantext...
[gargantext.git] / src / Gargantext / API / Node.hs
index 809befca3d9816a9f020ddb5415a3dee8edf791b..4b7060cf8178fab287e66f5a23743dfc57874f23 100644 (file)
@@ -46,32 +46,43 @@ import Data.Time (UTCTime)
 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
@@ -81,8 +92,13 @@ nodesAPI :: [NodeId] -> GargServer NodesAPI
 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
 
@@ -93,10 +109,21 @@ roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
 
 -------------------------------------------------------------------
 -- | 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
@@ -117,13 +144,15 @@ type NodeAPI a = Get '[JSON] (Node 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
@@ -132,10 +161,11 @@ type ChildrenApi a = Summary " Summary children"
                  :> 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
@@ -243,44 +273,62 @@ type ChartApi = Summary " Chart API"
              -- :<|> "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
 
@@ -310,8 +358,8 @@ 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
+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