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