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 ((>>), forM)
  43 import Control.Monad.IO.Class (liftIO)
  44 import Data.Aeson (FromJSON, ToJSON)
  45 import Data.Maybe
  46 import Data.Monoid (mempty)
  47 import Data.Swagger
  48 import Data.Text (Text())
  49 import Data.Time (UTCTime)
  50 import GHC.Generics (Generic)
  51 import Gargantext.API.Auth (withAccess, PathId(..))
  52 import Gargantext.API.Metrics
  53 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
  54 import Gargantext.API.Ngrams.NTree (MyTree)
  55 import Gargantext.API.Search (SearchDocsAPI, searchDocs)
  56 import Gargantext.API.Table
  57 import Gargantext.API.Types
  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, getNode, 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.Prelude.Utils (sha)
  69 import Gargantext.Viz.Chart
  70 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
  71 import Servant
  72 import Servant.Multipart
  73 import Servant.Swagger (HasSwagger(toSwagger))
  74 import Servant.Swagger.Internal
  75 import Test.QuickCheck (elements)
  76 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  77 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  78
  79 {-
  80 import qualified Gargantext.Text.List.Learn as Learn
  81 import qualified Data.Vector as Vec
  82 --}
  83
  84
  85 type NodesAPI  = Delete '[JSON] Int
  86
  87 -- | Delete Nodes
  88 -- Be careful: really delete nodes
  89 -- Access by admin only
  90 nodesAPI :: [NodeId] -> GargServer NodesAPI
  91 nodesAPI ids = deleteNodes ids
  92
  93 ------------------------------------------------------------------------
  94 -- | TODO-ACCESS: access by admin only.
  95 -- At first let's just have an isAdmin check.
  96 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
  97 -- To manage the Users roots
  98 -- TODO-EVENTS:
  99 --   PutNode ?
 100 -- TODO needs design discussion.
 101 type Roots =  Get    '[JSON] [Node HyperdataAny]
 102          :<|> Put    '[JSON] Int -- TODO
 103
 104 -- | TODO: access by admin only
 105 roots :: GargServer Roots
 106 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
 107    :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 108
 109 -------------------------------------------------------------------
 110 -- | Node API Types management
 111 -- TODO-ACCESS : access by users
 112 -- No ownership check is needed if we strictly follow the capability model.
 113 --
 114 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
 115 --             SearchAPI)
 116 -- CanRenameNode (or part of CanEditNode?)
 117 -- CanCreateChildren (PostNodeApi)
 118 -- CanEditNode / CanPutNode TODO not implemented yet
 119 -- CanDeleteNode
 120 -- CanPatch (TableNgramsApi)
 121 -- CanFavorite
 122 -- CanMoveToTrash
 123
 124 type NodeAPI a = Get '[JSON] (Node a)
 125              :<|> "rename" :> RenameApi
 126              :<|> PostNodeApi -- TODO move to children POST
 127              :<|> Put    '[JSON] Int
 128              :<|> Delete '[JSON] Int
 129              :<|> "children"  :> ChildrenApi a
 130
 131              -- TODO gather it
 132              :<|> "table"     :> TableApi
 133              :<|> "ngrams"    :> TableNgramsApi
 134              -- :<|> "pairing"   :> PairingApi
 135
 136              :<|> "category"  :> CatApi
 137              :<|> "search"    :> SearchDocsAPI
 138
 139              -- VIZ
 140              :<|> "metrics" :> ScatterAPI
 141              :<|> "chart"     :> ChartApi
 142              :<|> "pie"       :> PieApi
 143              :<|> "tree"      :> TreeApi
 144              :<|> "phylo"     :> PhyloAPI
 145              :<|> "add"       :> NodeAddAPI
 146
 147 -- TODO-ACCESS: check userId CanRenameNode nodeId
 148 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 149 type RenameApi = Summary " Rename Node"
 150                :> ReqBody '[JSON] RenameNode
 151                :> Put     '[JSON] [Int]
 152
 153 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 154                  :> ReqBody '[JSON] PostNode
 155                  :> Post    '[JSON] [NodeId]
 156
 157 type ChildrenApi a = Summary " Summary children"
 158                  :> QueryParam "type"   NodeType
 159                  :> QueryParam "offset" Int
 160                  :> QueryParam "limit"  Int
 161                  :> Get '[JSON] [Node a]
 162
 163 ------------------------------------------------------------------------
 164 type NodeNodeAPI a = Get '[JSON] (Node a)
 165
 166 nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> CorpusId -> NodeId -> GargServer (NodeNodeAPI a)
 167 nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
 168   where
 169     nodeNodeAPI' :: GargServer (NodeNodeAPI a)
 170     nodeNodeAPI' = getNode nId p
 171
 172
 173
 174 ------------------------------------------------------------------------
 175 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 176 nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 177 nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
 178   where
 179     nodeAPI' :: GargServer (NodeAPI a)
 180     nodeAPI' =  getNode       id p
 181            :<|> rename        id
 182            :<|> postNode  uId id
 183            :<|> putNode       id
 184            :<|> deleteNodeApi id
 185            :<|> getChildren   id p
 186
 187            -- TODO gather it
 188            :<|> tableApi             id
 189            :<|> apiNgramsTableCorpus id
 190            -- :<|> getPairing           id
 191            -- :<|> getTableNgramsDoc id
 192
 193            :<|> catApi     id
 194
 195            :<|> searchDocs id
 196
 197            :<|> getScatter id
 198            :<|> getChart   id
 199            :<|> getPie     id
 200            :<|> getTree    id
 201            :<|> phyloAPI   id uId
 202            :<|> nodeAddAPI id
 203            -- :<|> postUpload id
 204
 205     deleteNodeApi id' = do
 206       node <- getNode' id'
 207       if _node_typename node == nodeTypeId NodeUser
 208          then panic "not allowed"  -- TODO add proper Right Management Type
 209          else deleteNode id'
 210
 211            -- Annuaire
 212            -- :<|> query
 213
 214
 215 ------------------------------------------------------------------------
 216 data RenameNode = RenameNode { r_name :: Text }
 217   deriving (Generic)
 218
 219 -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
 220 instance FromJSON  RenameNode
 221 instance ToJSON    RenameNode
 222 instance ToSchema  RenameNode
 223 instance Arbitrary RenameNode where
 224   arbitrary = elements [RenameNode "test"]
 225 ------------------------------------------------------------------------
 226 data PostNode = PostNode { pn_name :: Text
 227                          , pn_typename :: NodeType}
 228   deriving (Generic)
 229
 230 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 231 instance FromJSON  PostNode
 232 instance ToJSON    PostNode
 233 instance ToSchema  PostNode
 234 instance Arbitrary PostNode where
 235   arbitrary = elements [PostNode "Node test" NodeCorpus]
 236
 237 ------------------------------------------------------------------------
 238 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 239             :> ReqBody '[JSON] NodesToCategory
 240             :> Put     '[JSON] [Int]
 241
 242 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 243                                        , ntc_category :: Int
 244                                        }
 245   deriving (Generic)
 246
 247 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 248 instance FromJSON  NodesToCategory
 249 instance ToJSON    NodesToCategory
 250 instance ToSchema  NodesToCategory
 251
 252 catApi :: CorpusId -> GargServer CatApi
 253 catApi = putCat
 254   where
 255     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 256     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 257
 258 ------------------------------------------------------------------------
 259 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 260 type PairingApi = Summary " Pairing API"
 261               :> QueryParam "view"   TabType
 262               -- TODO change TabType -> DocType (CorpusId for pairing)
 263               :> QueryParam "offset" Int
 264               :> QueryParam "limit"  Int
 265               :> QueryParam "order"  OrderBy
 266               :> Get '[JSON] [FacetDoc]
 267
 268 ------------------------------------------------------------------------
 269 type ChartApi = Summary " Chart API"
 270               :> QueryParam "from" UTCTime
 271               :> QueryParam "to"   UTCTime
 272               :> Get '[JSON] (ChartMetrics Histo)
 273
 274 type PieApi = Summary " Chart API"
 275            :> QueryParam "from" UTCTime
 276            :> QueryParam "to"   UTCTime
 277            :> QueryParamR "ngramsType" TabType
 278            :> Get '[JSON] (ChartMetrics Histo)
 279
 280 type TreeApi = Summary " Tree API"
 281            :> QueryParam "from" UTCTime
 282            :> QueryParam "to"   UTCTime
 283            :> QueryParamR "ngramsType" TabType
 284            :> QueryParamR "listType"   ListType
 285            :> Get '[JSON] (ChartMetrics [MyTree])
 286
 287                 -- Depending on the Type of the Node, we could post
 288                 -- New documents for a corpus
 289                 -- New map list terms
 290              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 291
 292                 -- To launch a query and update the corpus
 293              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 294
 295 ------------------------------------------------------------------------
 296
 297 {-
 298 NOTE: These instances are not necessary. However, these messages could be part
 299       of a display function for NodeError/TreeError.
 300 instance HasNodeError ServantErr where
 301   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 302     where
 303       e = "Gargantext NodeError: "
 304       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 305       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 306       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 307       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 308
 309       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 310       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 311       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 312       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 313       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 314       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 315       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 316
 317 instance HasTreeError ServantErr where
 318   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 319     where
 320       e = "TreeError: "
 321       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 322       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 323       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 324 -}
 325
 326 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 327
 328 treeAPI :: NodeId -> GargServer TreeAPI
 329 treeAPI = treeDB
 330
 331 ------------------------------------------------------------------------
 332 -- | Check if the name is less than 255 char
 333 rename :: NodeId -> RenameNode -> Cmd err [Int]
 334 rename nId (RenameNode name') = U.update (U.Rename nId name')
 335
 336 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 337 postNode uId pId (PostNode nodeName nt) = do
 338   nodeUser <- getNode (NodeId uId) HyperdataUser
 339   let uId' = nodeUser ^. node_userId
 340   mkNodeWithParent nt (Just pId) uId' nodeName
 341
 342 putNode :: NodeId -> Cmd err Int
 343 putNode = undefined -- TODO
 344
 345 query :: Monad m => Text -> m Text
 346 query s = pure s
 347
 348 -------------------------------------------------------------
 349 type Hash = Text
 350 data FileType = CSV | PresseRIS
 351   deriving (Eq, Show, Generic)
 352
 353 instance ToSchema FileType
 354 instance Arbitrary FileType
 355   where
 356     arbitrary = elements [CSV, PresseRIS]
 357 instance ToParamSchema FileType
 358
 359 instance ToParamSchema (MultipartData Mem) where
 360   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 361
 362 instance FromHttpApiData FileType
 363   where
 364     parseUrlPiece "CSV"       = pure CSV
 365     parseUrlPiece "PresseRis" = pure PresseRIS
 366     parseUrlPiece _           = pure CSV -- TODO error here
 367
 368
 369 instance (ToParamSchema a, HasSwagger sub) =>
 370          HasSwagger (MultipartForm tag a :> sub) where
 371   -- TODO
 372   toSwagger _ = toSwagger (Proxy :: Proxy sub)
 373     & addParam param
 374     where
 375       param = mempty
 376         & required ?~ True
 377         & schema   .~ ParamOther sch
 378       sch = mempty
 379         & in_         .~ ParamFormData
 380         & paramSchema .~ toParamSchema (Proxy :: Proxy a)
 381
 382 type NodeAddAPI = "file" :> Summary "Node add API"
 383                          :> UploadAPI
 384
 385 nodeAddAPI :: NodeId -> GargServer NodeAddAPI
 386 nodeAddAPI id =  postUpload       id
 387
 388 type UploadAPI = Summary "Upload file(s) to a corpus"
 389                 :> MultipartForm Mem (MultipartData Mem)
 390                 :> QueryParam "fileType"  FileType
 391                 :> Post '[JSON] [Hash]
 392
 393 --postUpload :: NodeId -> Maybe FileType ->  GargServer UploadAPI
 394 --postUpload :: NodeId -> GargServer UploadAPI
 395 postUpload :: NodeId -> MultipartData Mem -> Maybe FileType -> Cmd err [Hash]
 396 postUpload _ _ Nothing = panic "fileType is a required parameter"
 397 postUpload _ multipartData (Just fileType) = do
 398   putStrLn $ "File Type: " <> (show fileType)
 399   is <- liftIO $ do
 400     putStrLn ("Inputs:" :: Text)
 401     forM (inputs multipartData) $ \input -> do
 402       putStrLn $ ("iName  " :: Text) <> (iName input)
 403             <> ("iValue " :: Text) <> (iValue input)
 404       pure $ iName input
 405
 406   _ <- forM (files multipartData) $ \file -> do
 407     let content = fdPayload file
 408     putStrLn $ ("XXX " :: Text) <> (fdFileName file)
 409     putStrLn $ ("YYY " :: Text) <>  cs content
 410     --pure $ cs content
 411   -- is <- inputs multipartData
 412
 413   pure $ map (sha . cs) is