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