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