]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Node.hs
[GRAPH] API update (WIP).
[gargantext.git] / src / Gargantext / API / Node.hs
1 {-|
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
8 Portability : POSIX
9
10 -- TODO-SECURITY: Critical
11
12 -- TODO-ACCESS: CanGetNode
13 -- TODO-EVENTS: No events as this is a read only query.
14 Node API
15
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*]}
22
23 -}
24
25 {-# OPTIONS_GHC -fno-warn-orphans #-}
26
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 #-}
37
38 module Gargantext.API.Node
39 where
40
41 import Control.Lens ((.~), (?~))
42 import Control.Monad ((>>), forM)
43 import Control.Monad.IO.Class (liftIO)
44 import Data.Aeson (FromJSON, ToJSON)
45 import Data.Maybe
46 import Data.Monoid (mempty)
47 import Data.Swagger
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)
71 import Servant
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(..))
78
79 {-
80 import qualified Gargantext.Text.List.Learn as Learn
81 import qualified Data.Vector as Vec
82 --}
83
84
85 type NodesAPI = Delete '[JSON] Int
86
87 -- | Delete Nodes
88 -- Be careful: really delete nodes
89 -- Access by admin only
90 nodesAPI :: [NodeId] -> GargServer NodesAPI
91 nodesAPI ids = deleteNodes ids
92
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
98 -- TODO-EVENTS:
99 -- PutNode ?
100 -- TODO needs design discussion.
101 type Roots = Get '[JSON] [Node HyperdataAny]
102 :<|> Put '[JSON] Int -- TODO
103
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
108
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.
113 --
114 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
115 -- SearchAPI)
116 -- CanRenameNode (or part of CanEditNode?)
117 -- CanCreateChildren (PostNodeApi)
118 -- CanEditNode / CanPutNode TODO not implemented yet
119 -- CanDeleteNode
120 -- CanPatch (TableNgramsApi)
121 -- CanFavorite
122 -- CanMoveToTrash
123
124 type NodeAPI a = Get '[JSON] (Node a)
125 :<|> "rename" :> RenameApi
126 :<|> PostNodeApi -- TODO move to children POST
127 :<|> Put '[JSON] Int
128 :<|> Delete '[JSON] Int
129 :<|> "children" :> ChildrenApi a
130
131 -- TODO gather it
132 :<|> "table" :> TableApi
133 :<|> "ngrams" :> TableNgramsApi
134 -- :<|> "pairing" :> PairingApi
135
136 :<|> "category" :> CatApi
137 :<|> "search" :> SearchDocsAPI
138
139 -- VIZ
140 :<|> "metrics" :> ScatterAPI
141 :<|> "chart" :> ChartApi
142 :<|> "pie" :> PieApi
143 :<|> "tree" :> TreeApi
144 :<|> "phylo" :> PhyloAPI
145 :<|> "upload" :> UploadAPI
146
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
151 :> Put '[JSON] [Int]
152
153 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
154 :> ReqBody '[JSON] PostNode
155 :> Post '[JSON] [NodeId]
156
157 type ChildrenApi a = Summary " Summary children"
158 :> QueryParam "type" NodeType
159 :> QueryParam "offset" Int
160 :> QueryParam "limit" Int
161 :> Get '[JSON] [Node a]
162
163 ------------------------------------------------------------------------
164 type NodeNodeAPI a = Get '[JSON] (Node a)
165
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'
168 where
169 nodeNodeAPI' :: GargServer (NodeNodeAPI a)
170 nodeNodeAPI' = getNode nId p
171
172
173
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'
178 where
179 nodeAPI' :: GargServer (NodeAPI a)
180 nodeAPI' = getNode id p
181 :<|> rename id
182 :<|> postNode uId id
183 :<|> putNode id
184 :<|> deleteNodeApi id
185 :<|> getChildren id p
186
187 -- TODO gather it
188 :<|> tableApi id
189 :<|> apiNgramsTableCorpus id
190 -- :<|> getPairing id
191 -- :<|> getTableNgramsDoc id
192
193 :<|> catApi id
194
195 :<|> searchDocs id
196
197 :<|> getScatter id
198 :<|> getChart id
199 :<|> getPie id
200 :<|> getTree id
201 :<|> phyloAPI id uId
202 :<|> postUpload id
203
204 deleteNodeApi id' = do
205 node <- getNode' id'
206 if _node_typename node == nodeTypeId NodeUser
207 then panic "not allowed" -- TODO add proper Right Management Type
208 else deleteNode id'
209
210 -- Annuaire
211 -- :<|> query
212
213
214 ------------------------------------------------------------------------
215 data RenameNode = RenameNode { r_name :: Text }
216 deriving (Generic)
217
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}
227 deriving (Generic)
228
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]
235
236 ------------------------------------------------------------------------
237 type CatApi = Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
238 :> ReqBody '[JSON] NodesToCategory
239 :> Put '[JSON] [Int]
240
241 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
242 , ntc_category :: Int
243 }
244 deriving (Generic)
245
246 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
247 instance FromJSON NodesToCategory
248 instance ToJSON NodesToCategory
249 instance ToSchema NodesToCategory
250
251 catApi :: CorpusId -> GargServer CatApi
252 catApi = putCat
253 where
254 putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
255 putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
256
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]
266
267 ------------------------------------------------------------------------
268 type ChartApi = Summary " Chart API"
269 :> QueryParam "from" UTCTime
270 :> QueryParam "to" UTCTime
271 :> Get '[JSON] (ChartMetrics Histo)
272
273 type PieApi = Summary " Chart API"
274 :> QueryParam "from" UTCTime
275 :> QueryParam "to" UTCTime
276 :> QueryParamR "ngramsType" TabType
277 :> Get '[JSON] (ChartMetrics Histo)
278
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])
285
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
290
291 -- To launch a query and update the corpus
292 -- :<|> "query" :> Capture "string" Text :> Get '[JSON] Text
293
294 ------------------------------------------------------------------------
295
296 {-
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")
301 where
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" }
307
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" }
315
316 instance HasTreeError ServantErr where
317 _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
318 where
319 e = "TreeError: "
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" }
323 -}
324
325 type TreeAPI = Get '[JSON] (Tree NodeTree)
326
327 treeAPI :: NodeId -> GargServer TreeAPI
328 treeAPI = treeDB
329
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')
334
335 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
336 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
337
338 putNode :: NodeId -> Cmd err Int
339 putNode = undefined -- TODO
340
341 query :: Monad m => Text -> m Text
342 query s = pure s
343
344 -------------------------------------------------------------
345 type Hash = Text
346 data FileType = CSV | PresseRIS
347 deriving (Eq, Show, Generic)
348
349 instance ToSchema FileType
350 instance Arbitrary FileType
351 where
352 arbitrary = elements [CSV, PresseRIS]
353 instance ToParamSchema FileType
354
355 instance ToParamSchema (MultipartData Mem) where
356 toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
357
358 instance FromHttpApiData FileType
359 where
360 parseUrlPiece "CSV" = pure CSV
361 parseUrlPiece "PresseRis" = pure PresseRIS
362 parseUrlPiece _ = pure CSV -- TODO error here
363
364
365 instance (ToParamSchema a, HasSwagger sub) =>
366 HasSwagger (MultipartForm tag a :> sub) where
367 -- TODO
368 toSwagger _ = toSwagger (Proxy :: Proxy sub)
369 & addParam param
370 where
371 param = mempty
372 & required ?~ True
373 & schema .~ ParamOther sch
374 sch = mempty
375 & in_ .~ ParamFormData
376 & paramSchema .~ toParamSchema (Proxy :: Proxy a)
377
378 type UploadAPI = Summary "Upload file(s) to a corpus"
379 :> MultipartForm Mem (MultipartData Mem)
380 :> QueryParam "fileType" FileType
381 :> Post '[JSON] [Hash]
382
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)
389 is <- liftIO $ do
390 putStrLn ("Inputs:" :: Text)
391 forM (inputs multipartData) $ \input -> do
392 putStrLn $ ("iName " :: Text) <> (iName input)
393 <> ("iValue " :: Text) <> (iValue input)
394 pure $ iName input
395
396 _ <- forM (files multipartData) $ \file -> do
397 let content = fdPayload file
398 putStrLn $ ("XXX " :: Text) <> (fdFileName file)
399 putStrLn $ ("YYY " :: Text) <> cs content
400 --pure $ cs content
401 -- is <- inputs multipartData
402
403 pure $ map (sha . cs) is