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
  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.Aeson (FromJSON, ToJSON, Value())
  40 --import Data.Text (Text(), pack)
  41 import Data.Text (Text())
  42 import Data.Swagger
  43 import Data.Time (UTCTime)
  44
  45 import Database.PostgreSQL.Simple (Connection)
  46
  47 import GHC.Generics (Generic)
  48 import Servant
  49 -- import Servant.Multipart
  50
  51 import Gargantext.Prelude
  52 import Gargantext.Database.Types.Node
  53 import Gargantext.Database.Node ( runCmd
  54                                 , getNodesWithParentId
  55                                 , getNode, getNodesWith
  56                                 , deleteNode, deleteNodes, mk, JSONB)
  57 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  58 import Gargantext.Database.Facet (FacetDoc, getDocFacet
  59                                  ,FacetChart)
  60 import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
  61
  62 -- Graph
  63 import Gargantext.TextFlow
  64 import Gargantext.Viz.Graph (Graph)
  65 import Gargantext.Core (Lang(..))
  66 import Gargantext.Core.Types.Main (Tree, NodeTree)
  67 import Gargantext.Text.Terms (TermType(..))
  68
  69 import Test.QuickCheck (elements)
  70 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  71 -------------------------------------------------------------------
  72 -- | Node API Types management
  73 type Roots =  Get    '[JSON] [Node Value]
  74          :<|> Post   '[JSON] Int -- TODO
  75          :<|> Put    '[JSON] Int -- TODO
  76          :<|> Delete '[JSON] Int -- TODO
  77
  78 type NodesAPI  = Delete '[JSON] Int
  79
  80
  81 ------------------------------------------------------------------------
  82 ------------------------------------------------------------------------
  83 data RenameNode = RenameNode { r_name :: Text }
  84   deriving (Generic)
  85
  86 instance FromJSON  RenameNode
  87 instance ToJSON    RenameNode
  88 instance ToSchema  RenameNode
  89 instance Arbitrary RenameNode where
  90   arbitrary = elements [RenameNode "test"]
  91
  92 ------------------------------------------------------------------------
  93
  94 data PostNode = PostNode { pn_name :: Text
  95                          , pn_typename :: NodeType}
  96   deriving (Generic)
  97
  98 instance FromJSON  PostNode
  99 instance ToJSON    PostNode
 100 instance ToSchema  PostNode
 101 instance Arbitrary PostNode where
 102   arbitrary = elements [PostNode "Node test" NodeCorpus]
 103
 104 ------------------------------------------------------------------------
 105 ------------------------------------------------------------------------
 106 type NodeAPI a = Get '[JSON] (Node a)
 107              :<|> "rename" :> Summary " RenameNode Node"
 108                            :> ReqBody '[JSON] RenameNode
 109                            :> Put     '[JSON] [Int]
 110              :<|> Summary " PostNode Node with ParentId as {id}"
 111                            :> ReqBody '[JSON] PostNode
 112                            :> Post    '[JSON] [Int]
 113              :<|> Put    '[JSON] Int
 114              :<|> Delete '[JSON] Int
 115              :<|> "children" :> Summary " Summary children"
 116                              :> QueryParam "type"   NodeType
 117                              :> QueryParam "offset" Int
 118                              :> QueryParam "limit"  Int
 119                              :> Get '[JSON] [Node a]
 120              :<|> "facet" :> Summary " Facet documents"
 121                           :> "documents" :> FacetDocAPI
 122 --             :<|> "facet" :<|> "sources"   :<|> FacetSourcesAPI
 123 --             :<|> "facet" :<|> "authors"   :<|> FacetAuthorsAPI
 124 --             :<|> "facet" :<|> "terms"     :<|> FacetTermsAPI
 125
 126 --data FacetFormat = Table | Chart
 127 --data FacetType   = Doc   | Term  | Source | Author
 128 --data Facet       = Facet Doc Format
 129
 130
 131 type FacetDocAPI = "table"
 132                    :> Summary " Table data"
 133                    :> QueryParam "offset" Int
 134                    :> QueryParam "limit"  Int
 135                    :> Get '[JSON] [FacetDoc]
 136
 137                 :<|> "chart"
 138                    :> Summary " Chart data"
 139                    :> QueryParam "from" UTCTime
 140                    :> QueryParam "to"   UTCTime
 141                    :> Get '[JSON] [FacetChart]
 142
 143                 -- Depending on the Type of the Node, we could post
 144                 -- New documents for a corpus
 145                 -- New map list terms
 146              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 147
 148                 -- To launch a query and update the corpus
 149              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 150
 151
 152 -- | Node API functions
 153 roots :: Connection -> Server Roots
 154 roots conn = liftIO (putStrLn ( "/user" :: Text) >> getNodesWithParentId 0 Nothing conn)
 155           :<|> pure (panic "not implemented yet") -- TODO
 156           :<|> pure (panic "not implemented yet") -- TODO
 157           :<|> pure (panic "not implemented yet") -- TODO
 158
 159
 160 type GraphAPI   = Get '[JSON] Graph
 161 graphAPI :: Connection -> NodeId -> Server GraphAPI
 162 graphAPI _ _ = liftIO $ textFlow (Mono EN) (Contexts contextText)
 163   -- TODO what do we get about the node? to replace contextText
 164
 165 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 166 instance HasTreeError ServantErr where
 167   _TreeError = prism' mk (const Nothing) -- Note a prism
 168     where
 169       mk NoRoot       = err404 { errBody = "Root node not found"           }
 170       mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
 171       mk TooManyRoots = err500 { errBody = "Too many root nodes"           }
 172
 173 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 174 treeAPI :: Connection -> NodeId -> Server TreeAPI
 175 treeAPI = treeDB
 176
 177 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 178 nodeAPI :: JSONB a => Connection -> proxy a -> NodeId -> Server (NodeAPI a)
 179 nodeAPI conn p id
 180                 =  liftIO (getNode conn id p)
 181               :<|> rename        conn id
 182               :<|> postNode      conn id
 183               :<|> putNode       conn id
 184               :<|> deleteNode'   conn id
 185               :<|> getNodesWith' conn id p
 186               :<|> getFacet      conn id
 187               :<|> getChart      conn id
 188               -- :<|> upload
 189               -- :<|> query
 190 -- | Check if the name is less than 255 char
 191 --rename :: Connection -> NodeId -> Rename -> Server NodeAPI
 192 rename :: Connection -> NodeId -> RenameNode -> Handler [Int]
 193 rename c nId (RenameNode name) = liftIO $ U.update (U.Rename nId name) c
 194
 195 nodesAPI :: Connection -> [NodeId] -> Server NodesAPI
 196 nodesAPI conn ids = deleteNodes' conn ids
 197
 198 postNode :: Connection -> NodeId -> PostNode -> Handler [Int]
 199 postNode c pId (PostNode name nt) = liftIO $ mk c nt (Just pId) name
 200
 201 putNode :: Connection -> NodeId -> Handler Int
 202 putNode = undefined -- TODO
 203
 204 deleteNodes' :: Connection -> [NodeId] -> Handler Int
 205 deleteNodes' conn ids = liftIO (runCmd conn $ deleteNodes ids)
 206
 207 deleteNode' :: Connection -> NodeId -> Handler Int
 208 deleteNode' conn id = liftIO (runCmd conn $ deleteNode id)
 209
 210 getNodesWith' :: JSONB a => Connection -> NodeId -> proxy a -> Maybe NodeType
 211               -> Maybe Int -> Maybe Int -> Handler [Node a]
 212 getNodesWith' conn id p nodeType offset limit  = liftIO (getNodesWith conn id p nodeType offset limit)
 213
 214
 215 getFacet :: Connection -> NodeId -> Maybe Int -> Maybe Int
 216                         -> Handler [FacetDoc]
 217 getFacet conn id offset limit = liftIO (putStrLn ( "/facet" :: Text)) >> liftIO (getDocFacet conn NodeCorpus id (Just NodeDocument) offset limit)
 218
 219 getChart :: Connection -> NodeId -> Maybe UTCTime -> Maybe UTCTime
 220                         -> Handler [FacetChart]
 221 getChart _ _ _ _ = undefined -- TODO
 222
 223
 224 query :: Text -> Handler Text
 225 query s = pure s
 226
 227
 228 -- | Upload files
 229 -- TODO Is it possible to adapt the function according to iValue input ?
 230 --upload :: MultipartData -> Handler Text
 231 --upload multipartData = do
 232 --  liftIO $ do
 233 --    putStrLn "Inputs:"
 234 --    forM_ (inputs multipartData) $ \input ->
 235 --      putStrLn $ "  " <> show (iName input)
 236 --            <> " -> " <> show (iValue input)
 237 --
 238 --    forM_ (files multipartData) $ \file -> do
 239 --      content <- readFile (fdFilePath file)
 240 --      putStrLn $ "Content of " <> show (fdFileName file)
 241 --              <> " at " <> fdFilePath file
 242 --      putStrLn content
 243 --  pure (pack "Data loaded")
 244