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 Servant
  39 import Test.QuickCheck (elements)
  40 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  41
  42 import Gargantext.API.Admin.Auth (withAccess, PathId(..))
  43 import Gargantext.API.Prelude
  44 import Gargantext.API.Metrics
  45 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus)
  46 import Gargantext.API.Node.New
  47 import qualified Gargantext.API.Node.Share  as Share
  48 import qualified Gargantext.API.Node.Update as Update
  49
  50 import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
  51 import Gargantext.API.Table
  52 import Gargantext.Core.Types (NodeTableResult)
  53 import Gargantext.Core.Types.Main (Tree, NodeTree)
  54 import Gargantext.Database.Action.Flow.Pairing (pairing)
  55 import Gargantext.Database.Query.Facet (FacetDoc, OrderBy(..))
  56 import Gargantext.Core.Types.Individu (User(..))
  57 import Gargantext.Database.Query.Table.Node
  58 import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
  59 import Gargantext.Database.Query.Table.Node.Children (getChildren)
  60 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  61 import Gargantext.Database.Query.Table.Node.User
  62 import Gargantext.Database.Query.Tree (tree, TreeMode(..))
  63 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
  64 import Gargantext.Database.Admin.Types.Node
  65 import Gargantext.Database.Prelude -- (Cmd, CmdM)
  66 import Gargantext.Database.Query.Table.NodeNode
  67 import Gargantext.Prelude
  68 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
  69 import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
  70 import qualified Gargantext.Database.Action.Delete as Action (deleteNode)
  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"     :> SearchDocsAPI
 133              :<|> "share"      :> Share.API
 134
 135              -- Pairing utilities
 136              :<|> "pairwith"   :> PairWith
 137              :<|> "pairs"      :> Pairs
 138              :<|> "pairing"    :> PairingApi
 139              :<|> "searchPair" :> SearchPairsAPI
 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
 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
 225 ------------------------------------------------------------------------
 226 data RenameNode = RenameNode { r_name :: Text }
 227   deriving (Generic)
 228
 229 -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
 230 instance FromJSON  RenameNode
 231 instance ToJSON    RenameNode
 232 instance ToSchema  RenameNode
 233 instance Arbitrary RenameNode where
 234   arbitrary = elements [RenameNode "test"]
 235 ------------------------------------------------------------------------
 236 ------------------------------------------------------------------------
 237 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 238             :> ReqBody '[JSON] NodesToCategory
 239             :> Put     '[JSON] [Int]
 240
 241 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 242                                        , ntc_category :: Int
 243                                        }
 244   deriving (Generic)
 245
 246 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 247 instance FromJSON  NodesToCategory
 248 instance ToJSON    NodesToCategory
 249 instance ToSchema  NodesToCategory
 250
 251 catApi :: CorpusId -> GargServer CatApi
 252 catApi = putCat
 253   where
 254     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 255     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 256
 257 ------------------------------------------------------------------------
 258 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 259 -- Pairing utilities to move elsewhere
 260 type PairingApi = Summary " Pairing API"
 261                 :> QueryParam "view"   TabType
 262                 -- TODO change TabType -> DocType (CorpusId for pairing)
 263                 :> QueryParam "offset" Int
 264                 :> QueryParam "limit"  Int
 265                 :> QueryParam "order"  OrderBy
 266                 :> Get '[JSON] [FacetDoc]
 267
 268 ----------
 269 type Pairs    = Summary "List of Pairs"
 270               :> Get '[JSON] [AnnuaireId]
 271 pairs :: CorpusId -> GargServer Pairs
 272 pairs cId = do
 273   ns <- getNodeNode cId
 274   pure $ map _nn_node2_id ns
 275
 276 type PairWith = Summary "Pair a Corpus with an Annuaire"
 277               :> "annuaire" :> Capture "annuaire_id" AnnuaireId
 278               :> "list"     :> Capture "list_id"     ListId
 279               :> Post '[JSON] Int
 280
 281 pairWith :: CorpusId -> GargServer PairWith
 282 pairWith cId aId lId = do
 283   r <- pairing cId aId lId
 284   _ <- insertNodeNode [ NodeNode cId aId Nothing Nothing]
 285   pure r
 286
 287 ------------------------------------------------------------------------
 288
 289 ------------------------------------------------------------------------
 290 type TreeAPI   = QueryParams "type" NodeType :> Get '[JSON] (Tree NodeTree)
 291
 292 treeAPI :: NodeId -> GargServer TreeAPI
 293 treeAPI = tree Advanced
 294
 295 ------------------------------------------------------------------------
 296 -- | TODO Check if the name is less than 255 char
 297 rename :: NodeId -> RenameNode -> Cmd err [Int]
 298 rename nId (RenameNode name') = U.update (U.Rename nId name')
 299
 300 putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
 301         => NodeId
 302         -> a
 303         -> Cmd err Int
 304 putNode n h = fromIntegral <$> updateHyperdata n h
 305
 306 -------------------------------------------------------------
 307 type MoveAPI  = Summary "Move Node endpoint"
 308               :> Capture "parent_id" ParentId
 309               :> Put '[JSON] [Int]
 310
 311 moveNode :: User
 312          -> NodeId
 313          -> ParentId
 314          -> Cmd err [Int]
 315 moveNode _u n p = update (Move n p)
 316
 317 -------------------------------------------------------------