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)
  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.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
  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              :<|> Put    '[JSON] Int
 124              :<|> Delete '[JSON] Int
 125              :<|> "children"  :> ChildrenApi a
 126
 127              -- TODO gather it
 128              :<|> "table"     :> TableApi
 129              :<|> "ngrams"    :> TableNgramsApi
 130              -- :<|> "pairing"   :> PairingApi
 131
 132              :<|> "category"  :> CatApi
 133              :<|> "search"    :> SearchDocsAPI
 134
 135              -- VIZ
 136              :<|> "metrics" :> ScatterAPI
 137              :<|> "chart"     :> ChartApi
 138              :<|> "pie"       :> PieApi
 139              :<|> "tree"      :> TreeApi
 140              :<|> "phylo"     :> PhyloAPI
 141              -- :<|> "add"       :> NodeAddAPI
 142
 143 -- TODO-ACCESS: check userId CanRenameNode nodeId
 144 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 145 type RenameApi = Summary " Rename Node"
 146                :> ReqBody '[JSON] RenameNode
 147                :> Put     '[JSON] [Int]
 148
 149 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 150                  :> ReqBody '[JSON] PostNode
 151                  :> Post    '[JSON] [NodeId]
 152
 153 type ChildrenApi a = Summary " Summary children"
 154                  :> QueryParam "type"   NodeType
 155                  :> QueryParam "offset" Int
 156                  :> QueryParam "limit"  Int
 157                  -- :> Get '[JSON] [Node a]
 158                  :> Get '[JSON] (NodeTableResult a)
 159
 160 ------------------------------------------------------------------------
 161 type NodeNodeAPI a = Get '[JSON] (Node a)
 162
 163 nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> CorpusId -> NodeId -> GargServer (NodeNodeAPI a)
 164 nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
 165   where
 166     nodeNodeAPI' :: GargServer (NodeNodeAPI a)
 167     nodeNodeAPI' = getNodeWith nId p
 168
 169
 170
 171 ------------------------------------------------------------------------
 172 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 173 nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 174 nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
 175   where
 176     nodeAPI' :: GargServer (NodeAPI a)
 177     nodeAPI' =  getNodeWith       id p
 178            :<|> rename        id
 179            :<|> postNode  uId id
 180            :<|> putNode       id
 181            :<|> deleteNodeApi id
 182            :<|> getChildren   id p
 183
 184            -- TODO gather it
 185            :<|> tableApi             id
 186            :<|> apiNgramsTableCorpus id
 187            -- :<|> getPairing           id
 188            -- :<|> getTableNgramsDoc id
 189
 190            :<|> catApi     id
 191
 192            :<|> searchDocs id
 193
 194            :<|> getScatter id
 195            :<|> getChart   id
 196            :<|> getPie     id
 197            :<|> getTree    id
 198            :<|> phyloAPI   id uId
 199            -- :<|> nodeAddAPI id
 200            -- :<|> postUpload id
 201
 202     deleteNodeApi id' = do
 203       node <- getNode id'
 204       if _node_typename node == nodeTypeId NodeUser
 205          then panic "not allowed"  -- TODO add proper Right Management Type
 206          else deleteNode id'
 207
 208 ------------------------------------------------------------------------
 209 data RenameNode = RenameNode { r_name :: Text }
 210   deriving (Generic)
 211
 212 -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
 213 instance FromJSON  RenameNode
 214 instance ToJSON    RenameNode
 215 instance ToSchema  RenameNode
 216 instance Arbitrary RenameNode where
 217   arbitrary = elements [RenameNode "test"]
 218 ------------------------------------------------------------------------
 219 data PostNode = PostNode { pn_name :: Text
 220                          , pn_typename :: NodeType}
 221   deriving (Generic)
 222
 223 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 224 instance FromJSON  PostNode
 225 instance ToJSON    PostNode
 226 instance ToSchema  PostNode
 227 instance Arbitrary PostNode where
 228   arbitrary = elements [PostNode "Node test" NodeCorpus]
 229
 230 ------------------------------------------------------------------------
 231 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 232             :> ReqBody '[JSON] NodesToCategory
 233             :> Put     '[JSON] [Int]
 234
 235 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 236                                        , ntc_category :: Int
 237                                        }
 238   deriving (Generic)
 239
 240 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 241 instance FromJSON  NodesToCategory
 242 instance ToJSON    NodesToCategory
 243 instance ToSchema  NodesToCategory
 244
 245 catApi :: CorpusId -> GargServer CatApi
 246 catApi = putCat
 247   where
 248     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 249     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 250
 251 ------------------------------------------------------------------------
 252 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 253 type PairingApi = Summary " Pairing API"
 254               :> QueryParam "view"   TabType
 255               -- TODO change TabType -> DocType (CorpusId for pairing)
 256               :> QueryParam "offset" Int
 257               :> QueryParam "limit"  Int
 258               :> QueryParam "order"  OrderBy
 259               :> Get '[JSON] [FacetDoc]
 260
 261 ------------------------------------------------------------------------
 262 type ChartApi = Summary " Chart API"
 263               :> QueryParam "from" UTCTime
 264               :> QueryParam "to"   UTCTime
 265               :> Get '[JSON] (ChartMetrics Histo)
 266
 267 type PieApi = Summary " Chart API"
 268            :> QueryParam "from" UTCTime
 269            :> QueryParam "to"   UTCTime
 270            :> QueryParamR "ngramsType" TabType
 271            :> Get '[JSON] (ChartMetrics Histo)
 272
 273 type TreeApi = Summary " Tree API"
 274            :> QueryParam "from" UTCTime
 275            :> QueryParam "to"   UTCTime
 276            :> QueryParamR "ngramsType" TabType
 277            :> QueryParamR "listType"   ListType
 278            :> Get '[JSON] (ChartMetrics [MyTree])
 279
 280                 -- Depending on the Type of the Node, we could post
 281                 -- New documents for a corpus
 282                 -- New map list terms
 283              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 284
 285 ------------------------------------------------------------------------
 286
 287 {-
 288 NOTE: These instances are not necessary. However, these messages could be part
 289       of a display function for NodeError/TreeError.
 290 instance HasNodeError ServantErr where
 291   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 292     where
 293       e = "Gargantext NodeError: "
 294       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 295       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 296       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 297       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 298
 299       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 300       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 301       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 302       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 303       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 304       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 305       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 306
 307 instance HasTreeError ServantErr where
 308   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 309     where
 310       e = "TreeError: "
 311       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 312       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 313       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 314 -}
 315
 316 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 317
 318 treeAPI :: NodeId -> GargServer TreeAPI
 319 treeAPI = treeDB
 320
 321 ------------------------------------------------------------------------
 322 -- | Check if the name is less than 255 char
 323 rename :: NodeId -> RenameNode -> Cmd err [Int]
 324 rename nId (RenameNode name') = U.update (U.Rename nId name')
 325
 326 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 327 postNode uId pId (PostNode nodeName nt) = do
 328   nodeUser <- getNodeWith (NodeId uId) HyperdataUser
 329   let uId' = nodeUser ^. node_userId
 330   mkNodeWithParent nt (Just pId) uId' nodeName
 331
 332 putNode :: NodeId -> Cmd err Int
 333 putNode = undefined -- TODO
 334
 335 -------------------------------------------------------------