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 metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph]
 255                                        [ LegendField 1 "#FFFFFF" "Label 1"
 256                                        , LegendField 2 "#0048BA" "Label 2"
 257                                        ]
 258
 259   graph <- set graph_metadata (Just metadata)
 260         <$> maybe defaultGraph identity
 261         <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
 262
 263   pure graph
 264   -- t <- textFlow (Mono EN) (Contexts contextText)
 265   -- liftIO $ liftIO $ pure $  maybe t identity maybeGraph
 266   -- TODO what do we get about the node? to replace contextText
 267
 268 instance HasNodeError ServantErr where
 269   _NodeError = prism' make match
 270     where
 271       err = err404 { errBody = "NodeError: No list found" }
 272       make NoListFound = err
 273       match e = guard (e == err) $> NoListFound
 274
 275 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 276 instance HasTreeError ServantErr where
 277   _TreeError = prism' mk (const $ panic "HasTreeError ServantErr: not a prism")
 278     where
 279       mk NoRoot       = err404 { errBody = "Root node not found"           }
 280       mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
 281       mk TooManyRoots = err500 { errBody = "Too many root nodes"           }
 282
 283 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 284 treeAPI :: NodeId -> GargServer TreeAPI
 285 treeAPI = treeDB
 286
 287 ------------------------------------------------------------------------
 288 -- | Check if the name is less than 255 char
 289 rename :: NodeId -> RenameNode -> Cmd err [Int]
 290 rename nId (RenameNode name) = U.update (U.Rename nId name)
 291
 292 getTable :: NodeId -> Maybe TabType
 293          -> Maybe Offset  -> Maybe Limit
 294          -> Maybe OrderBy -> Cmd err [FacetDoc]
 295 getTable cId ft o l order = case ft of
 296                                 (Just Docs)  -> runViewDocuments cId False o l order
 297                                 (Just Trash) -> runViewDocuments cId True  o l order
 298                                 _     -> panic "not implemented"
 299
 300 getPairing :: ContactId -> Maybe TabType
 301          -> Maybe Offset  -> Maybe Limit
 302          -> Maybe OrderBy -> Cmd err [FacetDoc]
 303 getPairing cId ft o l order = case ft of
 304                                 (Just Docs)  -> runViewAuthorsDoc cId False o l order
 305                                 (Just Trash) -> runViewAuthorsDoc cId True  o l order
 306                                 _     -> panic "not implemented"
 307
 308
 309 getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
 310                    -> Cmd err [FacetChart]
 311 getChart _ _ _ = undefined -- TODO
 312
 313 postNode :: NodeId -> PostNode -> Cmd err [Int]
 314 postNode pId (PostNode name nt) = mk nt (Just pId) name
 315
 316 putNode :: NodeId -> Cmd err Int
 317 putNode = undefined -- TODO
 318
 319 query :: Monad m => Text -> m Text
 320 query s = pure s
 321
 322
 323 -- | Upload files
 324 -- TODO Is it possible to adapt the function according to iValue input ?
 325 --upload :: MultipartData -> Handler Text
 326 --upload multipartData = do
 327 --  liftIO $ do
 328 --    putStrLn "Inputs:"
 329 --    forM_ (inputs multipartData) $ \input ->
 330 --      putStrLn $ "  " <> show (iName input)
 331 --            <> " -> " <> show (iValue input)
 332 --
 333 --    forM_ (files multipartData) $ \file -> do
 334 --      content <- readFile (fdFilePath file)
 335 --      putStrLn $ "Content of " <> show (fdFileName file)
 336 --              <> " at " <> fdFilePath file
 337 --      putStrLn content
 338 --  pure (pack "Data loaded")
 339