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