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)
  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 (Graph,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 _ _ = do
 250   liftIO $ maybe defaultGraph identity <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
 251   -- t <- textFlow (Mono EN) (Contexts contextText)
 252   -- liftIO $ liftIO $ pure $  maybe t identity maybeGraph
 253   -- TODO what do we get about the node? to replace contextText
 254
 255 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 256 instance HasTreeError ServantErr where
 257   _TreeError = prism' mk (const Nothing) -- Note a prism
 258     where
 259       mk NoRoot       = err404 { errBody = "Root node not found"           }
 260       mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
 261       mk TooManyRoots = err500 { errBody = "Too many root nodes"           }
 262
 263 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 264 treeAPI :: Connection -> NodeId -> Server TreeAPI
 265 treeAPI = treeDB
 266
 267 ------------------------------------------------------------------------
 268 -- | Check if the name is less than 255 char
 269 rename :: Connection -> NodeId -> RenameNode -> Handler [Int]
 270 rename c nId (RenameNode name) = liftIO $ U.update (U.Rename nId name) c
 271
 272 getTable :: Connection -> NodeId -> Maybe TabType
 273          -> Maybe Offset  -> Maybe Limit
 274          -> Maybe OrderBy -> Handler [FacetDoc]
 275 getTable c cId ft o l order = liftIO $ case ft of
 276                                 (Just Docs)  -> runViewDocuments' c cId False o l order
 277                                 (Just Trash) -> runViewDocuments' c cId True  o l order
 278                                 _     -> panic "not implemented"
 279
 280 getPairing :: Connection -> ContactId -> Maybe TabType
 281          -> Maybe Offset  -> Maybe Limit
 282          -> Maybe OrderBy -> Handler [FacetDoc]
 283 getPairing c cId ft o l order = liftIO $ case ft of
 284                                 (Just Docs)  -> runViewAuthorsDoc c cId False o l order
 285                                 (Just Trash) -> runViewAuthorsDoc c cId True  o l order
 286                                 _     -> panic "not implemented"
 287
 288
 289 getChart :: Connection -> NodeId -> Maybe UTCTime -> Maybe UTCTime
 290                         -> Handler [FacetChart]
 291 getChart _ _ _ _ = undefined -- TODO
 292
 293 postNode :: Connection -> NodeId -> PostNode -> Handler [Int]
 294 postNode c pId (PostNode name nt) = liftIO $ mk c nt (Just pId) name
 295
 296 putNode :: Connection -> NodeId -> Handler Int
 297 putNode = undefined -- TODO
 298
 299 deleteNodes' :: Connection -> [NodeId] -> Handler Int
 300 deleteNodes' conn ids = liftIO (runCmd conn $ deleteNodes ids)
 301
 302 deleteNode' :: Connection -> NodeId -> Handler Int
 303 deleteNode' conn id = liftIO (runCmd conn $ deleteNode id)
 304
 305 getChildren' :: JSONB a => Connection -> NodeId -> proxy a -> Maybe NodeType
 306               -> Maybe Int -> Maybe Int -> Handler [Node a]
 307 getChildren' conn pId p nodeType offset limit  = liftIO (getChildren conn pId p nodeType offset limit)
 308
 309 tableNgramsPatch' :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> Handler NgramsIdPatchsBack
 310 tableNgramsPatch' c cId mL ns = liftIO $ tableNgramsPatch c cId mL ns
 311
 312 query :: Text -> Handler Text
 313 query s = pure s
 314
 315
 316 -- | Upload files
 317 -- TODO Is it possible to adapt the function according to iValue input ?
 318 --upload :: MultipartData -> Handler Text
 319 --upload multipartData = do
 320 --  liftIO $ do
 321 --    putStrLn "Inputs:"
 322 --    forM_ (inputs multipartData) $ \input ->
 323 --      putStrLn $ "  " <> show (iName input)
 324 --            <> " -> " <> show (iValue input)
 325 --
 326 --    forM_ (files multipartData) $ \file -> do
 327 --      content <- readFile (fdFilePath file)
 328 --      putStrLn $ "Content of " <> show (fdFileName file)
 329 --              <> " at " <> fdFilePath file
 330 --      putStrLn content
 331 --  pure (pack "Data loaded")
 332