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   , HyperdataCorpus(..)
  27   , HyperdataResource(..)
  28   , HyperdataUser(..)
  29   , HyperdataDocument(..)
  30   , HyperdataDocumentV3(..)
  31   ) where
  32 -------------------------------------------------------------------
  33 import Prelude (Enum, Bounded, minBound, maxBound)
  34 import Control.Lens (prism')
  35 import Control.Monad.IO.Class (liftIO)
  36 import Control.Monad ((>>))
  37 --import System.IO (putStrLn, readFile)
  38
  39 import Data.Either(Either(Left))
  40 import Data.Aeson (FromJSON, ToJSON, Value())
  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.Prelude
  52 import Gargantext.Database.Types.Node
  53 import Gargantext.Database.Node ( runCmd
  54                                 , getNodesWithParentId
  55                                 , getNode, getNodesWith, CorpusId
  56                                 , deleteNode, deleteNodes, mk, JSONB)
  57 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  58 import Gargantext.Database.Facet (FacetDoc , runViewDocuments', OrderBy(..)
  59                                  ,FacetChart)
  60 import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
  61 import Gargantext.Database.NodeNode (nodesToFavorite, nodesToTrash)
  62 -- Graph
  63 import Gargantext.TextFlow
  64 import Gargantext.Viz.Graph (Graph)
  65 import Gargantext.Core (Lang(..))
  66 import Gargantext.Core.Types (Offset, Limit)
  67 import Gargantext.Core.Types.Main (Tree, NodeTree)
  68 import Gargantext.Text.Terms (TermType(..))
  69
  70 import Test.QuickCheck (elements)
  71 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  72 -------------------------------------------------------------------
  73 -- | Node API Types management
  74 type Roots =  Get    '[JSON] [Node Value]
  75          :<|> Post   '[JSON] Int -- TODO
  76          :<|> Put    '[JSON] Int -- TODO
  77          :<|> Delete '[JSON] Int -- TODO
  78
  79 type NodesAPI  = Delete '[JSON] Int
  80
  81
  82 ------------------------------------------------------------------------
  83 ------------------------------------------------------------------------
  84 data RenameNode = RenameNode { r_name :: Text }
  85   deriving (Generic)
  86
  87 instance FromJSON  RenameNode
  88 instance ToJSON    RenameNode
  89 instance ToSchema  RenameNode
  90 instance Arbitrary RenameNode where
  91   arbitrary = elements [RenameNode "test"]
  92
  93 ------------------------------------------------------------------------
  94
  95 data PostNode = PostNode { pn_name :: Text
  96                          , pn_typename :: NodeType}
  97   deriving (Generic)
  98
  99 instance FromJSON  PostNode
 100 instance ToJSON    PostNode
 101 instance ToSchema  PostNode
 102 instance Arbitrary PostNode where
 103   arbitrary = elements [PostNode "Node test" NodeCorpus]
 104
 105 ------------------------------------------------------------------------
 106 type DocsApi = Summary "Move to trash"
 107              :> ReqBody '[JSON] Documents
 108              :> Delete  '[JSON] [Int]
 109
 110 data Documents = Documents { documents :: [NodeId]}
 111   deriving (Generic)
 112
 113 instance FromJSON  Documents
 114 instance ToJSON    Documents
 115 instance ToSchema  Documents
 116
 117 delDocs :: Connection -> CorpusId -> Documents -> Handler [Int]
 118 delDocs c cId ds = liftIO $ nodesToTrash c
 119                 $ map (\n -> (cId, n, True)) $ documents ds
 120
 121 ------------------------------------------------------------------------
 122 type FavApi =  Summary "Label as Favorites"
 123             :> ReqBody '[JSON] Favorites
 124             :> Put     '[JSON] [Int]
 125           :<|> Summary "Unlabel as Favorites"
 126             :> ReqBody '[JSON] Favorites
 127             :> Delete  '[JSON] [Int]
 128
 129 data Favorites = Favorites { favorites :: [NodeId]}
 130   deriving (Generic)
 131
 132 instance FromJSON  Favorites
 133 instance ToJSON    Favorites
 134 instance ToSchema  Favorites
 135
 136 putFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
 137 putFav c cId fs = liftIO $ nodesToFavorite c
 138                 $ map (\n -> (cId, n, True)) $ favorites fs
 139
 140 delFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
 141 delFav c cId fs = liftIO $ nodesToFavorite c
 142                 $ map (\n -> (cId, n, False)) $ favorites fs
 143
 144 favApi :: Connection -> CorpusId -> (Favorites -> Handler [Int])
 145                                :<|> (Favorites -> Handler [Int])
 146 favApi c cId = putFav c cId :<|> delFav c cId
 147
 148 ------------------------------------------------------------------------
 149 type NodeAPI a = Get '[JSON] (Node a)
 150              :<|> "rename" :> Summary " RenameNode Node"
 151                            :> ReqBody '[JSON] RenameNode
 152                            :> Put     '[JSON] [Int]
 153              :<|> Summary " PostNode Node with ParentId as {id}"
 154                            :> ReqBody '[JSON] PostNode
 155                            :> Post    '[JSON] [Int]
 156              :<|> Put    '[JSON] Int
 157              :<|> Delete '[JSON] Int
 158              :<|> "children" :> Summary " Summary children"
 159                              :> QueryParam "type"   NodeType
 160                              :> QueryParam "offset" Int
 161                              :> QueryParam "limit"  Int
 162                              :> Get '[JSON] [Node a]
 163              :<|> Summary " Tabs"      :> FacetDocAPI
 164 -- How TODO ?
 165 --                :<|> "favorites" :> Summary " Favorites" :> FavApi
 166 --                :<|> "documents" :> Summary " Documents" :> DocsApi
 167
 168
 169
 170 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 171 nodeAPI :: JSONB a => Connection -> proxy a -> NodeId -> Server (NodeAPI a)
 172 nodeAPI conn p id
 173                 =  liftIO (getNode conn id p)
 174               :<|> rename        conn id
 175               :<|> postNode      conn id
 176               :<|> putNode       conn id
 177               :<|> deleteNode'   conn id
 178               :<|> getNodesWith' conn id p
 179               :<|> getTable      conn id
 180               :<|> getChart      conn id
 181               :<|> favApi        conn id
 182               :<|> delDocs       conn id
 183               -- :<|> upload
 184               -- :<|> query
 185
 186
 187 --data FacetFormat = Table | Chart
 188 data FacetType   = Docs   | Terms  | Sources | Authors | Trash
 189   deriving (Generic, Enum, Bounded)
 190
 191 instance FromHttpApiData FacetType
 192   where
 193     parseUrlPiece "Docs"    = pure Docs
 194     parseUrlPiece "Terms"   = pure Terms
 195     parseUrlPiece "Sources" = pure Sources
 196     parseUrlPiece "Authors" = pure Authors
 197     parseUrlPiece "Trash"   = pure Trash
 198     parseUrlPiece _         = Left "Unexpected value of FacetType"
 199
 200 instance ToParamSchema   FacetType
 201 instance ToJSON    FacetType
 202 instance FromJSON  FacetType
 203 instance ToSchema  FacetType
 204 instance Arbitrary FacetType
 205   where
 206     arbitrary = elements [minBound .. maxBound]
 207
 208 ------------------------------------------------------------------------
 209 type FacetDocAPI = "table"
 210                    :> Summary " Table data"
 211                    :> QueryParam "view"   FacetType
 212                    :> QueryParam "offset" Int
 213                    :> QueryParam "limit"  Int
 214                    :> QueryParam "order"  OrderBy
 215                    :> Get '[JSON] [FacetDoc]
 216
 217                 :<|> "chart"
 218                    :> Summary " Chart data"
 219                    :> QueryParam "from" UTCTime
 220                    :> QueryParam "to"   UTCTime
 221                    :> Get '[JSON] [FacetChart]
 222                 :<|> "favorites" :> Summary " Favorites" :> FavApi
 223                 :<|> "documents" :> Summary " Documents" :> DocsApi
 224
 225                 -- Depending on the Type of the Node, we could post
 226                 -- New documents for a corpus
 227                 -- New map list terms
 228              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 229
 230                 -- To launch a query and update the corpus
 231              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 232
 233
 234 -- | Node API functions
 235 roots :: Connection -> Server Roots
 236 roots conn = liftIO (putStrLn ( "/user" :: Text) >> getNodesWithParentId 0 Nothing conn)
 237           :<|> pure (panic "not implemented yet") -- TODO
 238           :<|> pure (panic "not implemented yet") -- TODO
 239           :<|> pure (panic "not implemented yet") -- TODO
 240
 241 ------------------------------------------------------------------------
 242 type GraphAPI   = Get '[JSON] Graph
 243 graphAPI :: Connection -> NodeId -> Server GraphAPI
 244 graphAPI _ _ = liftIO $ textFlow (Mono EN) (Contexts contextText)
 245   -- TODO what do we get about the node? to replace contextText
 246
 247 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 248 instance HasTreeError ServantErr where
 249   _TreeError = prism' mk (const Nothing) -- Note a prism
 250     where
 251       mk NoRoot       = err404 { errBody = "Root node not found"           }
 252       mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
 253       mk TooManyRoots = err500 { errBody = "Too many root nodes"           }
 254
 255 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 256 treeAPI :: Connection -> NodeId -> Server TreeAPI
 257 treeAPI = treeDB
 258
 259 ------------------------------------------------------------------------
 260 -- | Check if the name is less than 255 char
 261 --rename :: Connection -> NodeId -> Rename -> Server NodeAPI
 262 rename :: Connection -> NodeId -> RenameNode -> Handler [Int]
 263 rename c nId (RenameNode name) = liftIO $ U.update (U.Rename nId name) c
 264
 265 nodesAPI :: Connection -> [NodeId] -> Server NodesAPI
 266 nodesAPI conn ids = deleteNodes' conn ids
 267
 268 getTable :: Connection -> NodeId -> Maybe FacetType
 269          -> Maybe Offset  -> Maybe Limit
 270          -> Maybe OrderBy -> Handler [FacetDoc]
 271 getTable c cId ft o l order = liftIO $ case ft of
 272                                 (Just Docs)  -> runViewDocuments' c cId False o l order
 273                                 (Just Trash) -> runViewDocuments' c cId True  o l order
 274                                 _     -> panic "not implemented"
 275
 276 getChart :: Connection -> NodeId -> Maybe UTCTime -> Maybe UTCTime
 277                         -> Handler [FacetChart]
 278 getChart _ _ _ _ = undefined -- TODO
 279
 280 postNode :: Connection -> NodeId -> PostNode -> Handler [Int]
 281 postNode c pId (PostNode name nt) = liftIO $ mk c nt (Just pId) name
 282
 283 putNode :: Connection -> NodeId -> Handler Int
 284 putNode = undefined -- TODO
 285
 286 deleteNodes' :: Connection -> [NodeId] -> Handler Int
 287 deleteNodes' conn ids = liftIO (runCmd conn $ deleteNodes ids)
 288
 289 deleteNode' :: Connection -> NodeId -> Handler Int
 290 deleteNode' conn id = liftIO (runCmd conn $ deleteNode id)
 291
 292 getNodesWith' :: JSONB a => Connection -> NodeId -> proxy a -> Maybe NodeType
 293               -> Maybe Int -> Maybe Int -> Handler [Node a]
 294 getNodesWith' conn id p nodeType offset limit  = liftIO (getNodesWith conn id p nodeType offset limit)
 295
 296
 297
 298 query :: Text -> Handler Text
 299 query s = pure s
 300
 301
 302 -- | Upload files
 303 -- TODO Is it possible to adapt the function according to iValue input ?
 304 --upload :: MultipartData -> Handler Text
 305 --upload multipartData = do
 306 --  liftIO $ do
 307 --    putStrLn "Inputs:"
 308 --    forM_ (inputs multipartData) $ \input ->
 309 --      putStrLn $ "  " <> show (iName input)
 310 --            <> " -> " <> show (iValue input)
 311 --
 312 --    forM_ (files multipartData) $ \file -> do
 313 --      content <- readFile (fdFilePath file)
 314 --      putStrLn $ "Content of " <> show (fdFileName file)
 315 --              <> " at " <> fdFilePath file
 316 --      putStrLn content
 317 --  pure (pack "Data loaded")
 318