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