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 RankNTypes         #-}
  21 {-# LANGUAGE TemplateHaskell    #-}
  22 {-# LANGUAGE TypeOperators      #-}
  23
  24 -------------------------------------------------------------------
  25 module Gargantext.API.Node
  26   ( module Gargantext.API.Node
  27   , HyperdataAny(..)
  28   , HyperdataAnnuaire(..)
  29   , HyperdataCorpus(..)
  30   , HyperdataResource(..)
  31   , HyperdataUser(..)
  32   , HyperdataDocument(..)
  33   , HyperdataDocumentV3(..)
  34   ) where
  35 -------------------------------------------------------------------
  36 import Control.Lens (prism', set)
  37 import Control.Monad.IO.Class (liftIO)
  38 import Control.Monad ((>>), guard)
  39 --import System.IO (putStrLn, readFile)
  40
  41 import Data.Aeson (FromJSON, ToJSON)
  42 import Data.Functor (($>))
  43 --import Data.Text (Text(), pack)
  44 import Data.Text (Text())
  45 import Data.Swagger
  46 import Data.Time (UTCTime)
  47
  48 import GHC.Generics (Generic)
  49 import Servant
  50
  51 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams)
  52 import Gargantext.Prelude
  53 import Gargantext.Database.Types.Node
  54 import Gargantext.Database.Utils (Cmd, CmdM)
  55 import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB, NodeError(..), HasNodeError(..))
  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 import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
  62 -- Graph
  63 --import Gargantext.Text.Flow
  64 import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
  65 -- import Gargantext.Core (Lang(..))
  66 import Gargantext.Core.Types (Offset, Limit)
  67 import Gargantext.Core.Types.Main (Tree, NodeTree, CorpusId, ContactId)
  68 -- import Gargantext.Text.Terms (TermType(..))
  69
  70 import Test.QuickCheck (elements)
  71 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  72
  73 type GargServer api = forall env m. CmdM env ServantErr m => ServerT api m
  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 :: [NodeId] -> GargServer NodesAPI
  83 nodesAPI ids = deleteNodes ids
  84
  85 ------------------------------------------------------------------------
  86 -- | TODO: access by admin only
  87 -- To manager the Users roots
  88 type Roots =  Get    '[JSON] [NodeAny]
  89          :<|> Put    '[JSON] Int -- TODO
  90
  91 -- | TODO: access by admin only
  92 roots :: GargServer Roots
  93 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
  94    :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
  95
  96 -------------------------------------------------------------------
  97 -- | Node API Types management
  98 -- TODO : access by users
  99 type NodeAPI a = Get '[JSON] (Node a)
 100              :<|> "rename" :> RenameApi
 101              :<|> PostNodeApi
 102              :<|> Put    '[JSON] Int
 103              :<|> Delete '[JSON] Int
 104              :<|> "children"  :> ChildrenApi a
 105
 106              -- TODO gather it
 107              :<|> "table"     :> TableApi
 108              :<|> "list"      :> TableNgramsApi
 109              :<|> "listGet"   :> TableNgramsApiGet
 110              :<|> "pairing"   :> PairingApi
 111
 112              :<|> "chart"     :> ChartApi
 113              :<|> "favorites" :> FavApi
 114              :<|> "documents" :> DocsApi
 115              :<|> "search":> Summary "Node Search"
 116                         :> ReqBody '[JSON] SearchInQuery
 117                         :> QueryParam "offset" Int
 118                         :> QueryParam "limit"  Int
 119                         :> QueryParam "order"  OrderBy
 120                         :> SearchAPI
 121
 122 type RenameApi = Summary " RenameNode Node"
 123                :> ReqBody '[JSON] RenameNode
 124                :> Put     '[JSON] [Int]
 125
 126 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 127                  :> ReqBody '[JSON] PostNode
 128                  :> Post    '[JSON] [Int]
 129
 130 type ChildrenApi a = Summary " Summary children"
 131                  :> QueryParam "type"   NodeType
 132                  :> QueryParam "offset" Int
 133                  :> QueryParam "limit"  Int
 134                  :> Get '[JSON] [Node a]
 135 ------------------------------------------------------------------------
 136 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 137 nodeAPI :: JSONB a => proxy a -> NodeId -> GargServer (NodeAPI a)
 138 nodeAPI p id =  getNode     id p
 139            :<|> rename      id
 140            :<|> postNode    id
 141            :<|> putNode     id
 142            :<|> deleteNode  id
 143            :<|> getChildren id p
 144
 145            -- TODO gather it
 146            :<|> getTable         id
 147            :<|> tableNgramsPatch id
 148            :<|> getTableNgrams   id
 149            :<|> getPairing       id
 150
 151            :<|> getChart id
 152            :<|> favApi   id
 153            :<|> delDocs  id
 154            :<|> searchIn id
 155            -- Annuaire
 156            -- :<|> upload
 157            -- :<|> query
 158 ------------------------------------------------------------------------
 159 data RenameNode = RenameNode { r_name :: Text }
 160   deriving (Generic)
 161
 162 instance FromJSON  RenameNode
 163 instance ToJSON    RenameNode
 164 instance ToSchema  RenameNode
 165 instance Arbitrary RenameNode where
 166   arbitrary = elements [RenameNode "test"]
 167 ------------------------------------------------------------------------
 168 data PostNode = PostNode { pn_name :: Text
 169                          , pn_typename :: NodeType}
 170   deriving (Generic)
 171
 172 instance FromJSON  PostNode
 173 instance ToJSON    PostNode
 174 instance ToSchema  PostNode
 175 instance Arbitrary PostNode where
 176   arbitrary = elements [PostNode "Node test" NodeCorpus]
 177
 178 ------------------------------------------------------------------------
 179 type DocsApi = Summary "Docs : Move to trash"
 180              :> ReqBody '[JSON] Documents
 181              :> Delete  '[JSON] [Int]
 182
 183 data Documents = Documents { documents :: [NodeId]}
 184   deriving (Generic)
 185
 186 instance FromJSON  Documents
 187 instance ToJSON    Documents
 188 instance ToSchema  Documents
 189
 190 delDocs :: CorpusId -> Documents -> Cmd err [Int]
 191 delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 192
 193 ------------------------------------------------------------------------
 194 type FavApi =  Summary " Favorites label"
 195             :> ReqBody '[JSON] Favorites
 196             :> Put     '[JSON] [Int]
 197           :<|> Summary " Favorites unlabel"
 198             :> ReqBody '[JSON] Favorites
 199             :> Delete  '[JSON] [Int]
 200
 201 data Favorites = Favorites { favorites :: [NodeId]}
 202   deriving (Generic)
 203
 204 instance FromJSON  Favorites
 205 instance ToJSON    Favorites
 206 instance ToSchema  Favorites
 207
 208 putFav :: CorpusId -> Favorites -> Cmd err [Int]
 209 putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 210
 211 delFav :: CorpusId -> Favorites -> Cmd err [Int]
 212 delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 213
 214 favApi :: CorpusId -> GargServer FavApi
 215 favApi cId = putFav cId :<|> delFav cId
 216
 217 ------------------------------------------------------------------------
 218 type TableApi = Summary " Table API"
 219               :> QueryParam "view"   TabType
 220               :> QueryParam "offset" Int
 221               :> QueryParam "limit"  Int
 222               :> QueryParam "order"  OrderBy
 223               :> Get '[JSON] [FacetDoc]
 224
 225 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 226 type PairingApi = Summary " Pairing API"
 227               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 228               :> QueryParam "offset" Int
 229               :> QueryParam "limit"  Int
 230               :> QueryParam "order"  OrderBy
 231               :> Get '[JSON] [FacetDoc]
 232
 233 ------------------------------------------------------------------------
 234 type ChartApi = Summary " Chart API"
 235               :> QueryParam "from" UTCTime
 236               :> QueryParam "to"   UTCTime
 237               :> Get '[JSON] [FacetChart]
 238
 239                 -- Depending on the Type of the Node, we could post
 240                 -- New documents for a corpus
 241                 -- New map list terms
 242              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 243
 244                 -- To launch a query and update the corpus
 245              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 246
 247 ------------------------------------------------------------------------
 248 type GraphAPI   = Get '[JSON] Graph
 249 graphAPI :: NodeId -> GargServer GraphAPI
 250 graphAPI nId = do
 251
 252   nodeGraph <- getNode nId HyperdataGraph
 253
 254   let title = "IMT - Scientific publications - 1982-2017 - English"
 255   let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph] [ LegendField 6 "#FFF" "Data processing"
 256                                                                                    , LegendField 7 "#FFF" "Networks"
 257                                                                                    , LegendField 1 "#FFF" "Material science"
 258                                                                                    , LegendField 5 "#FFF" "Energy / Environment"
 259                                                                                    ]
 260                                        -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 261
 262   graph <- set graph_metadata (Just metadata)
 263         <$> maybe defaultGraph identity
 264         <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
 265
 266   pure graph
 267   -- t <- textFlow (Mono EN) (Contexts contextText)
 268   -- liftIO $ liftIO $ pure $  maybe t identity maybeGraph
 269   -- TODO what do we get about the node? to replace contextText
 270
 271 instance HasNodeError ServantErr where
 272   _NodeError = prism' make match
 273     where
 274       err = err404 { errBody = "NodeError: No list found" }
 275       make NoListFound = err
 276       match e = guard (e == err) $> NoListFound
 277
 278 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 279 instance HasTreeError ServantErr where
 280   _TreeError = prism' mk (const $ panic "HasTreeError ServantErr: not a prism")
 281     where
 282       mk NoRoot       = err404 { errBody = "Root node not found"           }
 283       mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
 284       mk TooManyRoots = err500 { errBody = "Too many root nodes"           }
 285
 286 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 287 treeAPI :: NodeId -> GargServer TreeAPI
 288 treeAPI = treeDB
 289
 290 ------------------------------------------------------------------------
 291 -- | Check if the name is less than 255 char
 292 rename :: NodeId -> RenameNode -> Cmd err [Int]
 293 rename nId (RenameNode name) = U.update (U.Rename nId name)
 294
 295 getTable :: NodeId -> Maybe TabType
 296          -> Maybe Offset  -> Maybe Limit
 297          -> Maybe OrderBy -> Cmd err [FacetDoc]
 298 getTable cId ft o l order = case ft of
 299                                 (Just Docs)  -> runViewDocuments cId False o l order
 300                                 (Just Trash) -> runViewDocuments cId True  o l order
 301                                 _     -> panic "not implemented"
 302
 303 getPairing :: ContactId -> Maybe TabType
 304          -> Maybe Offset  -> Maybe Limit
 305          -> Maybe OrderBy -> Cmd err [FacetDoc]
 306 getPairing cId ft o l order = case ft of
 307                                 (Just Docs)  -> runViewAuthorsDoc cId False o l order
 308                                 (Just Trash) -> runViewAuthorsDoc cId True  o l order
 309                                 _     -> panic "not implemented"
 310
 311
 312 getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
 313                    -> Cmd err [FacetChart]
 314 getChart _ _ _ = undefined -- TODO
 315
 316 postNode :: NodeId -> PostNode -> Cmd err [Int]
 317 postNode pId (PostNode name nt) = mk nt (Just pId) name
 318
 319 putNode :: NodeId -> Cmd err Int
 320 putNode = undefined -- TODO
 321
 322 query :: Monad m => Text -> m Text
 323 query s = pure s
 324
 325
 326 -- | Upload files
 327 -- TODO Is it possible to adapt the function according to iValue input ?
 328 --upload :: MultipartData -> Handler Text
 329 --upload multipartData = do
 330 --  liftIO $ do
 331 --    putStrLn "Inputs:"
 332 --    forM_ (inputs multipartData) $ \input ->
 333 --      putStrLn $ "  " <> show (iName input)
 334 --            <> " -> " <> show (iValue input)
 335 --
 336 --    forM_ (files multipartData) $ \file -> do
 337 --      content <- readFile (fdFilePath file)
 338 --      putStrLn $ "Content of " <> show (fdFileName file)
 339 --              <> " at " <> fdFilePath file
 340 --      putStrLn content
 341 --  pure (pack "Data loaded")
 342