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