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