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 (hash)
  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              :<|> "upload"    :> UploadAPI
 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 (PathDoc cId nId) nodeNodeAPI'
 168   where
 169     nodeNodeAPI' :: GargServer (NodeNodeAPI a)
 170     nodeNodeAPI' = getNode nId p
 171
 172 ------------------------------------------------------------------------
 173 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 174 nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 175 nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
 176   where
 177     nodeAPI' :: GargServer (NodeAPI a)
 178     nodeAPI' =  getNode       id p
 179            :<|> rename        id
 180            :<|> postNode  uId id
 181            :<|> putNode       id
 182            :<|> deleteNodeApi id
 183            :<|> getChildren   id p
 184
 185            -- TODO gather it
 186            :<|> tableApi             id
 187            :<|> apiNgramsTableCorpus id
 188            :<|> getPairing           id
 189            -- :<|> getTableNgramsDoc id
 190
 191            :<|> catApi     id
 192
 193            :<|> searchDocs id
 194
 195            :<|> getScatter id
 196            :<|> getChart   id
 197            :<|> getPie     id
 198            :<|> getTree    id
 199            :<|> phyloAPI   id uId
 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            -- Annuaire
 209            -- :<|> query
 210 ------------------------------------------------------------------------
 211 data RenameNode = RenameNode { r_name :: Text }
 212   deriving (Generic)
 213
 214 -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
 215 instance FromJSON  RenameNode
 216 instance ToJSON    RenameNode
 217 instance ToSchema  RenameNode
 218 instance Arbitrary RenameNode where
 219   arbitrary = elements [RenameNode "test"]
 220 ------------------------------------------------------------------------
 221 data PostNode = PostNode { pn_name :: Text
 222                          , pn_typename :: NodeType}
 223   deriving (Generic)
 224
 225 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 226 instance FromJSON  PostNode
 227 instance ToJSON    PostNode
 228 instance ToSchema  PostNode
 229 instance Arbitrary PostNode where
 230   arbitrary = elements [PostNode "Node test" NodeCorpus]
 231
 232 ------------------------------------------------------------------------
 233 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 234             :> ReqBody '[JSON] NodesToCategory
 235             :> Put     '[JSON] [Int]
 236
 237 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 238                                        , ntc_category :: Int
 239                                        }
 240   deriving (Generic)
 241
 242 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 243 instance FromJSON  NodesToCategory
 244 instance ToJSON    NodesToCategory
 245 instance ToSchema  NodesToCategory
 246
 247 catApi :: CorpusId -> GargServer CatApi
 248 catApi = putCat
 249   where
 250     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 251     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 252
 253 ------------------------------------------------------------------------
 254 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 255 type PairingApi = Summary " Pairing API"
 256               :> QueryParam "view"   TabType
 257               -- TODO change TabType -> DocType (CorpusId for pairing)
 258               :> QueryParam "offset" Int
 259               :> QueryParam "limit"  Int
 260               :> QueryParam "order"  OrderBy
 261               :> Get '[JSON] [FacetDoc]
 262
 263 ------------------------------------------------------------------------
 264 type ChartApi = Summary " Chart API"
 265               :> QueryParam "from" UTCTime
 266               :> QueryParam "to"   UTCTime
 267               :> Get '[JSON] (ChartMetrics Histo)
 268
 269 type PieApi = Summary " Chart API"
 270            :> QueryParam "from" UTCTime
 271            :> QueryParam "to"   UTCTime
 272            :> QueryParamR "ngramsType" TabType
 273            :> Get '[JSON] (ChartMetrics Histo)
 274
 275 type TreeApi = Summary " Tree API"
 276            :> QueryParam "from" UTCTime
 277            :> QueryParam "to"   UTCTime
 278            :> QueryParamR "ngramsType" TabType
 279            :> QueryParamR "listType"   ListType
 280            :> Get '[JSON] (ChartMetrics [MyTree])
 281
 282                 -- Depending on the Type of the Node, we could post
 283                 -- New documents for a corpus
 284                 -- New map list terms
 285              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 286
 287                 -- To launch a query and update the corpus
 288              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 289
 290 ------------------------------------------------------------------------
 291
 292 {-
 293 NOTE: These instances are not necessary. However, these messages could be part
 294       of a display function for NodeError/TreeError.
 295 instance HasNodeError ServantErr where
 296   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 297     where
 298       e = "Gargantext NodeError: "
 299       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 300       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 301       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 302       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 303
 304       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 305       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 306       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 307       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 308       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 309       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 310       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 311
 312 instance HasTreeError ServantErr where
 313   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 314     where
 315       e = "TreeError: "
 316       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 317       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 318       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 319 -}
 320
 321 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 322
 323 treeAPI :: NodeId -> GargServer TreeAPI
 324 treeAPI = treeDB
 325
 326 ------------------------------------------------------------------------
 327 -- | Check if the name is less than 255 char
 328 rename :: NodeId -> RenameNode -> Cmd err [Int]
 329 rename nId (RenameNode name') = U.update (U.Rename nId name')
 330
 331 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 332 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 333
 334 putNode :: NodeId -> Cmd err Int
 335 putNode = undefined -- TODO
 336
 337 query :: Monad m => Text -> m Text
 338 query s = pure s
 339
 340 -------------------------------------------------------------
 341 type Hash = Text
 342 data FileType = CSV | PresseRIS
 343   deriving (Eq, Show, Generic)
 344
 345 instance ToSchema FileType
 346 instance Arbitrary FileType
 347   where
 348     arbitrary = elements [CSV, PresseRIS]
 349 instance ToParamSchema FileType
 350
 351 instance ToParamSchema (MultipartData Mem) where
 352   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 353
 354 instance FromHttpApiData FileType
 355   where
 356     parseUrlPiece "CSV"       = pure CSV
 357     parseUrlPiece "PresseRis" = pure PresseRIS
 358     parseUrlPiece _           = pure CSV -- TODO error here
 359
 360
 361 instance (ToParamSchema a, HasSwagger sub) =>
 362          HasSwagger (MultipartForm tag a :> sub) where
 363   -- TODO
 364   toSwagger _ = toSwagger (Proxy :: Proxy sub)
 365     & addParam param
 366     where
 367       param = mempty
 368         & required ?~ True
 369         & schema   .~ ParamOther sch
 370       sch = mempty
 371         & in_         .~ ParamFormData
 372         & paramSchema .~ toParamSchema (Proxy :: Proxy a)
 373
 374 type UploadAPI = Summary "Upload file(s) to a corpus"
 375                 :> MultipartForm Mem (MultipartData Mem)
 376                 :> QueryParam "fileType"  FileType
 377                 :> Post '[JSON] [Hash]
 378
 379 --postUpload :: NodeId -> Maybe FileType ->  GargServer UploadAPI
 380 --postUpload :: NodeId -> GargServer UploadAPI
 381 postUpload :: NodeId -> MultipartData Mem -> Maybe FileType -> Cmd err [Hash]
 382 postUpload _ _ Nothing = panic "fileType is a required parameter"
 383 postUpload _ multipartData (Just fileType) = do
 384   putStrLn $ "File Type: " <> (show fileType)
 385   is <- liftIO $ do
 386     putStrLn ("Inputs:" :: Text)
 387     forM (inputs multipartData) $ \input -> do
 388       putStrLn $ ("iName  " :: Text) <> (iName input)
 389             <> ("iValue " :: Text) <> (iValue input)
 390       pure $ iName input
 391
 392   _ <- forM (files multipartData) $ \file -> do
 393     let content = fdPayload file
 394     putStrLn $ ("XXX " :: Text) <> (fdFileName file)
 395     putStrLn $ ("YYY " :: Text) <>  cs content
 396     --pure $ cs content
 397   -- is <- inputs multipartData
 398
 399   pure $ map (hash . cs) is