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