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', set)
  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)
  52 import Gargantext.Prelude
  53 import Gargantext.Database.Types.Node
  54 import Gargantext.Database.Utils (runCmd)
  55 import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB)
  56 import Gargantext.Database.Node.Children (getChildren)
  57 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  58 import Gargantext.Database.Facet (FacetDoc , runViewDocuments', OrderBy(..),FacetChart,runViewAuthorsDoc)
  59 import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
  60 import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
  61 -- Graph
  62 --import Gargantext.Text.Flow
  63 import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
  64 -- import Gargantext.Core (Lang(..))
  65 import Gargantext.Core.Types (Offset, Limit)
  66 import Gargantext.Core.Types.Main (Tree, NodeTree, ListId, CorpusId, ContactId)
  67 -- import Gargantext.Text.Terms (TermType(..))
  68
  69 import Test.QuickCheck (elements)
  70 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  71
  72 -------------------------------------------------------------------
  73 -- | TODO : access by admin only
  74 type NodesAPI  = Delete '[JSON] Int
  75
  76 -- | Delete Nodes
  77 -- Be careful: really delete nodes
  78 -- Access by admin only
  79 nodesAPI :: Connection -> [NodeId] -> Server NodesAPI
  80 nodesAPI conn ids = deleteNodes' conn ids
  81
  82 ------------------------------------------------------------------------
  83 -- | TODO: access by admin only
  84 -- To manager the Users roots
  85 type Roots =  Get    '[JSON] [NodeAny]
  86          :<|> Post   '[JSON] Int -- TODO
  87          :<|> Put    '[JSON] Int -- TODO
  88          :<|> Delete '[JSON] Int -- TODO
  89
  90 -- | TODO: access by admin only
  91 roots :: Connection -> Server Roots
  92 roots conn = liftIO (putStrLn ( "/user" :: Text) >> getNodesWithParentId 0 Nothing conn)
  93           :<|> pure (panic "not implemented yet") -- TODO
  94           :<|> pure (panic "not implemented yet") -- TODO
  95           :<|> pure (panic "not implemented yet") -- TODO
  96
  97 -------------------------------------------------------------------
  98 -- | Node API Types management
  99 -- TODO : access by users
 100 type NodeAPI a = Get '[JSON] (Node a)
 101              :<|> "rename" :> RenameApi
 102              :<|> PostNodeApi
 103              :<|> Put    '[JSON] Int
 104              :<|> Delete '[JSON] Int
 105              :<|> "children"  :> ChildrenApi a
 106
 107              -- TODO gather it
 108              :<|> "table"     :> TableApi
 109              :<|> "list"      :> TableNgramsApi
 110              :<|> "listGet"   :> TableNgramsApiGet
 111              :<|> "pairing"   :> PairingApi
 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               :<|> getChildren'  conn id p
 140
 141               -- TODO gather it
 142               :<|> getTable      conn id
 143               :<|> tableNgramsPatch'  conn id
 144               :<|> getTableNgrams  conn id
 145               :<|> getPairing      conn id
 146
 147               :<|> getChart      conn id
 148               :<|> favApi        conn id
 149               :<|> delDocs       conn id
 150               -- Annuaire
 151               -- :<|> upload
 152               -- :<|> query
 153 ------------------------------------------------------------------------
 154 data RenameNode = RenameNode { r_name :: Text }
 155   deriving (Generic)
 156
 157 instance FromJSON  RenameNode
 158 instance ToJSON    RenameNode
 159 instance ToSchema  RenameNode
 160 instance Arbitrary RenameNode where
 161   arbitrary = elements [RenameNode "test"]
 162 ------------------------------------------------------------------------
 163 data PostNode = PostNode { pn_name :: Text
 164                          , pn_typename :: NodeType}
 165   deriving (Generic)
 166
 167 instance FromJSON  PostNode
 168 instance ToJSON    PostNode
 169 instance ToSchema  PostNode
 170 instance Arbitrary PostNode where
 171   arbitrary = elements [PostNode "Node test" NodeCorpus]
 172
 173 ------------------------------------------------------------------------
 174 type DocsApi = Summary "Docs : Move to trash"
 175              :> ReqBody '[JSON] Documents
 176              :> Delete  '[JSON] [Int]
 177
 178 data Documents = Documents { documents :: [NodeId]}
 179   deriving (Generic)
 180
 181 instance FromJSON  Documents
 182 instance ToJSON    Documents
 183 instance ToSchema  Documents
 184
 185 delDocs :: Connection -> CorpusId -> Documents -> Handler [Int]
 186 delDocs c cId ds = liftIO $ nodesToTrash c
 187                 $ map (\n -> (cId, n, True)) $ documents ds
 188
 189 ------------------------------------------------------------------------
 190 type FavApi =  Summary " Favorites label"
 191             :> ReqBody '[JSON] Favorites
 192             :> Put     '[JSON] [Int]
 193           :<|> Summary " Favorites unlabel"
 194             :> ReqBody '[JSON] Favorites
 195             :> Delete  '[JSON] [Int]
 196
 197 data Favorites = Favorites { favorites :: [NodeId]}
 198   deriving (Generic)
 199
 200 instance FromJSON  Favorites
 201 instance ToJSON    Favorites
 202 instance ToSchema  Favorites
 203
 204 putFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
 205 putFav c cId fs = liftIO $ nodesToFavorite c
 206                 $ map (\n -> (cId, n, True)) $ favorites fs
 207
 208 delFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
 209 delFav c cId fs = liftIO $ nodesToFavorite c
 210                 $ map (\n -> (cId, n, False)) $ favorites fs
 211
 212 favApi :: Connection -> CorpusId -> (Favorites -> Handler [Int])
 213                                :<|> (Favorites -> Handler [Int])
 214 favApi c cId = putFav c cId :<|> delFav c cId
 215
 216 ------------------------------------------------------------------------
 217 type TableApi = Summary " Table API"
 218               :> QueryParam "view"   TabType
 219               :> QueryParam "offset" Int
 220               :> QueryParam "limit"  Int
 221               :> QueryParam "order"  OrderBy
 222               :> Get '[JSON] [FacetDoc]
 223
 224 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 225 type PairingApi = Summary " Pairing API"
 226               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 227               :> QueryParam "offset" Int
 228               :> QueryParam "limit"  Int
 229               :> QueryParam "order"  OrderBy
 230               :> Get '[JSON] [FacetDoc]
 231
 232 ------------------------------------------------------------------------
 233 type ChartApi = Summary " Chart API"
 234               :> QueryParam "from" UTCTime
 235               :> QueryParam "to"   UTCTime
 236               :> Get '[JSON] [FacetChart]
 237
 238                 -- Depending on the Type of the Node, we could post
 239                 -- New documents for a corpus
 240                 -- New map list terms
 241              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 242
 243                 -- To launch a query and update the corpus
 244              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 245
 246 ------------------------------------------------------------------------
 247 type GraphAPI   = Get '[JSON] Graph
 248 graphAPI :: Connection -> NodeId -> Server GraphAPI
 249 graphAPI c nId = liftIO $ graphAPI' c nId
 250
 251 graphAPI' :: Connection -> NodeId -> IO Graph
 252 graphAPI' c nId = do
 253
 254   nodeGraph <- getNode c nId HyperdataGraph
 255
 256   let metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph]
 257                                        [ LegendField 1 "#FFFFFF" "Label 1"
 258                                        , LegendField 2 "#0048BA" "Label 2"
 259                                        ]
 260
 261   graph <- set graph_metadata (Just metadata) <$> maybe defaultGraph identity <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
 262
 263   pure graph
 264
 265
 266   -- t <- textFlow (Mono EN) (Contexts contextText)
 267   -- liftIO $ liftIO $ pure $  maybe t identity maybeGraph
 268   -- TODO what do we get about the node? to replace contextText
 269
 270 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 271 instance HasTreeError ServantErr where
 272   _TreeError = prism' mk (const Nothing) -- Note a prism
 273     where
 274       mk NoRoot       = err404 { errBody = "Root node not found"           }
 275       mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
 276       mk TooManyRoots = err500 { errBody = "Too many root nodes"           }
 277
 278 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 279 treeAPI :: Connection -> NodeId -> Server TreeAPI
 280 treeAPI = treeDB
 281
 282 ------------------------------------------------------------------------
 283 -- | Check if the name is less than 255 char
 284 rename :: Connection -> NodeId -> RenameNode -> Handler [Int]
 285 rename c nId (RenameNode name) = liftIO $ U.update (U.Rename nId name) c
 286
 287 getTable :: Connection -> NodeId -> Maybe TabType
 288          -> Maybe Offset  -> Maybe Limit
 289          -> Maybe OrderBy -> Handler [FacetDoc]
 290 getTable c cId ft o l order = liftIO $ case ft of
 291                                 (Just Docs)  -> runViewDocuments' c cId False o l order
 292                                 (Just Trash) -> runViewDocuments' c cId True  o l order
 293                                 _     -> panic "not implemented"
 294
 295 getPairing :: Connection -> ContactId -> Maybe TabType
 296          -> Maybe Offset  -> Maybe Limit
 297          -> Maybe OrderBy -> Handler [FacetDoc]
 298 getPairing c cId ft o l order = liftIO $ case ft of
 299                                 (Just Docs)  -> runViewAuthorsDoc c cId False o l order
 300                                 (Just Trash) -> runViewAuthorsDoc c cId True  o l order
 301                                 _     -> panic "not implemented"
 302
 303
 304 getChart :: Connection -> NodeId -> Maybe UTCTime -> Maybe UTCTime
 305                         -> Handler [FacetChart]
 306 getChart _ _ _ _ = undefined -- TODO
 307
 308 postNode :: Connection -> NodeId -> PostNode -> Handler [Int]
 309 postNode c pId (PostNode name nt) = liftIO $ mk c nt (Just pId) name
 310
 311 putNode :: Connection -> NodeId -> Handler Int
 312 putNode = undefined -- TODO
 313
 314 deleteNodes' :: Connection -> [NodeId] -> Handler Int
 315 deleteNodes' conn ids = liftIO (runCmd conn $ deleteNodes ids)
 316
 317 deleteNode' :: Connection -> NodeId -> Handler Int
 318 deleteNode' conn id = liftIO (runCmd conn $ deleteNode id)
 319
 320 getChildren' :: JSONB a => Connection -> NodeId -> proxy a -> Maybe NodeType
 321               -> Maybe Int -> Maybe Int -> Handler [Node a]
 322 getChildren' conn pId p nodeType offset limit  = liftIO (getChildren conn pId p nodeType offset limit)
 323
 324 tableNgramsPatch' :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> Handler NgramsIdPatchsBack
 325 tableNgramsPatch' c cId mL ns = liftIO $ tableNgramsPatch c cId mL ns
 326
 327 query :: Text -> Handler Text
 328 query s = pure s
 329
 330
 331 -- | Upload files
 332 -- TODO Is it possible to adapt the function according to iValue input ?
 333 --upload :: MultipartData -> Handler Text
 334 --upload multipartData = do
 335 --  liftIO $ do
 336 --    putStrLn "Inputs:"
 337 --    forM_ (inputs multipartData) $ \input ->
 338 --      putStrLn $ "  " <> show (iName input)
 339 --            <> " -> " <> show (iValue input)
 340 --
 341 --    forM_ (files multipartData) $ \file -> do
 342 --      content <- readFile (fdFilePath file)
 343 --      putStrLn $ "Content of " <> show (fdFileName file)
 344 --              <> " at " <> fdFilePath file
 345 --      putStrLn content
 346 --  pure (pack "Data loaded")
 347