2 Module : Gargantext.API.Node
3 Description : Server API
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
10 -- TODO-SECURITY: Critical
12 -- TODO-ACCESS: CanGetNode
13 -- TODO-EVENTS: No events as this is a read only query.
16 -------------------------------------------------------------------
17 -- TODO-ACCESS: access by admin only.
18 -- At first let's just have an isAdmin check.
19 -- Later: check userId CanDeleteNodes Nothing
20 -- TODO-EVENTS: DeletedNodes [NodeId]
21 -- {"tag": "DeletedNodes", "nodes": [Int*]}
25 {-# OPTIONS_GHC -fno-warn-orphans #-}
27 {-# LANGUAGE DataKinds #-}
28 {-# LANGUAGE DeriveGeneric #-}
29 {-# LANGUAGE FlexibleContexts #-}
30 {-# LANGUAGE FlexibleInstances #-}
31 {-# LANGUAGE NoImplicitPrelude #-}
32 {-# LANGUAGE OverloadedStrings #-}
33 {-# LANGUAGE RankNTypes #-}
34 {-# LANGUAGE ScopedTypeVariables #-}
35 {-# LANGUAGE TemplateHaskell #-}
36 {-# LANGUAGE TypeOperators #-}
38 module Gargantext.API.Node
41 import Control.Lens ((.~), (?~))
42 import Control.Monad ((>>), forM)
43 import Control.Monad.IO.Class (liftIO)
44 import Data.Aeson (FromJSON, ToJSON)
46 import Data.Monoid (mempty)
48 import Data.Text (Text())
49 import Data.Time (UTCTime)
50 import GHC.Generics (Generic)
51 import Gargantext.API.Auth (withAccess, PathId(..))
52 import Gargantext.API.Metrics
53 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
54 import Gargantext.API.Ngrams.NTree (MyTree)
55 import Gargantext.API.Search (SearchDocsAPI, searchDocs)
56 import Gargantext.API.Table
57 import Gargantext.API.Types
58 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
59 import Gargantext.Database.Config (nodeTypeId)
60 import Gargantext.Database.Facet (FacetDoc, OrderBy(..))
61 import Gargantext.Database.Node.Children (getChildren)
62 import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, getNode', deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..))
63 import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
64 import Gargantext.Database.Tree (treeDB)
65 import Gargantext.Database.Types.Node
66 import Gargantext.Database.Utils -- (Cmd, CmdM)
67 import Gargantext.Prelude
68 import Gargantext.Prelude.Utils (sha)
69 import Gargantext.Viz.Chart
70 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
72 import Servant.Multipart
73 import Servant.Swagger (HasSwagger(toSwagger))
74 import Servant.Swagger.Internal
75 import Test.QuickCheck (elements)
76 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
77 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
80 import qualified Gargantext.Text.List.Learn as Learn
81 import qualified Data.Vector as Vec
85 type NodesAPI = Delete '[JSON] Int
88 -- Be careful: really delete nodes
89 -- Access by admin only
90 nodesAPI :: [NodeId] -> GargServer NodesAPI
91 nodesAPI ids = deleteNodes ids
93 ------------------------------------------------------------------------
94 -- | TODO-ACCESS: access by admin only.
95 -- At first let's just have an isAdmin check.
96 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
97 -- To manage the Users roots
100 -- TODO needs design discussion.
101 type Roots = Get '[JSON] [Node HyperdataAny]
102 :<|> Put '[JSON] Int -- TODO
104 -- | TODO: access by admin only
105 roots :: GargServer Roots
106 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
107 :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
109 -------------------------------------------------------------------
110 -- | Node API Types management
111 -- TODO-ACCESS : access by users
112 -- No ownership check is needed if we strictly follow the capability model.
114 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
116 -- CanRenameNode (or part of CanEditNode?)
117 -- CanCreateChildren (PostNodeApi)
118 -- CanEditNode / CanPutNode TODO not implemented yet
120 -- CanPatch (TableNgramsApi)
124 type NodeAPI a = Get '[JSON] (Node a)
125 :<|> "rename" :> RenameApi
126 :<|> PostNodeApi -- TODO move to children POST
128 :<|> Delete '[JSON] Int
129 :<|> "children" :> ChildrenApi a
132 :<|> "table" :> TableApi
133 :<|> "ngrams" :> TableNgramsApi
134 -- :<|> "pairing" :> PairingApi
136 :<|> "category" :> CatApi
137 :<|> "search" :> SearchDocsAPI
140 :<|> "metrics" :> ScatterAPI
141 :<|> "chart" :> ChartApi
143 :<|> "tree" :> TreeApi
144 :<|> "phylo" :> PhyloAPI
145 :<|> "upload" :> UploadAPI
147 -- TODO-ACCESS: check userId CanRenameNode nodeId
148 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
149 type RenameApi = Summary " Rename Node"
150 :> ReqBody '[JSON] RenameNode
153 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
154 :> ReqBody '[JSON] PostNode
155 :> Post '[JSON] [NodeId]
157 type ChildrenApi a = Summary " Summary children"
158 :> QueryParam "type" NodeType
159 :> QueryParam "offset" Int
160 :> QueryParam "limit" Int
161 :> Get '[JSON] [Node a]
163 ------------------------------------------------------------------------
164 type NodeNodeAPI a = Get '[JSON] (Node a)
166 nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> CorpusId -> NodeId -> GargServer (NodeNodeAPI a)
167 nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
169 nodeNodeAPI' :: GargServer (NodeNodeAPI a)
170 nodeNodeAPI' = getNode nId p
174 ------------------------------------------------------------------------
175 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
176 nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
177 nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
179 nodeAPI' :: GargServer (NodeAPI a)
180 nodeAPI' = getNode id p
184 :<|> deleteNodeApi id
185 :<|> getChildren id p
189 :<|> apiNgramsTableCorpus id
190 -- :<|> getPairing id
191 -- :<|> getTableNgramsDoc id
204 deleteNodeApi id' = do
206 if _node_typename node == nodeTypeId NodeUser
207 then panic "not allowed" -- TODO add proper Right Management Type
214 ------------------------------------------------------------------------
215 data RenameNode = RenameNode { r_name :: Text }
218 -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
219 instance FromJSON RenameNode
220 instance ToJSON RenameNode
221 instance ToSchema RenameNode
222 instance Arbitrary RenameNode where
223 arbitrary = elements [RenameNode "test"]
224 ------------------------------------------------------------------------
225 data PostNode = PostNode { pn_name :: Text
226 , pn_typename :: NodeType}
229 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
230 instance FromJSON PostNode
231 instance ToJSON PostNode
232 instance ToSchema PostNode
233 instance Arbitrary PostNode where
234 arbitrary = elements [PostNode "Node test" NodeCorpus]
236 ------------------------------------------------------------------------
237 type CatApi = Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
238 :> ReqBody '[JSON] NodesToCategory
241 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
242 , ntc_category :: Int
246 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
247 instance FromJSON NodesToCategory
248 instance ToJSON NodesToCategory
249 instance ToSchema NodesToCategory
251 catApi :: CorpusId -> GargServer CatApi
254 putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
255 putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
257 ------------------------------------------------------------------------
258 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
259 type PairingApi = Summary " Pairing API"
260 :> QueryParam "view" TabType
261 -- TODO change TabType -> DocType (CorpusId for pairing)
262 :> QueryParam "offset" Int
263 :> QueryParam "limit" Int
264 :> QueryParam "order" OrderBy
265 :> Get '[JSON] [FacetDoc]
267 ------------------------------------------------------------------------
268 type ChartApi = Summary " Chart API"
269 :> QueryParam "from" UTCTime
270 :> QueryParam "to" UTCTime
271 :> Get '[JSON] (ChartMetrics Histo)
273 type PieApi = Summary " Chart API"
274 :> QueryParam "from" UTCTime
275 :> QueryParam "to" UTCTime
276 :> QueryParamR "ngramsType" TabType
277 :> Get '[JSON] (ChartMetrics Histo)
279 type TreeApi = Summary " Tree API"
280 :> QueryParam "from" UTCTime
281 :> QueryParam "to" UTCTime
282 :> QueryParamR "ngramsType" TabType
283 :> QueryParamR "listType" ListType
284 :> Get '[JSON] (ChartMetrics [MyTree])
286 -- Depending on the Type of the Node, we could post
287 -- New documents for a corpus
288 -- New map list terms
289 -- :<|> "process" :> MultipartForm MultipartData :> Post '[JSON] Text
291 -- To launch a query and update the corpus
292 -- :<|> "query" :> Capture "string" Text :> Get '[JSON] Text
294 ------------------------------------------------------------------------
297 NOTE: These instances are not necessary. However, these messages could be part
298 of a display function for NodeError/TreeError.
299 instance HasNodeError ServantErr where
300 _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
302 e = "Gargantext NodeError: "
303 mk NoListFound = err404 { errBody = e <> "No list found" }
304 mk NoRootFound = err404 { errBody = e <> "No Root found" }
305 mk NoCorpusFound = err404 { errBody = e <> "No Corpus found" }
306 mk NoUserFound = err404 { errBody = e <> "No User found" }
308 mk MkNode = err500 { errBody = e <> "Cannot mk node" }
309 mk NegativeId = err500 { errBody = e <> "Node with negative Id" }
310 mk UserNoParent = err500 { errBody = e <> "Should not have parent"}
311 mk HasParent = err500 { errBody = e <> "NodeType has parent" }
312 mk NotImplYet = err500 { errBody = e <> "Not implemented yet" }
313 mk ManyParents = err500 { errBody = e <> "Too many parents" }
314 mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user" }
316 instance HasTreeError ServantErr where
317 _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
320 mk NoRoot = err404 { errBody = e <> "Root node not found" }
321 mk EmptyRoot = err500 { errBody = e <> "Root node should not be empty" }
322 mk TooManyRoots = err500 { errBody = e <> "Too many root nodes" }
325 type TreeAPI = Get '[JSON] (Tree NodeTree)
327 treeAPI :: NodeId -> GargServer TreeAPI
330 ------------------------------------------------------------------------
331 -- | Check if the name is less than 255 char
332 rename :: NodeId -> RenameNode -> Cmd err [Int]
333 rename nId (RenameNode name') = U.update (U.Rename nId name')
335 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
336 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
338 putNode :: NodeId -> Cmd err Int
339 putNode = undefined -- TODO
341 query :: Monad m => Text -> m Text
344 -------------------------------------------------------------
346 data FileType = CSV | PresseRIS
347 deriving (Eq, Show, Generic)
349 instance ToSchema FileType
350 instance Arbitrary FileType
352 arbitrary = elements [CSV, PresseRIS]
353 instance ToParamSchema FileType
355 instance ToParamSchema (MultipartData Mem) where
356 toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
358 instance FromHttpApiData FileType
360 parseUrlPiece "CSV" = pure CSV
361 parseUrlPiece "PresseRis" = pure PresseRIS
362 parseUrlPiece _ = pure CSV -- TODO error here
365 instance (ToParamSchema a, HasSwagger sub) =>
366 HasSwagger (MultipartForm tag a :> sub) where
368 toSwagger _ = toSwagger (Proxy :: Proxy sub)
373 & schema .~ ParamOther sch
375 & in_ .~ ParamFormData
376 & paramSchema .~ toParamSchema (Proxy :: Proxy a)
378 type UploadAPI = Summary "Upload file(s) to a corpus"
379 :> MultipartForm Mem (MultipartData Mem)
380 :> QueryParam "fileType" FileType
381 :> Post '[JSON] [Hash]
383 --postUpload :: NodeId -> Maybe FileType -> GargServer UploadAPI
384 --postUpload :: NodeId -> GargServer UploadAPI
385 postUpload :: NodeId -> MultipartData Mem -> Maybe FileType -> Cmd err [Hash]
386 postUpload _ _ Nothing = panic "fileType is a required parameter"
387 postUpload _ multipartData (Just fileType) = do
388 putStrLn $ "File Type: " <> (show fileType)
390 putStrLn ("Inputs:" :: Text)
391 forM (inputs multipartData) $ \input -> do
392 putStrLn $ ("iName " :: Text) <> (iName input)
393 <> ("iValue " :: Text) <> (iValue input)
396 _ <- forM (files multipartData) $ \file -> do
397 let content = fdPayload file
398 putStrLn $ ("XXX " :: Text) <> (fdFileName file)
399 putStrLn $ ("YYY " :: Text) <> cs content
401 -- is <- inputs multipartData
403 pure $ map (sha . cs) is