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