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
  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 HyperdataAny]
  99          :<|> Put    '[JSON] Int -- TODO
 100
 101 -- | TODO: access by admin only
 102 roots :: GargServer Roots
 103 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 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. (JSONB a, FromJSON a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 183 nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
 184   where
 185     nodeAPI' :: GargServer (NodeAPI a)
 186     nodeAPI' =  getNodeWith   id p
 187            :<|> rename        id
 188            :<|> postNode  uId id
 189            :<|> putNode       id
 190            :<|> deleteNodeApi id
 191            :<|> getChildren   id p
 192
 193            -- TODO gather it
 194            :<|> tableApi             id
 195            :<|> apiNgramsTableCorpus id
 196
 197            :<|> catApi      id
 198
 199            :<|> searchDocs  id
 200            -- Pairing Tools
 201            :<|> pairWith    id
 202            :<|> pairs       id
 203            :<|> getPair     id
 204            :<|> searchPairs id
 205
 206            :<|> getScatter id
 207            :<|> getChart   id
 208            :<|> getPie     id
 209            :<|> getTree    id
 210            :<|> phyloAPI   id uId
 211            -- :<|> nodeAddAPI id
 212            -- :<|> postUpload id
 213
 214     deleteNodeApi id' = do
 215       node <- getNode id'
 216       if _node_typename node == nodeTypeId NodeUser
 217          then panic "not allowed"  -- TODO add proper Right Management Type
 218          else deleteNode id'
 219
 220 ------------------------------------------------------------------------
 221 data RenameNode = RenameNode { r_name :: Text }
 222   deriving (Generic)
 223
 224 -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
 225 instance FromJSON  RenameNode
 226 instance ToJSON    RenameNode
 227 instance ToSchema  RenameNode
 228 instance Arbitrary RenameNode where
 229   arbitrary = elements [RenameNode "test"]
 230 ------------------------------------------------------------------------
 231 data PostNode = PostNode { pn_name :: Text
 232                          , pn_typename :: NodeType}
 233   deriving (Generic)
 234
 235 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 236 instance FromJSON  PostNode
 237 instance ToJSON    PostNode
 238 instance ToSchema  PostNode
 239 instance Arbitrary PostNode where
 240   arbitrary = elements [PostNode "Node test" NodeCorpus]
 241
 242 ------------------------------------------------------------------------
 243 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 244             :> ReqBody '[JSON] NodesToCategory
 245             :> Put     '[JSON] [Int]
 246
 247 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 248                                        , ntc_category :: Int
 249                                        }
 250   deriving (Generic)
 251
 252 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 253 instance FromJSON  NodesToCategory
 254 instance ToJSON    NodesToCategory
 255 instance ToSchema  NodesToCategory
 256
 257 catApi :: CorpusId -> GargServer CatApi
 258 catApi = putCat
 259   where
 260     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 261     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 262
 263 ------------------------------------------------------------------------
 264 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 265 -- Pairing utilities to move elsewhere
 266 type PairingApi = Summary " Pairing API"
 267               :> QueryParam "view"   TabType
 268               -- TODO change TabType -> DocType (CorpusId for pairing)
 269               :> QueryParam "offset" Int
 270               :> QueryParam "limit"  Int
 271               :> QueryParam "order"  OrderBy
 272               :> Get '[JSON] [FacetDoc]
 273
 274 ----------
 275 type Pairs    = Summary "List of Pairs"
 276               :> Get '[JSON] [AnnuaireId]
 277 pairs :: CorpusId -> GargServer Pairs
 278 pairs cId = do
 279   ns <- getNodeNode cId
 280   pure $ map _nn_node2_id ns
 281
 282 type PairWith = Summary "Pair a Corpus with an Annuaire"
 283               :> "annuaire" :> Capture "annuaire_id" AnnuaireId
 284               :> "list"     :> Capture "list_id"     ListId
 285               :> Post '[JSON] Int
 286
 287 pairWith :: CorpusId -> GargServer PairWith
 288 pairWith cId aId lId = do
 289   r <- pairing cId aId lId
 290   _ <- insertNodeNode [ NodeNode cId aId Nothing Nothing]
 291   pure r
 292
 293 ------------------------------------------------------------------------
 294 type ChartApi = Summary " Chart API"
 295               :> QueryParam "from" UTCTime
 296               :> QueryParam "to"   UTCTime
 297               :> Get '[JSON] (ChartMetrics Histo)
 298
 299 type PieApi = Summary " Chart API"
 300            :> QueryParam "from" UTCTime
 301            :> QueryParam "to"   UTCTime
 302            :> QueryParamR "ngramsType" TabType
 303            :> Get '[JSON] (ChartMetrics Histo)
 304
 305 type TreeApi = Summary " Tree API"
 306            :> QueryParam "from" UTCTime
 307            :> QueryParam "to"   UTCTime
 308            :> QueryParamR "ngramsType" TabType
 309            :> QueryParamR "listType"   ListType
 310            :> Get '[JSON] (ChartMetrics [MyTree])
 311
 312                 -- Depending on the Type of the Node, we could post
 313                 -- New documents for a corpus
 314                 -- New map list terms
 315              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 316
 317 ------------------------------------------------------------------------
 318
 319 {-
 320 NOTE: These instances are not necessary. However, these messages could be part
 321       of a display function for NodeError/TreeError.
 322 instance HasNodeError ServantErr where
 323   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 324     where
 325       e = "Gargantext NodeError: "
 326       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 327       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 328       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 329       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 330
 331       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 332       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 333       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 334       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 335       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 336       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 337       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 338
 339 instance HasTreeError ServantErr where
 340   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 341     where
 342       e = "TreeError: "
 343       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 344       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 345       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 346 -}
 347
 348 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 349
 350 treeAPI :: NodeId -> GargServer TreeAPI
 351 treeAPI = treeDB
 352
 353 ------------------------------------------------------------------------
 354 -- | Check if the name is less than 255 char
 355 rename :: NodeId -> RenameNode -> Cmd err [Int]
 356 rename nId (RenameNode name') = U.update (U.Rename nId name')
 357
 358 postNode :: HasNodeError err
 359          => UserId
 360          -> NodeId
 361          -> PostNode
 362          -> Cmd err [NodeId]
 363 postNode uId pId (PostNode nodeName nt) = do
 364   nodeUser <- getNodeWith (NodeId uId) HyperdataUser
 365   let uId' = nodeUser ^. node_userId
 366   mkNodeWithParent nt (Just pId) uId' nodeName
 367
 368 putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
 369         => NodeId
 370         -> a
 371         -> Cmd err Int
 372 putNode n h = fromIntegral <$> updateHyperdata n h
 373 -------------------------------------------------------------