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