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