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 DataKinds            #-}
  27 {-# LANGUAGE DeriveGeneric        #-}
  28 {-# LANGUAGE FlexibleContexts     #-}
  29 {-# LANGUAGE FlexibleInstances    #-}
  30 {-# LANGUAGE NoImplicitPrelude    #-}
  31 {-# LANGUAGE OverloadedStrings    #-}
  32 {-# LANGUAGE RankNTypes           #-}
  33 {-# LANGUAGE ScopedTypeVariables  #-}
  34 {-# LANGUAGE TemplateHaskell      #-}
  35 {-# LANGUAGE TypeOperators        #-}
  36
  37 module Gargantext.API.Node
  38   where
  39
  40 import Data.Aeson (FromJSON, ToJSON)
  41 import Data.Maybe
  42 import Data.Swagger
  43 import Data.Text (Text())
  44 import Data.Time (UTCTime)
  45 import GHC.Generics (Generic)
  46 import Gargantext.API.Admin.Auth (withAccess, PathId(..))
  47 import Gargantext.API.Admin.Types
  48 import Gargantext.API.Metrics
  49 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR)
  50 import Gargantext.API.Ngrams.NTree (MyTree)
  51 import Gargantext.API.Node.New
  52 import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
  53 import Gargantext.API.Table
  54 import Gargantext.Core.Types (NodeTableResult)
  55 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
  56 import Gargantext.Database.Action.Flow.Pairing (pairing)
  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.UpdateOpaleye (updateHyperdata)
  61 import Gargantext.Database.Query.Table.Node.User
  62 import Gargantext.Database.Query.Tree (treeDB)
  63 import Gargantext.Database.Admin.Config (nodeTypeId)
  64 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
  65 import Gargantext.Database.Admin.Types.Node
  66 import Gargantext.Database.Prelude -- (Cmd, CmdM)
  67 import Gargantext.Database.Schema.Node (_node_typename)
  68 import Gargantext.Database.Query.Table.NodeNode
  69 import Gargantext.Prelude
  70 import Gargantext.Viz.Chart
  71 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
  72 import Servant
  73 import Test.QuickCheck (elements)
  74 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  75 import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
  76
  77 {-
  78 import qualified Gargantext.Text.List.Learn as Learn
  79 import qualified Data.Vector as Vec
  80 --}
  81
  82 type NodesAPI  = Delete '[JSON] Int
  83
  84 -- | Delete Nodes
  85 -- Be careful: really delete nodes
  86 -- Access by admin only
  87 nodesAPI :: [NodeId] -> GargServer NodesAPI
  88 nodesAPI ids = deleteNodes ids
  89
  90 ------------------------------------------------------------------------
  91 -- | TODO-ACCESS: access by admin only.
  92 -- At first let's just have an isAdmin check.
  93 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
  94 -- To manage the Users roots
  95 -- TODO-EVENTS:
  96 --   PutNode ?
  97 -- TODO needs design discussion.
  98 type Roots =  Get    '[JSON] [Node HyperdataUser]
  99          :<|> Put    '[JSON] Int -- TODO
 100
 101 -- | TODO: access by admin only
 102 roots :: GargServer Roots
 103 roots = getNodesWithParentId Nothing
 104     :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 105
 106 -------------------------------------------------------------------
 107 -- | Node API Types management
 108 -- TODO-ACCESS : access by users
 109 -- No ownership check is needed if we strictly follow the capability model.
 110 --
 111 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
 112 --             SearchAPI)
 113 -- CanRenameNode (or part of CanEditNode?)
 114 -- CanCreateChildren (PostNodeApi)
 115 -- CanEditNode / CanPutNode TODO not implemented yet
 116 -- CanDeleteNode
 117 -- CanPatch (TableNgramsApi)
 118 -- CanFavorite
 119 -- CanMoveToTrash
 120
 121 type NodeAPI a = Get '[JSON] (Node a)
 122              :<|> "rename" :> RenameApi
 123              :<|> PostNodeApi -- TODO move to children POST
 124              :<|> ReqBody '[JSON] a :> Put    '[JSON] Int
 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"     :> SearchDocsAPI
 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
 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            :<|> putNode       id'
 197            :<|> deleteNodeApi id'
 198            :<|> getChildren   id' p
 199
 200            -- TODO gather it
 201            :<|> tableApi             id'
 202            :<|> apiNgramsTableCorpus id'
 203
 204            :<|> catApi      id'
 205
 206            :<|> searchDocs  id'
 207            -- Pairing Tools
 208            :<|> pairWith    id'
 209            :<|> pairs       id'
 210            :<|> getPair     id'
 211            :<|> searchPairs id'
 212
 213            :<|> getScatter id'
 214            :<|> getChart   id'
 215            :<|> getPie     id'
 216            :<|> getTree    id'
 217            :<|> phyloAPI   id' uId
 218            -- :<|> nodeAddAPI id'
 219            -- :<|> postUpload id'
 220
 221     deleteNodeApi id'' = do
 222       node' <- getNode id''
 223       if _node_typename node' == nodeTypeId NodeUser
 224          then panic "not allowed"  -- TODO add proper Right Management Type
 225          else deleteNode id''
 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 type ChartApi = Summary " Chart API"
 291               :> QueryParam "from" UTCTime
 292               :> QueryParam "to"   UTCTime
 293               :> Get '[JSON] (ChartMetrics Histo)
 294
 295 type PieApi = Summary " Chart API"
 296            :> QueryParam "from" UTCTime
 297            :> QueryParam "to"   UTCTime
 298            :> QueryParamR "ngramsType" TabType
 299            :> Get '[JSON] (ChartMetrics Histo)
 300
 301 type TreeApi = Summary " Tree API"
 302            :> QueryParam "from" UTCTime
 303            :> QueryParam "to"   UTCTime
 304            :> QueryParamR "ngramsType" TabType
 305            :> QueryParamR "listType"   ListType
 306            :> Get '[JSON] (ChartMetrics [MyTree])
 307
 308                 -- Depending on the Type of the Node, we could post
 309                 -- New documents for a corpus
 310                 -- New map list terms
 311              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 312
 313 ------------------------------------------------------------------------
 314
 315 type TreeAPI   = QueryParams "type" NodeType :> Get '[JSON] (Tree NodeTree)
 316
 317 treeAPI :: NodeId -> GargServer TreeAPI
 318 treeAPI = treeDB
 319
 320 ------------------------------------------------------------------------
 321 -- | Check if the name is less than 255 char
 322 rename :: NodeId -> RenameNode -> Cmd err [Int]
 323 rename nId (RenameNode name') = U.update (U.Rename nId name')
 324
 325 putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
 326         => NodeId
 327         -> a
 328         -> Cmd err Int
 329 putNode n h = fromIntegral <$> updateHyperdata n h
 330 -------------------------------------------------------------
 331