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 Node API
  11 -}
  12
  13 {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
  14
  15 {-# LANGUAGE DataKinds          #-}
  16 {-# LANGUAGE DeriveGeneric      #-}
  17 {-# LANGUAGE FlexibleContexts   #-}
  18 {-# LANGUAGE NoImplicitPrelude  #-}
  19 {-# LANGUAGE OverloadedStrings  #-}
  20 {-# LANGUAGE TemplateHaskell    #-}
  21 {-# LANGUAGE TypeOperators      #-}
  22
  23 -------------------------------------------------------------------
  24 module Gargantext.API.Node
  25   ( module Gargantext.API.Node
  26   , HyperdataAny(..)
  27   , HyperdataAnnuaire(..)
  28   , HyperdataCorpus(..)
  29   , HyperdataResource(..)
  30   , HyperdataUser(..)
  31   , HyperdataDocument(..)
  32   , HyperdataDocumentV3(..)
  33   ) where
  34 -------------------------------------------------------------------
  35 import Control.Lens (prism', set)
  36 import Control.Monad.IO.Class (liftIO)
  37 import Control.Monad ((>>))
  38 --import System.IO (putStrLn, readFile)
  39
  40 import Data.Aeson (FromJSON, ToJSON)
  41 --import Data.Text (Text(), pack)
  42 import Data.Text (Text())
  43 import Data.Swagger
  44 import Data.Time (UTCTime)
  45
  46 import Database.PostgreSQL.Simple (Connection)
  47
  48 import GHC.Generics (Generic)
  49 import Servant
  50
  51 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, NgramsIdPatchsFeed, NgramsIdPatchsBack)
  52 import Gargantext.Prelude
  53 import Gargantext.Database.Types.Node
  54 import Gargantext.Database.Utils (runCmd)
  55 import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB)
  56 import Gargantext.Database.Node.Children (getChildren)
  57 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  58 import Gargantext.Database.Facet (FacetDoc , runViewDocuments', OrderBy(..),FacetChart,runViewAuthorsDoc)
  59 import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
  60 import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
  61 import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
  62 -- Graph
  63 --import Gargantext.Text.Flow
  64 import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
  65 -- import Gargantext.Core (Lang(..))
  66 import Gargantext.Core.Types (Offset, Limit)
  67 import Gargantext.Core.Types.Main (Tree, NodeTree, ListId, CorpusId, ContactId)
  68 -- import Gargantext.Text.Terms (TermType(..))
  69
  70 import Test.QuickCheck (elements)
  71 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  72
  73 -------------------------------------------------------------------
  74 -- | TODO : access by admin only
  75 type NodesAPI  = Delete '[JSON] Int
  76
  77 -- | Delete Nodes
  78 -- Be careful: really delete nodes
  79 -- Access by admin only
  80 nodesAPI :: Connection -> [NodeId] -> Server NodesAPI
  81 nodesAPI conn ids = deleteNodes' conn ids
  82
  83 ------------------------------------------------------------------------
  84 -- | TODO: access by admin only
  85 -- To manager the Users roots
  86 type Roots =  Get    '[JSON] [NodeAny]
  87          :<|> Post   '[JSON] Int -- TODO
  88          :<|> Put    '[JSON] Int -- TODO
  89          :<|> Delete '[JSON] Int -- TODO
  90
  91 -- | TODO: access by admin only
  92 roots :: Connection -> Server Roots
  93 roots conn = liftIO (putStrLn ( "/user" :: Text) >> getNodesWithParentId 0 Nothing conn)
  94           :<|> pure (panic "not implemented yet") -- TODO
  95           :<|> pure (panic "not implemented yet") -- TODO
  96           :<|> pure (panic "not implemented yet") -- TODO
  97
  98 -------------------------------------------------------------------
  99 -- | Node API Types management
 100 -- TODO : access by users
 101 type NodeAPI a = Get '[JSON] (Node a)
 102              :<|> "rename" :> RenameApi
 103              :<|> PostNodeApi
 104              :<|> Put    '[JSON] Int
 105              :<|> Delete '[JSON] Int
 106              :<|> "children"  :> ChildrenApi a
 107
 108              -- TODO gather it
 109              :<|> "table"     :> TableApi
 110              :<|> "list"      :> TableNgramsApi
 111              :<|> "listGet"   :> TableNgramsApiGet
 112              :<|> "pairing"   :> PairingApi
 113
 114              :<|> "chart"     :> ChartApi
 115              :<|> "favorites" :> FavApi
 116              :<|> "documents" :> DocsApi
 117              :<|> "search":> Summary "Node Search"
 118                         :> ReqBody '[JSON] SearchInQuery
 119                         :> QueryParam "offset" Int
 120                         :> QueryParam "limit"  Int
 121                         :> QueryParam "order"  OrderBy
 122                         :> SearchAPI
 123
 124 type RenameApi = Summary " RenameNode Node"
 125                :> ReqBody '[JSON] RenameNode
 126                :> Put     '[JSON] [Int]
 127
 128 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 129                  :> ReqBody '[JSON] PostNode
 130                  :> Post    '[JSON] [Int]
 131
 132 type ChildrenApi a = Summary " Summary children"
 133                  :> QueryParam "type"   NodeType
 134                  :> QueryParam "offset" Int
 135                  :> QueryParam "limit"  Int
 136                  :> Get '[JSON] [Node a]
 137 ------------------------------------------------------------------------
 138 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 139 nodeAPI :: JSONB a => Connection -> proxy a -> NodeId -> Server (NodeAPI a)
 140 nodeAPI conn p id
 141                 =  liftIO (getNode conn id p)
 142               :<|> rename        conn id
 143               :<|> postNode      conn id
 144               :<|> putNode       conn id
 145               :<|> deleteNode'   conn id
 146               :<|> getChildren'  conn id p
 147
 148               -- TODO gather it
 149               :<|> getTable      conn id
 150               :<|> tableNgramsPatch'  conn id
 151               :<|> getTableNgrams  conn id
 152               :<|> getPairing      conn id
 153
 154               :<|> getChart      conn id
 155               :<|> favApi        conn id
 156               :<|> delDocs       conn id
 157               :<|> searchIn      conn id
 158
 159               -- Annuaire
 160               -- :<|> upload
 161               -- :<|> query
 162 ------------------------------------------------------------------------
 163 data RenameNode = RenameNode { r_name :: Text }
 164   deriving (Generic)
 165
 166 instance FromJSON  RenameNode
 167 instance ToJSON    RenameNode
 168 instance ToSchema  RenameNode
 169 instance Arbitrary RenameNode where
 170   arbitrary = elements [RenameNode "test"]
 171 ------------------------------------------------------------------------
 172 data PostNode = PostNode { pn_name :: Text
 173                          , pn_typename :: NodeType}
 174   deriving (Generic)
 175
 176 instance FromJSON  PostNode
 177 instance ToJSON    PostNode
 178 instance ToSchema  PostNode
 179 instance Arbitrary PostNode where
 180   arbitrary = elements [PostNode "Node test" NodeCorpus]
 181
 182 ------------------------------------------------------------------------
 183 type DocsApi = Summary "Docs : Move to trash"
 184              :> ReqBody '[JSON] Documents
 185              :> Delete  '[JSON] [Int]
 186
 187 data Documents = Documents { documents :: [NodeId]}
 188   deriving (Generic)
 189
 190 instance FromJSON  Documents
 191 instance ToJSON    Documents
 192 instance ToSchema  Documents
 193
 194 delDocs :: Connection -> CorpusId -> Documents -> Handler [Int]
 195 delDocs c cId ds = liftIO $ nodesToTrash c
 196                 $ map (\n -> (cId, n, True)) $ documents ds
 197
 198 ------------------------------------------------------------------------
 199 type FavApi =  Summary " Favorites label"
 200             :> ReqBody '[JSON] Favorites
 201             :> Put     '[JSON] [Int]
 202           :<|> Summary " Favorites unlabel"
 203             :> ReqBody '[JSON] Favorites
 204             :> Delete  '[JSON] [Int]
 205
 206 data Favorites = Favorites { favorites :: [NodeId]}
 207   deriving (Generic)
 208
 209 instance FromJSON  Favorites
 210 instance ToJSON    Favorites
 211 instance ToSchema  Favorites
 212
 213 putFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
 214 putFav c cId fs = liftIO $ nodesToFavorite c
 215                 $ map (\n -> (cId, n, True)) $ favorites fs
 216
 217 delFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
 218 delFav c cId fs = liftIO $ nodesToFavorite c
 219                 $ map (\n -> (cId, n, False)) $ favorites fs
 220
 221 favApi :: Connection -> CorpusId -> (Favorites -> Handler [Int])
 222                                :<|> (Favorites -> Handler [Int])
 223 favApi c cId = putFav c cId :<|> delFav c cId
 224
 225 ------------------------------------------------------------------------
 226 type TableApi = Summary " Table API"
 227               :> QueryParam "view"   TabType
 228               :> QueryParam "offset" Int
 229               :> QueryParam "limit"  Int
 230               :> QueryParam "order"  OrderBy
 231               :> Get '[JSON] [FacetDoc]
 232
 233 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 234 type PairingApi = Summary " Pairing API"
 235               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 236               :> QueryParam "offset" Int
 237               :> QueryParam "limit"  Int
 238               :> QueryParam "order"  OrderBy
 239               :> Get '[JSON] [FacetDoc]
 240
 241 ------------------------------------------------------------------------
 242 type ChartApi = Summary " Chart API"
 243               :> QueryParam "from" UTCTime
 244               :> QueryParam "to"   UTCTime
 245               :> Get '[JSON] [FacetChart]
 246
 247                 -- Depending on the Type of the Node, we could post
 248                 -- New documents for a corpus
 249                 -- New map list terms
 250              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 251
 252                 -- To launch a query and update the corpus
 253              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 254
 255 ------------------------------------------------------------------------
 256 type GraphAPI   = Get '[JSON] Graph
 257 graphAPI :: Connection -> NodeId -> Server GraphAPI
 258 graphAPI c nId = liftIO $ graphAPI' c nId
 259
 260 graphAPI' :: Connection -> NodeId -> IO Graph
 261 graphAPI' c nId = do
 262
 263   nodeGraph <- getNode c nId HyperdataGraph
 264   let title = "IMT - Scientific publications - 1982-2017 - English"
 265   let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph] [ LegendField 6 "#FFF" "Data processing"
 266                                                                                    , LegendField 7 "#FFF" "Networks"
 267                                                                                    , LegendField 1 "#FFF" "Material science"
 268                                                                                    , LegendField 5 "#FFF" "Energy / Environment"
 269                                                                                    ]
 270                                        -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 271
 272   graph <- set graph_metadata (Just metadata) <$> maybe defaultGraph identity <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
 273
 274   pure graph
 275
 276
 277   -- t <- textFlow (Mono EN) (Contexts contextText)
 278   -- liftIO $ liftIO $ pure $  maybe t identity maybeGraph
 279   -- TODO what do we get about the node? to replace contextText
 280
 281 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 282 instance HasTreeError ServantErr where
 283   _TreeError = prism' mk (const Nothing) -- Note a prism
 284     where
 285       mk NoRoot       = err404 { errBody = "Root node not found"           }
 286       mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
 287       mk TooManyRoots = err500 { errBody = "Too many root nodes"           }
 288
 289 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 290 treeAPI :: Connection -> NodeId -> Server TreeAPI
 291 treeAPI = treeDB
 292
 293 ------------------------------------------------------------------------
 294 -- | Check if the name is less than 255 char
 295 rename :: Connection -> NodeId -> RenameNode -> Handler [Int]
 296 rename c nId (RenameNode name) = liftIO $ U.update (U.Rename nId name) c
 297
 298 getTable :: Connection -> NodeId -> Maybe TabType
 299          -> Maybe Offset  -> Maybe Limit
 300          -> Maybe OrderBy -> Handler [FacetDoc]
 301 getTable c cId ft o l order = liftIO $ case ft of
 302                                 (Just Docs)  -> runViewDocuments' c cId False o l order
 303                                 (Just Trash) -> runViewDocuments' c cId True  o l order
 304                                 _     -> panic "not implemented"
 305
 306 getPairing :: Connection -> ContactId -> Maybe TabType
 307          -> Maybe Offset  -> Maybe Limit
 308          -> Maybe OrderBy -> Handler [FacetDoc]
 309 getPairing c cId ft o l order = liftIO $ case ft of
 310                                 (Just Docs)  -> runViewAuthorsDoc c cId False o l order
 311                                 (Just Trash) -> runViewAuthorsDoc c cId True  o l order
 312                                 _     -> panic "not implemented"
 313
 314
 315 getChart :: Connection -> NodeId -> Maybe UTCTime -> Maybe UTCTime
 316                         -> Handler [FacetChart]
 317 getChart _ _ _ _ = undefined -- TODO
 318
 319 postNode :: Connection -> NodeId -> PostNode -> Handler [Int]
 320 postNode c pId (PostNode name nt) = liftIO $ mk c nt (Just pId) name
 321
 322 putNode :: Connection -> NodeId -> Handler Int
 323 putNode = undefined -- TODO
 324
 325 deleteNodes' :: Connection -> [NodeId] -> Handler Int
 326 deleteNodes' conn ids = liftIO (runCmd conn $ deleteNodes ids)
 327
 328 deleteNode' :: Connection -> NodeId -> Handler Int
 329 deleteNode' conn id = liftIO (runCmd conn $ deleteNode id)
 330
 331 getChildren' :: JSONB a => Connection -> NodeId -> proxy a -> Maybe NodeType
 332               -> Maybe Int -> Maybe Int -> Handler [Node a]
 333 getChildren' conn pId p nodeType offset limit  = liftIO (getChildren conn pId p nodeType offset limit)
 334
 335 tableNgramsPatch' :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> Handler NgramsIdPatchsBack
 336 tableNgramsPatch' c cId mL ns = liftIO $ tableNgramsPatch c cId mL ns
 337
 338 query :: Text -> Handler Text
 339 query s = pure s
 340
 341
 342 -- | Upload files
 343 -- TODO Is it possible to adapt the function according to iValue input ?
 344 --upload :: MultipartData -> Handler Text
 345 --upload multipartData = do
 346 --  liftIO $ do
 347 --    putStrLn "Inputs:"
 348 --    forM_ (inputs multipartData) $ \input ->
 349 --      putStrLn $ "  " <> show (iName input)
 350 --            <> " -> " <> show (iValue input)
 351 --
 352 --    forM_ (files multipartData) $ \file -> do
 353 --      content <- readFile (fdFilePath file)
 354 --      putStrLn $ "Content of " <> show (fdFileName file)
 355 --              <> " at " <> fdFilePath file
 356 --      putStrLn content
 357 --  pure (pack "Data loaded")
 358