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, getTableNgrams, NgramsIdPatchsFeed, NgramsIdPatchsBack, NgramsTable)
  52 import Gargantext.Prelude
  53 import Gargantext.Database.Types.Node
  54 import Gargantext.Database.Node ( runCmd
  55                                 , getNodesWithParentId
  56                                 , getNode
  57                                 , deleteNode, deleteNodes, mk, JSONB)
  58 import Gargantext.Database.Node.Children (getChildren)
  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.Text.Flow
  66 import Gargantext.Viz.Graph (Graph,readGraphFromJson,defaultGraph)
  67 -- import Gargantext.Core (Lang(..))
  68 import Gargantext.Core.Types (Offset, Limit)
  69 import Gargantext.Core.Types.Main (Tree, NodeTree, ListId, CorpusId)
  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               :<|> getChildren'  conn id p
 142
 143               -- TODO gather it
 144               :<|> getTable      conn id
 145               :<|> tableNgramsPatch'  conn id
 146               :<|> getTableNgrams' conn id
 147
 148               :<|> getChart      conn id
 149               :<|> favApi        conn id
 150               :<|> delDocs       conn id
 151               -- Annuaire
 152               -- :<|> upload
 153               -- :<|> query
 154 ------------------------------------------------------------------------
 155 data RenameNode = RenameNode { r_name :: Text }
 156   deriving (Generic)
 157
 158 instance FromJSON  RenameNode
 159 instance ToJSON    RenameNode
 160 instance ToSchema  RenameNode
 161 instance Arbitrary RenameNode where
 162   arbitrary = elements [RenameNode "test"]
 163 ------------------------------------------------------------------------
 164 data PostNode = PostNode { pn_name :: Text
 165                          , pn_typename :: NodeType}
 166   deriving (Generic)
 167
 168 instance FromJSON  PostNode
 169 instance ToJSON    PostNode
 170 instance ToSchema  PostNode
 171 instance Arbitrary PostNode where
 172   arbitrary = elements [PostNode "Node test" NodeCorpus]
 173
 174 ------------------------------------------------------------------------
 175 type DocsApi = Summary "Docs : Move to trash"
 176              :> ReqBody '[JSON] Documents
 177              :> Delete  '[JSON] [Int]
 178
 179 data Documents = Documents { documents :: [NodeId]}
 180   deriving (Generic)
 181
 182 instance FromJSON  Documents
 183 instance ToJSON    Documents
 184 instance ToSchema  Documents
 185
 186 delDocs :: Connection -> CorpusId -> Documents -> Handler [Int]
 187 delDocs c cId ds = liftIO $ nodesToTrash c
 188                 $ map (\n -> (cId, n, True)) $ documents ds
 189
 190 ------------------------------------------------------------------------
 191 type FavApi =  Summary " Favorites label"
 192             :> ReqBody '[JSON] Favorites
 193             :> Put     '[JSON] [Int]
 194           :<|> Summary " Favorites unlabel"
 195             :> ReqBody '[JSON] Favorites
 196             :> Delete  '[JSON] [Int]
 197
 198 data Favorites = Favorites { favorites :: [NodeId]}
 199   deriving (Generic)
 200
 201 instance FromJSON  Favorites
 202 instance ToJSON    Favorites
 203 instance ToSchema  Favorites
 204
 205 putFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
 206 putFav c cId fs = liftIO $ nodesToFavorite c
 207                 $ map (\n -> (cId, n, True)) $ favorites fs
 208
 209 delFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
 210 delFav c cId fs = liftIO $ nodesToFavorite c
 211                 $ map (\n -> (cId, n, False)) $ favorites fs
 212
 213 favApi :: Connection -> CorpusId -> (Favorites -> Handler [Int])
 214                                :<|> (Favorites -> Handler [Int])
 215 favApi c cId = putFav c cId :<|> delFav c cId
 216
 217 ------------------------------------------------------------------------
 218 type TableApi = Summary " Table API"
 219               :> QueryParam "view"   TabType
 220               :> QueryParam "offset" Int
 221               :> QueryParam "limit"  Int
 222               :> QueryParam "order"  OrderBy
 223               :> Get '[JSON] [FacetDoc]
 224
 225 ------------------------------------------------------------------------
 226 type ChartApi = Summary " Chart API"
 227               :> QueryParam "from" UTCTime
 228               :> QueryParam "to"   UTCTime
 229               :> Get '[JSON] [FacetChart]
 230
 231                 -- Depending on the Type of the Node, we could post
 232                 -- New documents for a corpus
 233                 -- New map list terms
 234              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 235
 236                 -- To launch a query and update the corpus
 237              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 238
 239 ------------------------------------------------------------------------
 240 type GraphAPI   = Get '[JSON] Graph
 241 graphAPI :: Connection -> NodeId -> Server GraphAPI
 242 graphAPI _ _ = do
 243   liftIO $ maybe defaultGraph identity <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
 244   -- t <- textFlow (Mono EN) (Contexts contextText)
 245   -- liftIO $ liftIO $ pure $  maybe t identity maybeGraph
 246   -- TODO what do we get about the node? to replace contextText
 247
 248 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 249 instance HasTreeError ServantErr where
 250   _TreeError = prism' mk (const Nothing) -- Note a prism
 251     where
 252       mk NoRoot       = err404 { errBody = "Root node not found"           }
 253       mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
 254       mk TooManyRoots = err500 { errBody = "Too many root nodes"           }
 255
 256 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 257 treeAPI :: Connection -> NodeId -> Server TreeAPI
 258 treeAPI = treeDB
 259
 260 ------------------------------------------------------------------------
 261 -- | Check if the name is less than 255 char
 262 rename :: Connection -> NodeId -> RenameNode -> Handler [Int]
 263 rename c nId (RenameNode name) = liftIO $ U.update (U.Rename nId name) c
 264
 265 getTable :: Connection -> NodeId -> Maybe TabType
 266          -> Maybe Offset  -> Maybe Limit
 267          -> Maybe OrderBy -> Handler [FacetDoc]
 268 getTable c cId ft o l order = liftIO $ case ft of
 269                                 (Just Docs)  -> runViewDocuments' c cId False o l order
 270                                 (Just Trash) -> runViewDocuments' c cId True  o l order
 271                                 _     -> panic "not implemented"
 272
 273 getChart :: Connection -> NodeId -> Maybe UTCTime -> Maybe UTCTime
 274                         -> Handler [FacetChart]
 275 getChart _ _ _ _ = undefined -- TODO
 276
 277 postNode :: Connection -> NodeId -> PostNode -> Handler [Int]
 278 postNode c pId (PostNode name nt) = liftIO $ mk c nt (Just pId) name
 279
 280 putNode :: Connection -> NodeId -> Handler Int
 281 putNode = undefined -- TODO
 282
 283 deleteNodes' :: Connection -> [NodeId] -> Handler Int
 284 deleteNodes' conn ids = liftIO (runCmd conn $ deleteNodes ids)
 285
 286 deleteNode' :: Connection -> NodeId -> Handler Int
 287 deleteNode' conn id = liftIO (runCmd conn $ deleteNode id)
 288
 289 getChildren' :: JSONB a => Connection -> NodeId -> proxy a -> Maybe NodeType
 290               -> Maybe Int -> Maybe Int -> Handler [Node a]
 291 getChildren' conn pId p nodeType offset limit  = liftIO (getChildren conn pId p nodeType offset limit)
 292
 293 tableNgramsPatch' :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> Handler NgramsIdPatchsBack
 294 tableNgramsPatch' c cId mL ns = liftIO $ tableNgramsPatch c cId mL ns
 295
 296 getTableNgrams' :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> Handler NgramsTable
 297 getTableNgrams' c cId nType mL = liftIO $ getTableNgrams c cId nType mL
 298
 299 query :: Text -> Handler Text
 300 query s = pure s
 301
 302
 303 -- | Upload files
 304 -- TODO Is it possible to adapt the function according to iValue input ?
 305 --upload :: MultipartData -> Handler Text
 306 --upload multipartData = do
 307 --  liftIO $ do
 308 --    putStrLn "Inputs:"
 309 --    forM_ (inputs multipartData) $ \input ->
 310 --      putStrLn $ "  " <> show (iName input)
 311 --            <> " -> " <> show (iValue input)
 312 --
 313 --    forM_ (files multipartData) $ \file -> do
 314 --      content <- readFile (fdFilePath file)
 315 --      putStrLn $ "Content of " <> show (fdFileName file)
 316 --              <> " at " <> fdFilePath file
 317 --      putStrLn content
 318 --  pure (pack "Data loaded")
 319