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              :<|> "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 (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            :<|> postUpload id
 203
 204     deleteNodeApi id' = do
 205       node <- getNode' id'
 206       if _node_typename node == nodeTypeId NodeUser
 207          then panic "not allowed"  -- TODO add proper Right Management Type
 208          else deleteNode id'
 209
 210            -- Annuaire
 211            -- :<|> query
 212
 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                 -- To launch a query and update the corpus
 292              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 293
 294 ------------------------------------------------------------------------
 295
 296 {-
 297 NOTE: These instances are not necessary. However, these messages could be part
 298       of a display function for NodeError/TreeError.
 299 instance HasNodeError ServantErr where
 300   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 301     where
 302       e = "Gargantext NodeError: "
 303       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 304       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 305       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 306       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 307
 308       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 309       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 310       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 311       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 312       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 313       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 314       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 315
 316 instance HasTreeError ServantErr where
 317   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 318     where
 319       e = "TreeError: "
 320       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 321       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 322       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 323 -}
 324
 325 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 326
 327 treeAPI :: NodeId -> GargServer TreeAPI
 328 treeAPI = treeDB
 329
 330 ------------------------------------------------------------------------
 331 -- | Check if the name is less than 255 char
 332 rename :: NodeId -> RenameNode -> Cmd err [Int]
 333 rename nId (RenameNode name') = U.update (U.Rename nId name')
 334
 335 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 336 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 337
 338 putNode :: NodeId -> Cmd err Int
 339 putNode = undefined -- TODO
 340
 341 query :: Monad m => Text -> m Text
 342 query s = pure s
 343
 344 -------------------------------------------------------------
 345 type Hash = Text
 346 data FileType = CSV | PresseRIS
 347   deriving (Eq, Show, Generic)
 348
 349 instance ToSchema FileType
 350 instance Arbitrary FileType
 351   where
 352     arbitrary = elements [CSV, PresseRIS]
 353 instance ToParamSchema FileType
 354
 355 instance ToParamSchema (MultipartData Mem) where
 356   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 357
 358 instance FromHttpApiData FileType
 359   where
 360     parseUrlPiece "CSV"       = pure CSV
 361     parseUrlPiece "PresseRis" = pure PresseRIS
 362     parseUrlPiece _           = pure CSV -- TODO error here
 363
 364
 365 instance (ToParamSchema a, HasSwagger sub) =>
 366          HasSwagger (MultipartForm tag a :> sub) where
 367   -- TODO
 368   toSwagger _ = toSwagger (Proxy :: Proxy sub)
 369     & addParam param
 370     where
 371       param = mempty
 372         & required ?~ True
 373         & schema   .~ ParamOther sch
 374       sch = mempty
 375         & in_         .~ ParamFormData
 376         & paramSchema .~ toParamSchema (Proxy :: Proxy a)
 377
 378 type UploadAPI = Summary "Upload file(s) to a corpus"
 379                 :> MultipartForm Mem (MultipartData Mem)
 380                 :> QueryParam "fileType"  FileType
 381                 :> Post '[JSON] [Hash]
 382
 383 --postUpload :: NodeId -> Maybe FileType ->  GargServer UploadAPI
 384 --postUpload :: NodeId -> GargServer UploadAPI
 385 postUpload :: NodeId -> MultipartData Mem -> Maybe FileType -> Cmd err [Hash]
 386 postUpload _ _ Nothing = panic "fileType is a required parameter"
 387 postUpload _ multipartData (Just fileType) = do
 388   putStrLn $ "File Type: " <> (show fileType)
 389   is <- liftIO $ do
 390     putStrLn ("Inputs:" :: Text)
 391     forM (inputs multipartData) $ \input -> do
 392       putStrLn $ ("iName  " :: Text) <> (iName input)
 393             <> ("iValue " :: Text) <> (iValue input)
 394       pure $ iName input
 395
 396   _ <- forM (files multipartData) $ \file -> do
 397     let content = fdPayload file
 398     putStrLn $ ("XXX " :: Text) <> (fdFileName file)
 399     putStrLn $ ("YYY " :: Text) <>  cs content
 400     --pure $ cs content
 401   -- is <- inputs multipartData
 402
 403   pure $ map (sha . cs) is