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 -------------------------------------------------------------------
  17 -- TODO-ACCESS: access by admin only.
  18 --              At first let's just have an isAdmin check.
  19 --              Later: check userId CanDeleteNodes Nothing
  20 -- TODO-EVENTS: DeletedNodes [NodeId]
  21 --              {"tag": "DeletedNodes", "nodes": [Int*]}
  22
  23 -}
  24
  25 {-# OPTIONS_GHC -fno-warn-orphans #-}
  26
  27 {-# LANGUAGE DataKinds            #-}
  28 {-# LANGUAGE DeriveGeneric        #-}
  29 {-# LANGUAGE FlexibleContexts     #-}
  30 {-# LANGUAGE FlexibleInstances    #-}
  31 {-# LANGUAGE NoImplicitPrelude    #-}
  32 {-# LANGUAGE OverloadedStrings    #-}
  33 {-# LANGUAGE RankNTypes           #-}
  34 {-# LANGUAGE ScopedTypeVariables  #-}
  35 {-# LANGUAGE TemplateHaskell      #-}
  36 {-# LANGUAGE TypeOperators        #-}
  37
  38 module Gargantext.API.Node
  39   where
  40
  41 import Control.Lens ((^.))
  42 import Control.Monad ((>>))
  43 import Control.Monad.IO.Class (liftIO)
  44 import Data.Aeson (FromJSON, ToJSON)
  45 import Data.Maybe
  46 import Data.Swagger
  47 import Data.Text (Text())
  48 import Data.Time (UTCTime)
  49 import GHC.Generics (Generic)
  50 import Gargantext.API.Auth (withAccess, PathId(..))
  51 import Gargantext.API.Metrics
  52 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR)
  53 import Gargantext.API.Ngrams.NTree (MyTree)
  54 import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
  55 import Gargantext.API.Table
  56 import Gargantext.API.Types
  57 import Gargantext.Core.Types (NodeTableResult)
  58 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
  59 import Gargantext.Database.Config (nodeTypeId)
  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)
  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              :<|> "pairing"   :> PairingApi
 132
 133              :<|> "category"  :> CatApi
 134              :<|> "search"     :> SearchDocsAPI
 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. (JSONB a, FromJSON a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 179 nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
 180   where
 181     nodeAPI' :: GargServer (NodeAPI a)
 182     nodeAPI' =  getNodeWith   id p
 183            :<|> rename        id
 184            :<|> postNode  uId id
 185            :<|> putNode       id
 186            :<|> deleteNodeApi id
 187            :<|> getChildren   id p
 188
 189            -- TODO gather it
 190            :<|> tableApi             id
 191            :<|> apiNgramsTableCorpus id
 192            :<|> getPairing           id
 193            -- :<|> getTableNgramsDoc id
 194
 195            :<|> catApi     id
 196
 197            :<|> searchDocs  id
 198            :<|> searchPairs id
 199
 200            :<|> getScatter id
 201            :<|> getChart   id
 202            :<|> getPie     id
 203            :<|> getTree    id
 204            :<|> phyloAPI   id uId
 205            -- :<|> nodeAddAPI id
 206            -- :<|> postUpload id
 207
 208     deleteNodeApi id' = do
 209       node <- getNode id'
 210       if _node_typename node == nodeTypeId NodeUser
 211          then panic "not allowed"  -- TODO add proper Right Management Type
 212          else deleteNode id'
 213
 214 ------------------------------------------------------------------------
 215 data RenameNode = RenameNode { r_name :: Text }
 216   deriving (Generic)
 217
 218 -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
 219 instance FromJSON  RenameNode
 220 instance ToJSON    RenameNode
 221 instance ToSchema  RenameNode
 222 instance Arbitrary RenameNode where
 223   arbitrary = elements [RenameNode "test"]
 224 ------------------------------------------------------------------------
 225 data PostNode = PostNode { pn_name :: Text
 226                          , pn_typename :: NodeType}
 227   deriving (Generic)
 228
 229 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 230 instance FromJSON  PostNode
 231 instance ToJSON    PostNode
 232 instance ToSchema  PostNode
 233 instance Arbitrary PostNode where
 234   arbitrary = elements [PostNode "Node test" NodeCorpus]
 235
 236 ------------------------------------------------------------------------
 237 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 238             :> ReqBody '[JSON] NodesToCategory
 239             :> Put     '[JSON] [Int]
 240
 241 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 242                                        , ntc_category :: Int
 243                                        }
 244   deriving (Generic)
 245
 246 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 247 instance FromJSON  NodesToCategory
 248 instance ToJSON    NodesToCategory
 249 instance ToSchema  NodesToCategory
 250
 251 catApi :: CorpusId -> GargServer CatApi
 252 catApi = putCat
 253   where
 254     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 255     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 256
 257 ------------------------------------------------------------------------
 258 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 259 type PairingApi = Summary " Pairing API"
 260               :> QueryParam "view"   TabType
 261               -- TODO change TabType -> DocType (CorpusId for pairing)
 262               :> QueryParam "offset" Int
 263               :> QueryParam "limit"  Int
 264               :> QueryParam "order"  OrderBy
 265               :> Get '[JSON] [FacetDoc]
 266
 267 ------------------------------------------------------------------------
 268 type ChartApi = Summary " Chart API"
 269               :> QueryParam "from" UTCTime
 270               :> QueryParam "to"   UTCTime
 271               :> Get '[JSON] (ChartMetrics Histo)
 272
 273 type PieApi = Summary " Chart API"
 274            :> QueryParam "from" UTCTime
 275            :> QueryParam "to"   UTCTime
 276            :> QueryParamR "ngramsType" TabType
 277            :> Get '[JSON] (ChartMetrics Histo)
 278
 279 type TreeApi = Summary " Tree API"
 280            :> QueryParam "from" UTCTime
 281            :> QueryParam "to"   UTCTime
 282            :> QueryParamR "ngramsType" TabType
 283            :> QueryParamR "listType"   ListType
 284            :> Get '[JSON] (ChartMetrics [MyTree])
 285
 286                 -- Depending on the Type of the Node, we could post
 287                 -- New documents for a corpus
 288                 -- New map list terms
 289              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 290
 291 ------------------------------------------------------------------------
 292
 293 {-
 294 NOTE: These instances are not necessary. However, these messages could be part
 295       of a display function for NodeError/TreeError.
 296 instance HasNodeError ServantErr where
 297   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 298     where
 299       e = "Gargantext NodeError: "
 300       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 301       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 302       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 303       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 304
 305       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 306       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 307       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 308       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 309       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 310       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 311       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 312
 313 instance HasTreeError ServantErr where
 314   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 315     where
 316       e = "TreeError: "
 317       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 318       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 319       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 320 -}
 321
 322 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 323
 324 treeAPI :: NodeId -> GargServer TreeAPI
 325 treeAPI = treeDB
 326
 327 ------------------------------------------------------------------------
 328 -- | Check if the name is less than 255 char
 329 rename :: NodeId -> RenameNode -> Cmd err [Int]
 330 rename nId (RenameNode name') = U.update (U.Rename nId name')
 331
 332 postNode :: HasNodeError err
 333          => UserId
 334          -> NodeId
 335          -> PostNode
 336          -> Cmd err [NodeId]
 337 postNode uId pId (PostNode nodeName nt) = do
 338   nodeUser <- getNodeWith (NodeId uId) HyperdataUser
 339   let uId' = nodeUser ^. node_userId
 340   mkNodeWithParent nt (Just pId) uId' nodeName
 341
 342 putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
 343         => NodeId
 344         -> a
 345         -> Cmd err Int
 346 putNode n h = fromIntegral <$> updateHyperdata n h
 347 -------------------------------------------------------------