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