-- 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.
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Node
where
-import Control.Lens ((.~), (?~))
-import Control.Monad ((>>), forM)
-import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson.TH (deriveJSON)
import Data.Maybe
-import Data.Monoid (mempty)
import Data.Swagger
import Data.Text (Text())
-import Data.Time (UTCTime)
import GHC.Generics (Generic)
-import Gargantext.API.Auth (withAccess, PathId(..))
-import Gargantext.API.Metrics
-import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
-import Gargantext.API.Ngrams.NTree (MyTree)
-import Gargantext.API.Search (SearchDocsAPI, searchDocs)
-import Gargantext.API.Table
-import Gargantext.API.Types
-import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
-import Gargantext.Database.Config (nodeTypeId)
-import Gargantext.Database.Facet (FacetDoc, OrderBy(..))
-import Gargantext.Database.Node.Children (getChildren)
-import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, getNode', deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..))
-import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
-import Gargantext.Database.Tree (treeDB)
-import Gargantext.Database.Types.Node
-import Gargantext.Database.Utils -- (Cmd, CmdM)
-import Gargantext.Prelude
-import Gargantext.Prelude.Utils (sha)
-import Gargantext.Viz.Chart
-import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
import Servant
-import Servant.Multipart
-import Servant.Swagger (HasSwagger(toSwagger))
-import Servant.Swagger.Internal
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-import qualified Gargantext.Database.Node.Update as U (update, Update(..))
+
+import Gargantext.API.Admin.Auth.Types (PathId(..))
+import Gargantext.API.Admin.Auth (withAccess)
+import Gargantext.API.Metrics
+import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableCorpus)
+import Gargantext.API.Ngrams.Types (TabType(..))
+import Gargantext.API.Node.File
+import Gargantext.API.Node.FrameCalcUpload (FrameCalcUploadAPI, frameCalcUploadAPI)
+import Gargantext.API.Node.New
+import Gargantext.API.Prelude
+import Gargantext.API.Table
+import Gargantext.Core.Types (NodeTableResult)
+import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Core.Types.Main (Tree, NodeTree)
+import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Database.Action.Flow.Pairing (pairing)
+import Gargantext.Database.Admin.Types.Hyperdata
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude -- (Cmd, CmdM)
+import Gargantext.Database.Query.Facet (FacetDoc, OrderBy(..))
+import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Table.Node.Children (getChildren)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
+import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
+import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Query.Table.NodeNode
+import Gargantext.Database.Query.Tree (tree, TreeMode(..))
+import Gargantext.Prelude
+import Gargantext.Core.Viz.Phylo.Legacy.LegacyAPI (PhyloAPI, phyloAPI)
+import qualified Gargantext.API.Node.DocumentsFromWriteNodes as DocumentsFromWriteNodes
+import qualified Gargantext.API.Node.Share as Share
+import qualified Gargantext.API.Node.Update as Update
+import qualified Gargantext.API.Search as Search
+import qualified Gargantext.Database.Action.Delete as Action (deleteNode)
+import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
{-
-import qualified Gargantext.Text.List.Learn as Learn
+import qualified Gargantext.Core.Text.List.Learn as Learn
import qualified Data.Vector as Vec
--}
-
+-- | Admin NodesAPI
+-- TODO
type NodesAPI = Delete '[JSON] Int
-- | Delete Nodes
-- Be careful: really delete nodes
-- Access by admin only
nodesAPI :: [NodeId] -> GargServer NodesAPI
-nodesAPI ids = deleteNodes ids
+nodesAPI = deleteNodes
------------------------------------------------------------------------
-- | TODO-ACCESS: access by admin only.
-- TODO-EVENTS:
-- PutNode ?
-- TODO needs design discussion.
-type Roots = Get '[JSON] [Node HyperdataAny]
+type Roots = Get '[JSON] [Node HyperdataUser]
:<|> 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
type NodeAPI a = Get '[JSON] (Node a)
:<|> "rename" :> RenameApi
:<|> PostNodeApi -- TODO move to children POST
- :<|> Put '[JSON] Int
+ :<|> PostNodeAsync
+ :<|> FrameCalcUploadAPI
+ :<|> ReqBody '[JSON] a :> Put '[JSON] Int
+ :<|> "update" :> Update.API
:<|> Delete '[JSON] Int
:<|> "children" :> ChildrenApi a
-- TODO gather it
- :<|> "table" :> TableApi
- :<|> "ngrams" :> TableNgramsApi
- :<|> "pairing" :> PairingApi
+ :<|> "table" :> TableApi
+ :<|> "ngrams" :> TableNgramsApi
+
+ :<|> "category" :> CatApi
+ :<|> "score" :> ScoreApi
+ :<|> "search" :> (Search.API Search.SearchResult)
+ :<|> "share" :> Share.API
- :<|> "category" :> CatApi
- :<|> "search" :> SearchDocsAPI
+ -- Pairing utilities
+ :<|> "pairwith" :> PairWith
+ :<|> "pairs" :> Pairs
+ :<|> "pairing" :> PairingApi
-- VIZ
- :<|> "metrics" :> ScatterAPI
+ :<|> "metrics" :> ScatterAPI
:<|> "chart" :> ChartApi
:<|> "pie" :> PieApi
:<|> "tree" :> TreeApi
:<|> "phylo" :> PhyloAPI
- :<|> "upload" :> UploadAPI
+ -- :<|> "add" :> NodeAddAPI
+ :<|> "move" :> MoveAPI
+ :<|> "unpublish" :> Share.Unpublish
+
+ :<|> "file" :> FileApi
+ :<|> "async" :> FileAsyncApi
+
+ :<|> "documents-from-write-nodes" :> DocumentsFromWriteNodes.API
-- TODO-ACCESS: check userId CanRenameNode nodeId
-- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
:> 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 :: 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' = getNode nId p
-
-
+ nodeNodeAPI' = getNodeWith nId p
------------------------------------------------------------------------
-- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
-nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
-nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
+nodeAPI :: forall proxy a.
+ ( JSONB a
+ , FromJSON a
+ , ToJSON a
+ , MimeRender JSON a
+ , MimeUnrender JSON 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' = getNode id p
- :<|> rename id
- :<|> postNode uId id
- :<|> putNode id
- :<|> deleteNodeApi id
- :<|> getChildren id p
+ nodeAPI' = getNodeWith id' p
+ :<|> rename id'
+ :<|> postNode uId id'
+ :<|> postNodeAsyncAPI uId id'
+ :<|> frameCalcUploadAPI uId id'
+ :<|> putNode id'
+ :<|> Update.api uId id'
+ :<|> Action.deleteNode (RootId $ NodeId uId) id'
+ :<|> getChildren id' p
-- TODO gather it
- :<|> tableApi id
- :<|> apiNgramsTableCorpus id
- :<|> getPairing id
- -- :<|> getTableNgramsDoc id
-
- :<|> catApi id
-
- :<|> searchDocs id
-
- :<|> getScatter id
- :<|> getChart id
- :<|> getPie id
- :<|> getTree id
- :<|> phyloAPI id uId
- :<|> 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'
-
- -- Annuaire
- -- :<|> query
+ :<|> tableApi id'
+ :<|> apiNgramsTableCorpus id'
+
+ :<|> catApi id'
+ :<|> scoreApi id'
+ :<|> Search.api id'
+ :<|> Share.api (RootId $ NodeId uId) id'
+ -- Pairing Tools
+ :<|> pairWith id'
+ :<|> pairs id'
+ :<|> getPair id'
+
+ -- VIZ
+ :<|> scatterApi id'
+ :<|> chartApi id'
+ :<|> pieApi id'
+ :<|> treeApi id'
+ :<|> phyloAPI id' uId
+ :<|> moveNode (RootId $ NodeId uId) id'
+ -- :<|> nodeAddAPI id'
+ -- :<|> postUpload id'
+ :<|> Share.unPublish id'
+
+ :<|> fileApi uId id'
+ :<|> fileAsyncApi uId id'
+
+ :<|> DocumentsFromWriteNodes.api uId 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
-instance Arbitrary RenameNode where
- arbitrary = elements [RenameNode "test"]
------------------------------------------------------------------------
-data PostNode = PostNode { pn_name :: Text
- , pn_typename :: NodeType}
- deriving (Generic)
-
--- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
-instance FromJSON PostNode
-instance ToJSON PostNode
-instance ToSchema PostNode
-instance Arbitrary PostNode where
- arbitrary = elements [PostNode "Node test" NodeCorpus]
-
------------------------------------------------------------------------
type CatApi = Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
:> ReqBody '[JSON] NodesToCategory
putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
------------------------------------------------------------------------
--- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
-type PairingApi = Summary " Pairing API"
- :> QueryParam "view" TabType
- -- TODO change TabType -> DocType (CorpusId for pairing)
- :> QueryParam "offset" Int
- :> QueryParam "limit" Int
- :> QueryParam "order" OrderBy
- :> Get '[JSON] [FacetDoc]
+type ScoreApi = Summary " To Score NodeNodes"
+ :> ReqBody '[JSON] NodesToScore
+ :> Put '[JSON] [Int]
-------------------------------------------------------------------------
-type ChartApi = Summary " Chart API"
- :> QueryParam "from" UTCTime
- :> QueryParam "to" UTCTime
- :> 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
+data NodesToScore = NodesToScore { nts_nodesId :: [NodeId]
+ , nts_score :: Int
+ }
+ deriving (Generic)
+
+-- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
+instance FromJSON NodesToScore
+instance ToJSON NodesToScore
+instance ToSchema NodesToScore
+
+scoreApi :: CorpusId -> GargServer ScoreApi
+scoreApi = putScore
+ where
+ putScore :: CorpusId -> NodesToScore -> Cmd err [Int]
+ putScore cId cs' = nodeNodesScore $ map (\n -> (cId, n, nts_score cs')) (nts_nodesId cs')
------------------------------------------------------------------------
+-- 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 "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
+ :> QueryParam "list_id" ListId
+ :> Post '[JSON] Int
+
+pairWith :: CorpusId -> GargServer PairWith
+pairWith cId aId lId = do
+ r <- pairing cId aId lId
+ _ <- insertNodeNode [ NodeNode { _nn_node1_id = cId
+ , _nn_node2_id = aId
+ , _nn_score = Nothing
+ , _nn_category = Nothing }]
+ pure r
-{-
-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 Nothing) -- panic "HasNodeError ServantErr: not a prism")
- where
- 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 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" }
-
-instance HasTreeError ServantErr where
- _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 = Get '[JSON] (Tree NodeTree)
+------------------------------------------------------------------------
+type TreeAPI = QueryParams "type" NodeType
+ :> Get '[JSON] (Tree NodeTree)
+ :<|> "first-level"
+ :> QueryParams "type" NodeType
+ :> Get '[JSON] (Tree NodeTree)
treeAPI :: NodeId -> GargServer TreeAPI
-treeAPI = treeDB
+treeAPI id = tree TreeAdvanced id
+ :<|> tree TreeFirstLevel id
------------------------------------------------------------------------
--- | Check if the name is less than 255 char
+-- | TODO 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')
-postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
-postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
-
-putNode :: NodeId -> Cmd err Int
-putNode = undefined -- TODO
-
-query :: Monad m => Text -> m Text
-query s = pure s
+putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
+ => NodeId
+ -> a
+ -> Cmd err Int
+putNode n h = fromIntegral <$> updateHyperdata n h
-------------------------------------------------------------
-type Hash = Text
-data FileType = CSV | PresseRIS
- deriving (Eq, Show, Generic)
+type MoveAPI = Summary "Move Node endpoint"
+ :> Capture "parent_id" ParentId
+ :> Put '[JSON] [Int]
+
+moveNode :: User
+ -> NodeId
+ -> ParentId
+ -> Cmd err [Int]
+moveNode _u n p = update (Move n p)
+-------------------------------------------------------------
-instance ToSchema FileType
-instance Arbitrary FileType
- where
- arbitrary = elements [CSV, PresseRIS]
-instance ToParamSchema FileType
-instance ToParamSchema (MultipartData Mem) where
- toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
+$(deriveJSON (unPrefix "r_" ) ''RenameNode )
+instance ToSchema RenameNode
+instance Arbitrary RenameNode where
+ arbitrary = elements [RenameNode "test"]
-instance FromHttpApiData FileType
- where
- parseUrlPiece "CSV" = pure CSV
- parseUrlPiece "PresseRis" = pure PresseRIS
- parseUrlPiece _ = pure CSV -- TODO error here
-
-
-instance (ToParamSchema a, HasSwagger sub) =>
- HasSwagger (MultipartForm tag a :> sub) where
- -- TODO
- toSwagger _ = toSwagger (Proxy :: Proxy sub)
- & addParam param
- where
- param = mempty
- & required ?~ True
- & schema .~ ParamOther sch
- sch = mempty
- & in_ .~ ParamFormData
- & paramSchema .~ toParamSchema (Proxy :: Proxy a)
-
-type UploadAPI = Summary "Upload file(s) to a corpus"
- :> MultipartForm Mem (MultipartData Mem)
- :> QueryParam "fileType" FileType
- :> Post '[JSON] [Hash]
-
---postUpload :: NodeId -> Maybe FileType -> GargServer UploadAPI
---postUpload :: NodeId -> GargServer UploadAPI
-postUpload :: NodeId -> MultipartData Mem -> Maybe FileType -> Cmd err [Hash]
-postUpload _ _ Nothing = panic "fileType is a required parameter"
-postUpload _ multipartData (Just fileType) = do
- putStrLn $ "File Type: " <> (show fileType)
- is <- liftIO $ do
- putStrLn ("Inputs:" :: Text)
- forM (inputs multipartData) $ \input -> do
- putStrLn $ ("iName " :: Text) <> (iName input)
- <> ("iValue " :: Text) <> (iValue input)
- pure $ iName input
-
- _ <- forM (files multipartData) $ \file -> do
- let content = fdPayload file
- putStrLn $ ("XXX " :: Text) <> (fdFileName file)
- putStrLn $ ("YYY " :: Text) <> cs content
- --pure $ cs content
- -- is <- inputs multipartData
-
- pure $ map (sha . cs) is
+
+-------------------------------------------------------------