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 Gargantext.API.Admin.Auth (withAccess, PathId(..))
  40 import Gargantext.API.Metrics
  41 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus)
  42 import Gargantext.API.Node.New
  43 import Gargantext.API.Prelude
  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.Core.Utils.Prefix (unPrefix)
  49 import Gargantext.Database.Action.Flow.Pairing (pairing)
  50 import Gargantext.Database.Admin.Types.Hyperdata
  51 import Gargantext.Database.Admin.Types.Node
  52 import Gargantext.Database.Prelude -- (Cmd, CmdM)
  53 import Gargantext.Database.Query.Facet (FacetDoc, OrderBy(..))
  54 import Gargantext.Database.Query.Table.Node
  55 import Gargantext.Database.Query.Table.Node.Children (getChildren)
  56 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
  57 import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
  58 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  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.API.Search as Search
  69 import qualified Gargantext.Database.Action.Delete as Action (deleteNode)
  70 import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
  71
  72 {-
  73 import qualified Gargantext.Text.List.Learn as Learn
  74 import qualified Data.Vector as Vec
  75 --}
  76
  77 -- | Admin NodesAPI
  78 -- TODO
  79 type NodesAPI  = Delete '[JSON] Int
  80
  81 -- | Delete Nodes
  82 -- Be careful: really delete nodes
  83 -- Access by admin only
  84 nodesAPI :: [NodeId] -> GargServer NodesAPI
  85 nodesAPI = deleteNodes
  86
  87 ------------------------------------------------------------------------
  88 -- | TODO-ACCESS: access by admin only.
  89 -- At first let's just have an isAdmin check.
  90 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
  91 -- To manage the Users roots
  92 -- TODO-EVENTS:
  93 --   PutNode ?
  94 -- TODO needs design discussion.
  95 type Roots =  Get    '[JSON] [Node HyperdataUser]
  96          :<|> Put    '[JSON] Int -- TODO
  97
  98 -- | TODO: access by admin only
  99 roots :: GargServer Roots
 100 roots = getNodesWithParentId Nothing
 101     :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 102
 103 -------------------------------------------------------------------
 104 -- | Node API Types management
 105 -- TODO-ACCESS : access by users
 106 -- No ownership check is needed if we strictly follow the capability model.
 107 --
 108 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
 109 --             SearchAPI)
 110 -- CanRenameNode (or part of CanEditNode?)
 111 -- CanCreateChildren (PostNodeApi)
 112 -- CanEditNode / CanPutNode TODO not implemented yet
 113 -- CanDeleteNode
 114 -- CanPatch (TableNgramsApi)
 115 -- CanFavorite
 116 -- CanMoveToTrash
 117
 118 type NodeAPI a = Get '[JSON] (Node a)
 119              :<|> "rename" :> RenameApi
 120              :<|> PostNodeApi -- TODO move to children POST
 121              :<|> PostNodeAsync
 122              :<|> ReqBody '[JSON] a :> Put    '[JSON] Int
 123              :<|> "update"     :> Update.API
 124              :<|> Delete '[JSON] Int
 125              :<|> "children"  :> ChildrenApi a
 126
 127              -- TODO gather it
 128              :<|> "table"      :> TableApi
 129              :<|> "ngrams"     :> TableNgramsApi
 130
 131              :<|> "category"   :> CatApi
 132              :<|> "search"     :> (Search.API Search.SearchResult)
 133              :<|> "share"      :> Share.API
 134
 135              -- Pairing utilities
 136              :<|> "pairwith"   :> PairWith
 137              :<|> "pairs"      :> Pairs
 138              :<|> "pairing"    :> PairingApi
 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" :> Share.Unpublish
 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            :<|> Search.api  id'
 209            :<|> Share.api   id'
 210            -- Pairing Tools
 211            :<|> pairWith    id'
 212            :<|> pairs       id'
 213            :<|> getPair     id'
 214
 215            :<|> scatterApi id'
 216            :<|> chartApi   id'
 217            :<|> pieApi     id'
 218            :<|> treeApi    id'
 219            :<|> phyloAPI   id' uId
 220            :<|> moveNode   (RootId $ NodeId uId) id'
 221            -- :<|> nodeAddAPI id'
 222            -- :<|> postUpload id'
 223            :<|> Share.unPublish id'
 224
 225
 226 ------------------------------------------------------------------------
 227 data RenameNode = RenameNode { r_name :: Text }
 228   deriving (Generic)
 229
 230 ------------------------------------------------------------------------
 231 ------------------------------------------------------------------------
 232 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 233             :> ReqBody '[JSON] NodesToCategory
 234             :> Put     '[JSON] [Int]
 235
 236 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 237                                        , ntc_category :: Int
 238                                        }
 239   deriving (Generic)
 240
 241 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 242 instance FromJSON  NodesToCategory
 243 instance ToJSON    NodesToCategory
 244 instance ToSchema  NodesToCategory
 245
 246 catApi :: CorpusId -> GargServer CatApi
 247 catApi = putCat
 248   where
 249     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 250     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 251
 252 ------------------------------------------------------------------------
 253 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 254 -- Pairing utilities to move elsewhere
 255 type PairingApi = Summary " Pairing API"
 256                 :> QueryParam "view"   TabType
 257                 -- TODO change TabType -> DocType (CorpusId for pairing)
 258                 :> QueryParam "offset" Int
 259                 :> QueryParam "limit"  Int
 260                 :> QueryParam "order"  OrderBy
 261                 :> Get '[JSON] [FacetDoc]
 262
 263 ----------
 264 type Pairs    = Summary "List of Pairs"
 265               :> Get '[JSON] [AnnuaireId]
 266 pairs :: CorpusId -> GargServer Pairs
 267 pairs cId = do
 268   ns <- getNodeNode cId
 269   pure $ map _nn_node2_id ns
 270
 271 type PairWith = Summary "Pair a Corpus with an Annuaire"
 272               :> "annuaire" :> Capture "annuaire_id" AnnuaireId
 273               :> QueryParam "list_id"     ListId
 274               :> Post '[JSON] Int
 275
 276 pairWith :: CorpusId -> GargServer PairWith
 277 pairWith cId aId lId = do
 278   r <- pairing cId aId lId
 279   _ <- insertNodeNode [ NodeNode cId aId Nothing Nothing]
 280   pure r
 281
 282
 283 ------------------------------------------------------------------------
 284 type TreeAPI   = QueryParams "type" NodeType :> Get '[JSON] (Tree NodeTree)
 285
 286 treeAPI :: NodeId -> GargServer TreeAPI
 287 treeAPI = tree Advanced
 288
 289 ------------------------------------------------------------------------
 290 -- | TODO Check if the name is less than 255 char
 291 rename :: NodeId -> RenameNode -> Cmd err [Int]
 292 rename nId (RenameNode name') = U.update (U.Rename nId name')
 293
 294 putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
 295         => NodeId
 296         -> a
 297         -> Cmd err Int
 298 putNode n h = fromIntegral <$> updateHyperdata n h
 299
 300 -------------------------------------------------------------
 301 type MoveAPI  = Summary "Move Node endpoint"
 302               :> Capture "parent_id" ParentId
 303               :> Put '[JSON] [Int]
 304
 305 moveNode :: User
 306          -> NodeId
 307          -> ParentId
 308          -> Cmd err [Int]
 309 moveNode _u n p = update (Move n p)
 310 -------------------------------------------------------------
 311
 312
 313 $(deriveJSON (unPrefix "r_"       ) ''RenameNode )
 314 instance ToSchema  RenameNode
 315 instance Arbitrary RenameNode where
 316   arbitrary = elements [RenameNode "test"]
 317
 318
 319 -------------------------------------------------------------