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 -- TODO-ACCESS: access by admin only.
  17 --              At first let's just have an isAdmin check.
  18 --              Later: check userId CanDeleteNodes Nothing
  19 -- TODO-EVENTS: DeletedNodes [NodeId]
  20 --              {"tag": "DeletedNodes", "nodes": [Int*]}
  21
  22 -}
  23
  24 {-# OPTIONS_GHC -fno-warn-orphans #-}
  25
  26 {-# LANGUAGE ScopedTypeVariables  #-}
  27 {-# LANGUAGE TemplateHaskell      #-}
  28 {-# LANGUAGE TypeOperators        #-}
  29
  30 module Gargantext.API.Node
  31   where
  32
  33 import Data.Aeson (FromJSON, ToJSON)
  34 import Data.Maybe
  35 import Data.Swagger
  36 import Data.Text (Text())
  37 import Data.Time (UTCTime)
  38 import GHC.Generics (Generic)
  39 import Gargantext.API.Admin.Auth (withAccess, PathId(..))
  40 import Gargantext.API.Prelude
  41 import Gargantext.API.Metrics
  42 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR)
  43 import Gargantext.API.Ngrams.NTree (MyTree)
  44 import Gargantext.API.Node.New
  45 import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
  46 import Gargantext.API.Table
  47 import Gargantext.Core.Types (NodeTableResult)
  48 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
  49 import Gargantext.Database.Action.Flow.Pairing (pairing)
  50 import Gargantext.Database.Query.Facet (FacetDoc, OrderBy(..))
  51 import Gargantext.Database.Query.Table.Node
  52 import Gargantext.Database.Query.Table.Node.Children (getChildren)
  53 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  54 import Gargantext.Database.Query.Table.Node.User
  55 import Gargantext.Database.Query.Tree (treeDB)
  56 import Gargantext.Database.Admin.Config (nodeTypeId)
  57 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
  58 import Gargantext.Database.Admin.Types.Node
  59 import Gargantext.Database.Prelude -- (Cmd, CmdM)
  60 import Gargantext.Database.Schema.Node (_node_typename)
  61 import Gargantext.Database.Query.Table.NodeNode
  62 import Gargantext.Prelude
  63 import Gargantext.Viz.Chart
  64 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
  65 import Servant
  66 import Test.QuickCheck (elements)
  67 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  68 import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
  69
  70 {-
  71 import qualified Gargantext.Text.List.Learn as Learn
  72 import qualified Data.Vector as Vec
  73 --}
  74
  75 type NodesAPI  = Delete '[JSON] Int
  76
  77 -- | Delete Nodes
  78 -- Be careful: really delete nodes
  79 -- Access by admin only
  80 nodesAPI :: [NodeId] -> GargServer NodesAPI
  81 nodesAPI ids = deleteNodes ids
  82
  83 ------------------------------------------------------------------------
  84 -- | TODO-ACCESS: access by admin only.
  85 -- At first let's just have an isAdmin check.
  86 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
  87 -- To manage the Users roots
  88 -- TODO-EVENTS:
  89 --   PutNode ?
  90 -- TODO needs design discussion.
  91 type Roots =  Get    '[JSON] [Node HyperdataUser]
  92          :<|> Put    '[JSON] Int -- TODO
  93
  94 -- | TODO: access by admin only
  95 roots :: GargServer Roots
  96 roots = getNodesWithParentId Nothing
  97     :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
  98
  99 -------------------------------------------------------------------
 100 -- | Node API Types management
 101 -- TODO-ACCESS : access by users
 102 -- No ownership check is needed if we strictly follow the capability model.
 103 --
 104 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
 105 --             SearchAPI)
 106 -- CanRenameNode (or part of CanEditNode?)
 107 -- CanCreateChildren (PostNodeApi)
 108 -- CanEditNode / CanPutNode TODO not implemented yet
 109 -- CanDeleteNode
 110 -- CanPatch (TableNgramsApi)
 111 -- CanFavorite
 112 -- CanMoveToTrash
 113
 114 type NodeAPI a = Get '[JSON] (Node a)
 115              :<|> "rename" :> RenameApi
 116              :<|> PostNodeApi -- TODO move to children POST
 117              :<|> PostNodeAsync
 118              :<|> ReqBody '[JSON] a :> Put    '[JSON] Int
 119              :<|> Delete '[JSON] Int
 120              :<|> "children"  :> ChildrenApi a
 121
 122              -- TODO gather it
 123              :<|> "table"     :> TableApi
 124              :<|> "ngrams"    :> TableNgramsApi
 125
 126              :<|> "category"  :> CatApi
 127              :<|> "search"     :> SearchDocsAPI
 128
 129              -- Pairing utilities
 130              :<|> "pairwith"   :> PairWith
 131              :<|> "pairs"      :> Pairs
 132              :<|> "pairing"    :> PairingApi
 133              :<|> "searchPair" :> SearchPairsAPI
 134
 135              -- VIZ
 136              :<|> "metrics" :> ScatterAPI
 137              :<|> "chart"     :> ChartApi
 138              :<|> "pie"       :> PieApi
 139              :<|> "tree"      :> TreeApi
 140              :<|> "phylo"     :> PhyloAPI
 141              -- :<|> "add"       :> NodeAddAPI
 142
 143 -- TODO-ACCESS: check userId CanRenameNode nodeId
 144 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 145 type RenameApi = Summary " Rename Node"
 146                :> ReqBody '[JSON] RenameNode
 147                :> Put     '[JSON] [Int]
 148
 149 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 150                  :> ReqBody '[JSON] PostNode
 151                  :> Post    '[JSON] [NodeId]
 152
 153 type ChildrenApi a = Summary " Summary children"
 154                  :> QueryParam "type"   NodeType
 155                  :> QueryParam "offset" Int
 156                  :> QueryParam "limit"  Int
 157                  -- :> Get '[JSON] [Node a]
 158                  :> Get '[JSON] (NodeTableResult a)
 159
 160 ------------------------------------------------------------------------
 161 type NodeNodeAPI a = Get '[JSON] (Node a)
 162
 163 nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a)
 164             => proxy a
 165             -> UserId
 166             -> CorpusId
 167             -> NodeId
 168             -> GargServer (NodeNodeAPI a)
 169 nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
 170   where
 171     nodeNodeAPI' :: GargServer (NodeNodeAPI a)
 172     nodeNodeAPI' = getNodeWith nId p
 173
 174 ------------------------------------------------------------------------
 175 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 176 nodeAPI :: forall proxy a.
 177        ( JSONB a
 178        , FromJSON a
 179        , ToJSON a
 180        ) => proxy a
 181          -> UserId
 182          -> NodeId
 183          -> GargServer (NodeAPI a)
 184 nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id') nodeAPI'
 185   where
 186     nodeAPI' :: GargServer (NodeAPI a)
 187     nodeAPI' =  getNodeWith   id' p
 188            :<|> rename        id'
 189            :<|> postNode  uId id'
 190            :<|> postNodeAsyncAPI  uId id'
 191            :<|> putNode       id'
 192            :<|> deleteNodeApi id'
 193            :<|> getChildren   id' p
 194
 195            -- TODO gather it
 196            :<|> tableApi             id'
 197            :<|> apiNgramsTableCorpus id'
 198
 199            :<|> catApi      id'
 200
 201            :<|> searchDocs  id'
 202            -- Pairing Tools
 203            :<|> pairWith    id'
 204            :<|> pairs       id'
 205            :<|> getPair     id'
 206            :<|> searchPairs id'
 207
 208            :<|> getScatter id'
 209            :<|> getChart   id'
 210            :<|> getPie     id'
 211            :<|> getTree    id'
 212            :<|> phyloAPI   id' uId
 213            -- :<|> nodeAddAPI id'
 214            -- :<|> postUpload id'
 215
 216     deleteNodeApi id'' = do
 217       node' <- getNode id''
 218       if _node_typename node' == nodeTypeId NodeUser
 219          then panic "not allowed"  -- TODO add proper Right Management Type
 220          else deleteNode id''
 221
 222 ------------------------------------------------------------------------
 223 data RenameNode = RenameNode { r_name :: Text }
 224   deriving (Generic)
 225
 226 -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
 227 instance FromJSON  RenameNode
 228 instance ToJSON    RenameNode
 229 instance ToSchema  RenameNode
 230 instance Arbitrary RenameNode where
 231   arbitrary = elements [RenameNode "test"]
 232 ------------------------------------------------------------------------
 233 ------------------------------------------------------------------------
 234 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 235             :> ReqBody '[JSON] NodesToCategory
 236             :> Put     '[JSON] [Int]
 237
 238 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 239                                        , ntc_category :: Int
 240                                        }
 241   deriving (Generic)
 242
 243 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 244 instance FromJSON  NodesToCategory
 245 instance ToJSON    NodesToCategory
 246 instance ToSchema  NodesToCategory
 247
 248 catApi :: CorpusId -> GargServer CatApi
 249 catApi = putCat
 250   where
 251     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 252     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 253
 254 ------------------------------------------------------------------------
 255 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 256 -- Pairing utilities to move elsewhere
 257 type PairingApi = Summary " Pairing API"
 258               :> QueryParam "view"   TabType
 259               -- TODO change TabType -> DocType (CorpusId for pairing)
 260               :> QueryParam "offset" Int
 261               :> QueryParam "limit"  Int
 262               :> QueryParam "order"  OrderBy
 263               :> Get '[JSON] [FacetDoc]
 264
 265 ----------
 266 type Pairs    = Summary "List of Pairs"
 267               :> Get '[JSON] [AnnuaireId]
 268 pairs :: CorpusId -> GargServer Pairs
 269 pairs cId = do
 270   ns <- getNodeNode cId
 271   pure $ map _nn_node2_id ns
 272
 273 type PairWith = Summary "Pair a Corpus with an Annuaire"
 274               :> "annuaire" :> Capture "annuaire_id" AnnuaireId
 275               :> "list"     :> Capture "list_id"     ListId
 276               :> Post '[JSON] Int
 277
 278 pairWith :: CorpusId -> GargServer PairWith
 279 pairWith cId aId lId = do
 280   r <- pairing cId aId lId
 281   _ <- insertNodeNode [ NodeNode cId aId Nothing Nothing]
 282   pure r
 283
 284 ------------------------------------------------------------------------
 285 type ChartApi = Summary " Chart API"
 286               :> QueryParam "from" UTCTime
 287               :> QueryParam "to"   UTCTime
 288               :> Get '[JSON] (ChartMetrics Histo)
 289
 290 type PieApi = Summary " Chart API"
 291            :> QueryParam "from" UTCTime
 292            :> QueryParam "to"   UTCTime
 293            :> QueryParamR "ngramsType" TabType
 294            :> Get '[JSON] (ChartMetrics Histo)
 295
 296 type TreeApi = Summary " Tree API"
 297            :> QueryParam "from" UTCTime
 298            :> QueryParam "to"   UTCTime
 299            :> QueryParamR "ngramsType" TabType
 300            :> QueryParamR "listType"   ListType
 301            :> Get '[JSON] (ChartMetrics [MyTree])
 302
 303                 -- Depending on the Type of the Node, we could post
 304                 -- New documents for a corpus
 305                 -- New map list terms
 306              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 307
 308 ------------------------------------------------------------------------
 309
 310 type TreeAPI   = QueryParams "type" NodeType :> Get '[JSON] (Tree NodeTree)
 311
 312 treeAPI :: NodeId -> GargServer TreeAPI
 313 treeAPI = treeDB
 314
 315 ------------------------------------------------------------------------
 316 -- | Check if the name is less than 255 char
 317 rename :: NodeId -> RenameNode -> Cmd err [Int]
 318 rename nId (RenameNode name') = U.update (U.Rename nId name')
 319
 320 putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
 321         => NodeId
 322         -> a
 323         -> Cmd err Int
 324 putNode n h = fromIntegral <$> updateHyperdata n h
 325 -------------------------------------------------------------
 326
 327