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