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 Data.Time (UTCTime)
  38 import GHC.Generics (Generic)
  39 import Gargantext.API.Admin.Auth (withAccess, PathId(..))
  40 import Gargantext.API.Prelude
  41 import Gargantext.API.Metrics
  42 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR)
  43 import Gargantext.API.Ngrams.NTree (MyTree)
  44 import Gargantext.API.Node.New
  45 import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
  46 import Gargantext.API.Table
  47 import Gargantext.Core.Types (NodeTableResult)
  48 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
  49 import Gargantext.Database.Action.Flow.Pairing (pairing)
  50 import Gargantext.Database.Query.Facet (FacetDoc, OrderBy(..))
  51 import Gargantext.Core.Types.Individu (User(..))
  52 import Gargantext.Database.Query.Table.Node
  53 import Gargantext.Database.Query.Table.Node.Children (getChildren)
  54 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  55 import Gargantext.Database.Query.Table.Node.User
  56 import Gargantext.Database.Query.Tree (tree, TreeMode(..))
  57 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
  58 import Gargantext.Database.Admin.Types.Node
  59 import Gargantext.Database.Prelude -- (Cmd, CmdM)
  60 import Gargantext.Database.Query.Table.NodeNode
  61 import Gargantext.Prelude
  62 import Gargantext.Viz.Chart
  63 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
  64 import Servant
  65 import Test.QuickCheck (elements)
  66 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  67 import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
  68 import qualified Gargantext.Database.Action.Delete as Action (deleteNode)
  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 ids = deleteNodes ids
  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              :<|> Delete '[JSON] Int
 122              :<|> "children"  :> ChildrenApi a
 123
 124              -- TODO gather it
 125              :<|> "table"      :> TableApi
 126              :<|> "ngrams"     :> TableNgramsApi
 127
 128              :<|> "category"   :> CatApi
 129              :<|> "search"     :> SearchDocsAPI
 130
 131              -- Pairing utilities
 132              :<|> "pairwith"   :> PairWith
 133              :<|> "pairs"      :> Pairs
 134              :<|> "pairing"    :> PairingApi
 135              :<|> "searchPair" :> SearchPairsAPI
 136
 137              -- VIZ
 138              :<|> "metrics"    :> ScatterAPI
 139              :<|> "chart"      :> ChartApi
 140              :<|> "pie"        :> PieApi
 141              :<|> "tree"       :> TreeApi
 142              :<|> "phylo"      :> PhyloAPI
 143              -- :<|> "add"       :> NodeAddAPI
 144
 145 -- TODO-ACCESS: check userId CanRenameNode nodeId
 146 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 147 type RenameApi = Summary " Rename Node"
 148                :> ReqBody '[JSON] RenameNode
 149                :> Put     '[JSON] [Int]
 150
 151 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 152                  :> ReqBody '[JSON] PostNode
 153                  :> Post    '[JSON] [NodeId]
 154
 155 type ChildrenApi a = Summary " Summary children"
 156                  :> QueryParam "type"   NodeType
 157                  :> QueryParam "offset" Int
 158                  :> QueryParam "limit"  Int
 159                  -- :> Get '[JSON] [Node a]
 160                  :> Get '[JSON] (NodeTableResult a)
 161
 162 ------------------------------------------------------------------------
 163 type NodeNodeAPI a = Get '[JSON] (Node a)
 164
 165 nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a)
 166             => proxy a
 167             -> UserId
 168             -> CorpusId
 169             -> NodeId
 170             -> GargServer (NodeNodeAPI a)
 171 nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
 172   where
 173     nodeNodeAPI' :: GargServer (NodeNodeAPI a)
 174     nodeNodeAPI' = getNodeWith nId p
 175
 176 ------------------------------------------------------------------------
 177 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 178 nodeAPI :: forall proxy a.
 179        ( JSONB a
 180        , FromJSON a
 181        , ToJSON a
 182        ) => proxy a
 183          -> UserId
 184          -> NodeId
 185          -> GargServer (NodeAPI a)
 186 nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id') nodeAPI'
 187   where
 188     nodeAPI' :: GargServer (NodeAPI a)
 189     nodeAPI' =  getNodeWith   id' p
 190            :<|> rename        id'
 191            :<|> postNode  uId id'
 192            :<|> postNodeAsyncAPI  uId id'
 193            :<|> putNode       id'
 194            :<|> Action.deleteNode (RootId $ NodeId uId) id'
 195            :<|> getChildren   id' p
 196
 197            -- TODO gather it
 198            :<|> tableApi             id'
 199            :<|> apiNgramsTableCorpus id'
 200
 201            :<|> catApi      id'
 202
 203            :<|> searchDocs  id'
 204            -- Pairing Tools
 205            :<|> pairWith    id'
 206            :<|> pairs       id'
 207            :<|> getPair     id'
 208            :<|> searchPairs id'
 209
 210            :<|> getScatter id'
 211            :<|> getChart   id'
 212            :<|> getPie     id'
 213            :<|> getTree    id'
 214            :<|> phyloAPI   id' uId
 215            -- :<|> nodeAddAPI id'
 216            -- :<|> postUpload id'
 217
 218 ------------------------------------------------------------------------
 219 data RenameNode = RenameNode { r_name :: Text }
 220   deriving (Generic)
 221
 222 -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
 223 instance FromJSON  RenameNode
 224 instance ToJSON    RenameNode
 225 instance ToSchema  RenameNode
 226 instance Arbitrary RenameNode where
 227   arbitrary = elements [RenameNode "test"]
 228 ------------------------------------------------------------------------
 229 ------------------------------------------------------------------------
 230 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 231             :> ReqBody '[JSON] NodesToCategory
 232             :> Put     '[JSON] [Int]
 233
 234 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 235                                        , ntc_category :: Int
 236                                        }
 237   deriving (Generic)
 238
 239 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 240 instance FromJSON  NodesToCategory
 241 instance ToJSON    NodesToCategory
 242 instance ToSchema  NodesToCategory
 243
 244 catApi :: CorpusId -> GargServer CatApi
 245 catApi = putCat
 246   where
 247     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 248     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 249
 250 ------------------------------------------------------------------------
 251 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 252 -- Pairing utilities to move elsewhere
 253 type PairingApi = Summary " Pairing API"
 254               :> QueryParam "view"   TabType
 255               -- TODO change TabType -> DocType (CorpusId for pairing)
 256               :> QueryParam "offset" Int
 257               :> QueryParam "limit"  Int
 258               :> QueryParam "order"  OrderBy
 259               :> Get '[JSON] [FacetDoc]
 260
 261 ----------
 262 type Pairs    = Summary "List of Pairs"
 263               :> Get '[JSON] [AnnuaireId]
 264 pairs :: CorpusId -> GargServer Pairs
 265 pairs cId = do
 266   ns <- getNodeNode cId
 267   pure $ map _nn_node2_id ns
 268
 269 type PairWith = Summary "Pair a Corpus with an Annuaire"
 270               :> "annuaire" :> Capture "annuaire_id" AnnuaireId
 271               :> "list"     :> Capture "list_id"     ListId
 272               :> Post '[JSON] Int
 273
 274 pairWith :: CorpusId -> GargServer PairWith
 275 pairWith cId aId lId = do
 276   r <- pairing cId aId lId
 277   _ <- insertNodeNode [ NodeNode cId aId Nothing Nothing]
 278   pure r
 279
 280 ------------------------------------------------------------------------
 281 type ChartApi = Summary " Chart API"
 282               :> QueryParam "from" UTCTime
 283               :> QueryParam "to"   UTCTime
 284               :> Get '[JSON] (ChartMetrics Histo)
 285
 286 type PieApi = Summary " Chart API"
 287            :> QueryParam "from" UTCTime
 288            :> QueryParam "to"   UTCTime
 289            :> QueryParamR "ngramsType" TabType
 290            :> Get '[JSON] (ChartMetrics Histo)
 291
 292 type TreeApi = Summary " Tree API"
 293            :> QueryParam "from" UTCTime
 294            :> QueryParam "to"   UTCTime
 295            :> QueryParamR "ngramsType" TabType
 296            :> QueryParamR "listType"   ListType
 297            :> Get '[JSON] (ChartMetrics [MyTree])
 298
 299                 -- Depending on the Type of the Node, we could post
 300                 -- New documents for a corpus
 301                 -- New map list terms
 302              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 303
 304 ------------------------------------------------------------------------
 305 type TreeAPI   = QueryParams "type" NodeType :> Get '[JSON] (Tree NodeTree)
 306
 307 treeAPI :: NodeId -> GargServer TreeAPI
 308 treeAPI = tree Advanced
 309
 310 ------------------------------------------------------------------------
 311 -- | Check if the name is less than 255 char
 312 rename :: NodeId -> RenameNode -> Cmd err [Int]
 313 rename nId (RenameNode name') = U.update (U.Rename nId name')
 314
 315 putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
 316         => NodeId
 317         -> a
 318         -> Cmd err Int
 319 putNode n h = fromIntegral <$> updateHyperdata n h
 320 -------------------------------------------------------------
 321
 322