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 Control.Lens ((^.))
  41 import Data.Aeson (FromJSON, ToJSON)
  42 import Data.Maybe
  43 import Data.Swagger
  44 import Data.Text (Text())
  45 import Data.Time (UTCTime)
  46 import GHC.Generics (Generic)
  47 import Gargantext.API.Auth (withAccess, PathId(..))
  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.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
  52 import Gargantext.API.Table
  53 import Gargantext.API.Types
  54 import Gargantext.Core.Types (NodeTableResult)
  55 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
  56 import Gargantext.Database.Config (nodeTypeId)
  57 import Gargantext.Database.Flow.Pairing (pairing)
  58 import Gargantext.Database.Facet (FacetDoc, OrderBy(..))
  59 import Gargantext.Database.Node.Children (getChildren)
  60 import Gargantext.Database.Node.User (NodeUser)
  61 import Gargantext.Database.Schema.Node (getNodesWithParentId, getNodeWith, getNode, deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..), getNodeUser)
  62 import Gargantext.Database.Schema.NodeNode -- (nodeNodesCategory, insertNodeNode, NodeNode(..))
  63 import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
  64 import Gargantext.Database.Tree (treeDB)
  65 import Gargantext.Database.Types.Node
  66 import Gargantext.Database.Utils -- (Cmd, CmdM)
  67 import Gargantext.Prelude
  68 import Gargantext.Viz.Chart
  69 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
  70 import Servant
  71 import Test.QuickCheck (elements)
  72 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  73 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  74
  75 {-
  76 import qualified Gargantext.Text.List.Learn as Learn
  77 import qualified Data.Vector as Vec
  78 --}
  79
  80 type NodesAPI  = Delete '[JSON] Int
  81
  82 -- | Delete Nodes
  83 -- Be careful: really delete nodes
  84 -- Access by admin only
  85 nodesAPI :: [NodeId] -> GargServer NodesAPI
  86 nodesAPI ids = deleteNodes ids
  87
  88 ------------------------------------------------------------------------
  89 -- | TODO-ACCESS: access by admin only.
  90 -- At first let's just have an isAdmin check.
  91 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
  92 -- To manage the Users roots
  93 -- TODO-EVENTS:
  94 --   PutNode ?
  95 -- TODO needs design discussion.
  96 type Roots =  Get    '[JSON] [NodeUser]
  97          :<|> Put    '[JSON] Int -- TODO
  98
  99 -- | TODO: access by admin only
 100 roots :: GargServer Roots
 101 roots = getNodesWithParentId Nothing
 102     :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 103
 104 -------------------------------------------------------------------
 105 -- | Node API Types management
 106 -- TODO-ACCESS : access by users
 107 -- No ownership check is needed if we strictly follow the capability model.
 108 --
 109 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
 110 --             SearchAPI)
 111 -- CanRenameNode (or part of CanEditNode?)
 112 -- CanCreateChildren (PostNodeApi)
 113 -- CanEditNode / CanPutNode TODO not implemented yet
 114 -- CanDeleteNode
 115 -- CanPatch (TableNgramsApi)
 116 -- CanFavorite
 117 -- CanMoveToTrash
 118
 119 type NodeAPI a = Get '[JSON] (Node a)
 120              :<|> "rename" :> RenameApi
 121              :<|> PostNodeApi -- TODO move to children POST
 122              :<|> ReqBody '[JSON] a :> Put    '[JSON] Int
 123              :<|> Delete '[JSON] Int
 124              :<|> "children"  :> ChildrenApi a
 125
 126              -- TODO gather it
 127              :<|> "table"     :> TableApi
 128              :<|> "ngrams"    :> TableNgramsApi
 129
 130              :<|> "category"  :> CatApi
 131              :<|> "search"     :> SearchDocsAPI
 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
 147 -- TODO-ACCESS: check userId CanRenameNode nodeId
 148 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 149 type RenameApi = Summary " Rename Node"
 150                :> ReqBody '[JSON] RenameNode
 151                :> Put     '[JSON] [Int]
 152
 153 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 154                  :> ReqBody '[JSON] PostNode
 155                  :> Post    '[JSON] [NodeId]
 156
 157 type ChildrenApi a = Summary " Summary children"
 158                  :> QueryParam "type"   NodeType
 159                  :> QueryParam "offset" Int
 160                  :> QueryParam "limit"  Int
 161                  -- :> Get '[JSON] [Node a]
 162                  :> Get '[JSON] (NodeTableResult a)
 163
 164 ------------------------------------------------------------------------
 165 type NodeNodeAPI a = Get '[JSON] (Node a)
 166
 167 nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a)
 168             => proxy a
 169             -> UserId
 170             -> CorpusId
 171             -> NodeId
 172             -> GargServer (NodeNodeAPI a)
 173 nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
 174   where
 175     nodeNodeAPI' :: GargServer (NodeNodeAPI a)
 176     nodeNodeAPI' = getNodeWith nId p
 177
 178 ------------------------------------------------------------------------
 179 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 180 nodeAPI :: forall proxy a. (JSONB a, FromJSON a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 181 nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
 182   where
 183     nodeAPI' :: GargServer (NodeAPI a)
 184     nodeAPI' =  getNodeWith   id p
 185            :<|> rename        id
 186            :<|> postNode  uId id
 187            :<|> putNode       id
 188            :<|> deleteNodeApi id
 189            :<|> getChildren   id p
 190
 191            -- TODO gather it
 192            :<|> tableApi             id
 193            :<|> apiNgramsTableCorpus id
 194
 195            :<|> catApi      id
 196
 197            :<|> searchDocs  id
 198            -- Pairing Tools
 199            :<|> pairWith    id
 200            :<|> pairs       id
 201            :<|> getPair     id
 202            :<|> searchPairs id
 203
 204            :<|> getScatter id
 205            :<|> getChart   id
 206            :<|> getPie     id
 207            :<|> getTree    id
 208            :<|> phyloAPI   id uId
 209            -- :<|> nodeAddAPI id
 210            -- :<|> postUpload id
 211
 212     deleteNodeApi id' = do
 213       node <- getNode id'
 214       if _node_typename node == nodeTypeId NodeUser
 215          then panic "not allowed"  -- TODO add proper Right Management Type
 216          else deleteNode 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 data PostNode = PostNode { pn_name :: Text
 230                          , pn_typename :: NodeType}
 231   deriving (Generic)
 232
 233 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 234 instance FromJSON  PostNode
 235 instance ToJSON    PostNode
 236 instance ToSchema  PostNode
 237 instance Arbitrary PostNode where
 238   arbitrary = elements [PostNode "Node test" NodeCorpus]
 239
 240 ------------------------------------------------------------------------
 241 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 242             :> ReqBody '[JSON] NodesToCategory
 243             :> Put     '[JSON] [Int]
 244
 245 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 246                                        , ntc_category :: Int
 247                                        }
 248   deriving (Generic)
 249
 250 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 251 instance FromJSON  NodesToCategory
 252 instance ToJSON    NodesToCategory
 253 instance ToSchema  NodesToCategory
 254
 255 catApi :: CorpusId -> GargServer CatApi
 256 catApi = putCat
 257   where
 258     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 259     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 260
 261 ------------------------------------------------------------------------
 262 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 263 -- Pairing utilities to move elsewhere
 264 type PairingApi = Summary " Pairing API"
 265               :> QueryParam "view"   TabType
 266               -- TODO change TabType -> DocType (CorpusId for pairing)
 267               :> QueryParam "offset" Int
 268               :> QueryParam "limit"  Int
 269               :> QueryParam "order"  OrderBy
 270               :> Get '[JSON] [FacetDoc]
 271
 272 ----------
 273 type Pairs    = Summary "List of Pairs"
 274               :> Get '[JSON] [AnnuaireId]
 275 pairs :: CorpusId -> GargServer Pairs
 276 pairs cId = do
 277   ns <- getNodeNode cId
 278   pure $ map _nn_node2_id ns
 279
 280 type PairWith = Summary "Pair a Corpus with an Annuaire"
 281               :> "annuaire" :> Capture "annuaire_id" AnnuaireId
 282               :> "list"     :> Capture "list_id"     ListId
 283               :> Post '[JSON] Int
 284
 285 pairWith :: CorpusId -> GargServer PairWith
 286 pairWith cId aId lId = do
 287   r <- pairing cId aId lId
 288   _ <- insertNodeNode [ NodeNode cId aId Nothing Nothing]
 289   pure r
 290
 291 ------------------------------------------------------------------------
 292 type ChartApi = Summary " Chart API"
 293               :> QueryParam "from" UTCTime
 294               :> QueryParam "to"   UTCTime
 295               :> Get '[JSON] (ChartMetrics Histo)
 296
 297 type PieApi = Summary " Chart API"
 298            :> QueryParam "from" UTCTime
 299            :> QueryParam "to"   UTCTime
 300            :> QueryParamR "ngramsType" TabType
 301            :> Get '[JSON] (ChartMetrics Histo)
 302
 303 type TreeApi = Summary " Tree API"
 304            :> QueryParam "from" UTCTime
 305            :> QueryParam "to"   UTCTime
 306            :> QueryParamR "ngramsType" TabType
 307            :> QueryParamR "listType"   ListType
 308            :> Get '[JSON] (ChartMetrics [MyTree])
 309
 310                 -- Depending on the Type of the Node, we could post
 311                 -- New documents for a corpus
 312                 -- New map list terms
 313              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 314
 315 ------------------------------------------------------------------------
 316
 317 {-
 318 NOTE: These instances are not necessary. However, these messages could be part
 319       of a display function for NodeError/TreeError.
 320 instance HasNodeError ServantErr where
 321   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 322     where
 323       e = "Gargantext NodeError: "
 324       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 325       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 326       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 327       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 328
 329       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 330       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 331       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 332       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 333       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 334       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 335       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 336
 337 instance HasTreeError ServantErr where
 338   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 339     where
 340       e = "TreeError: "
 341       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 342       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 343       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 344 -}
 345
 346 type TreeAPI   = QueryParams "type" NodeType :> Get '[JSON] (Tree NodeTree)
 347
 348 treeAPI :: NodeId -> GargServer TreeAPI
 349 treeAPI = treeDB
 350
 351 ------------------------------------------------------------------------
 352 -- | Check if the name is less than 255 char
 353 rename :: NodeId -> RenameNode -> Cmd err [Int]
 354 rename nId (RenameNode name') = U.update (U.Rename nId name')
 355
 356 postNode :: HasNodeError err
 357          => UserId
 358          -> NodeId
 359          -> PostNode
 360          -> Cmd err [NodeId]
 361 postNode uId pId (PostNode nodeName nt) = do
 362   nodeUser <- getNodeUser (NodeId uId)
 363   let uId' = nodeUser ^. node_userId
 364   mkNodeWithParent nt (Just pId) uId' nodeName
 365
 366 putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
 367         => NodeId
 368         -> a
 369         -> Cmd err Int
 370 putNode n h = fromIntegral <$> updateHyperdata n h
 371 -------------------------------------------------------------
 372