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