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