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 ((>>))
  39 --import System.IO (putStrLn, readFile)
  40
  41 import Data.Aeson (FromJSON, ToJSON)
  42 import Data.Text (Text())
  43 import Data.Swagger
  44 import Data.Time (UTCTime)
  45
  46 import GHC.Generics (Generic)
  47 import Servant
  48
  49 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams)
  50 import Gargantext.Prelude
  51 import Gargantext.Database.Types.Node
  52 import Gargantext.Database.Utils (Cmd, CmdM)
  53 import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB, NodeError(..), HasNodeError(..))
  54 import Gargantext.Database.Node.Children (getChildren)
  55 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  56 import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),FacetChart,runViewAuthorsDoc)
  57 import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
  58 import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
  59 import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
  60 -- Graph
  61 --import Gargantext.Text.Flow
  62 import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
  63 -- import Gargantext.Core (Lang(..))
  64 import Gargantext.Core.Types (Offset, Limit)
  65 import Gargantext.Core.Types.Main (Tree, NodeTree)
  66 import Gargantext.Database.Types.Node (CorpusId, ContactId)
  67 -- import Gargantext.Text.Terms (TermType(..))
  68
  69 import Test.QuickCheck (elements)
  70 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  71
  72 type GargServer api = forall env m. CmdM env ServantErr m => ServerT api m
  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 :: [NodeId] -> GargServer NodesAPI
  82 nodesAPI ids = deleteNodes ids
  83
  84 ------------------------------------------------------------------------
  85 -- | TODO: access by admin only
  86 -- To manager the Users roots
  87 type Roots =  Get    '[JSON] [NodeAny]
  88          :<|> Put    '[JSON] Int -- TODO
  89
  90 -- | TODO: access by admin only
  91 roots :: GargServer Roots
  92 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
  93    :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
  94
  95 -------------------------------------------------------------------
  96 -- | Node API Types management
  97 -- TODO : access by users
  98 type NodeAPI a = Get '[JSON] (Node a)
  99              :<|> "rename" :> RenameApi
 100              :<|> PostNodeApi
 101              :<|> Put    '[JSON] Int
 102              :<|> Delete '[JSON] Int
 103              :<|> "children"  :> ChildrenApi a
 104
 105              -- TODO gather it
 106              :<|> "table"     :> TableApi
 107              :<|> "list"      :> TableNgramsApi
 108              :<|> "listGet"   :> TableNgramsApiGet
 109              :<|> "pairing"   :> PairingApi
 110
 111              :<|> "chart"     :> ChartApi
 112              :<|> "favorites" :> FavApi
 113              :<|> "documents" :> DocsApi
 114              :<|> "search":> Summary "Node Search"
 115                         :> ReqBody '[JSON] SearchInQuery
 116                         :> QueryParam "offset" Int
 117                         :> QueryParam "limit"  Int
 118                         :> QueryParam "order"  OrderBy
 119                         :> SearchAPI
 120
 121 type RenameApi = Summary " Rename Node"
 122                :> ReqBody '[JSON] RenameNode
 123                :> Put     '[JSON] [Int]
 124
 125 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 126                  :> ReqBody '[JSON] PostNode
 127                  :> Post    '[JSON] [NodeId]
 128
 129 type ChildrenApi a = Summary " Summary children"
 130                  :> QueryParam "type"   NodeType
 131                  :> QueryParam "offset" Int
 132                  :> QueryParam "limit"  Int
 133                  :> Get '[JSON] [Node a]
 134 ------------------------------------------------------------------------
 135 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 136 nodeAPI :: JSONB a => proxy a -> NodeId -> GargServer (NodeAPI a)
 137 nodeAPI p id =  getNode     id p
 138            :<|> rename      id
 139            :<|> postNode    id
 140            :<|> putNode     id
 141            :<|> deleteNode  id
 142            :<|> getChildren id p
 143
 144            -- TODO gather it
 145            :<|> getTable         id
 146            :<|> tableNgramsPatch id
 147            :<|> getTableNgrams   id
 148            :<|> getPairing       id
 149
 150            :<|> getChart id
 151            :<|> favApi   id
 152            :<|> delDocs  id
 153            :<|> searchIn id
 154            -- Annuaire
 155            -- :<|> upload
 156            -- :<|> query
 157 ------------------------------------------------------------------------
 158 data RenameNode = RenameNode { r_name :: Text }
 159   deriving (Generic)
 160
 161 instance FromJSON  RenameNode
 162 instance ToJSON    RenameNode
 163 instance ToSchema  RenameNode
 164 instance Arbitrary RenameNode where
 165   arbitrary = elements [RenameNode "test"]
 166 ------------------------------------------------------------------------
 167 data PostNode = PostNode { pn_name :: Text
 168                          , pn_typename :: NodeType}
 169   deriving (Generic)
 170
 171 instance FromJSON  PostNode
 172 instance ToJSON    PostNode
 173 instance ToSchema  PostNode
 174 instance Arbitrary PostNode where
 175   arbitrary = elements [PostNode "Node test" NodeCorpus]
 176
 177 ------------------------------------------------------------------------
 178 type DocsApi = Summary "Docs : Move to trash"
 179              :> ReqBody '[JSON] Documents
 180              :> Delete  '[JSON] [Int]
 181
 182 data Documents = Documents { documents :: [NodeId]}
 183   deriving (Generic)
 184
 185 instance FromJSON  Documents
 186 instance ToJSON    Documents
 187 instance ToSchema  Documents
 188
 189 delDocs :: CorpusId -> Documents -> Cmd err [Int]
 190 delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 191
 192 ------------------------------------------------------------------------
 193 type FavApi =  Summary " Favorites label"
 194             :> ReqBody '[JSON] Favorites
 195             :> Put     '[JSON] [Int]
 196           :<|> Summary " Favorites unlabel"
 197             :> ReqBody '[JSON] Favorites
 198             :> Delete  '[JSON] [Int]
 199
 200 data Favorites = Favorites { favorites :: [NodeId]}
 201   deriving (Generic)
 202
 203 instance FromJSON  Favorites
 204 instance ToJSON    Favorites
 205 instance ToSchema  Favorites
 206
 207 putFav :: CorpusId -> Favorites -> Cmd err [Int]
 208 putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 209
 210 delFav :: CorpusId -> Favorites -> Cmd err [Int]
 211 delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 212
 213 favApi :: CorpusId -> GargServer FavApi
 214 favApi cId = putFav cId :<|> delFav 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 :: NodeId -> GargServer GraphAPI
 249 graphAPI nId = do
 250
 251   nodeGraph <- getNode nId HyperdataGraph
 252
 253   let title = "IMT - Scientific publications - 1982-2017 - English"
 254   let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph] [ LegendField 6 "#FFF" "Data processing"
 255                                                                                    , LegendField 7 "#FFF" "Networks"
 256                                                                                    , LegendField 1 "#FFF" "Material science"
 257                                                                                    , LegendField 5 "#FFF" "Energy / Environment"
 258                                                                                    ]
 259                                        -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 260
 261   graph <- set graph_metadata (Just metadata)
 262         <$> maybe defaultGraph identity
 263         <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
 264
 265   pure graph
 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 instance HasNodeError ServantErr where
 271   _NodeError = prism' mk (const Nothing) -- $ panic "HasNodeError ServantErr: not a prism")
 272     where
 273       e = "NodeError: "
 274       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 275       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 276       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 277       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 278
 279       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 280       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 281       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 282       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 283       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 284       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 285       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 286
 287 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 288 instance HasTreeError ServantErr where
 289   _TreeError = prism' mk (const Nothing) -- $ panic "HasTreeError ServantErr: not a prism")
 290     where
 291       e = "TreeError: "
 292       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 293       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 294       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 295
 296 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 297 treeAPI :: NodeId -> GargServer TreeAPI
 298 treeAPI = treeDB
 299
 300 ------------------------------------------------------------------------
 301 -- | Check if the name is less than 255 char
 302 rename :: NodeId -> RenameNode -> Cmd err [Int]
 303 rename nId (RenameNode name) = U.update (U.Rename nId name)
 304
 305 getTable :: NodeId -> Maybe TabType
 306          -> Maybe Offset  -> Maybe Limit
 307          -> Maybe OrderBy -> Cmd err [FacetDoc]
 308 getTable cId ft o l order = case ft of
 309                                 (Just Docs)  -> runViewDocuments cId False o l order
 310                                 (Just Trash) -> runViewDocuments cId True  o l order
 311                                 _     -> panic "not implemented"
 312
 313 getPairing :: ContactId -> Maybe TabType
 314          -> Maybe Offset  -> Maybe Limit
 315          -> Maybe OrderBy -> Cmd err [FacetDoc]
 316 getPairing cId ft o l order = case ft of
 317                                 (Just Docs)  -> runViewAuthorsDoc cId False o l order
 318                                 (Just Trash) -> runViewAuthorsDoc cId True  o l order
 319                                 _     -> panic "not implemented"
 320
 321
 322 getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
 323                    -> Cmd err [FacetChart]
 324 getChart _ _ _ = undefined -- TODO
 325
 326 postNode :: NodeId -> PostNode -> Cmd err [NodeId]
 327 postNode pId (PostNode name nt) = mk nt (Just pId) name
 328
 329 putNode :: NodeId -> Cmd err Int
 330 putNode = undefined -- TODO
 331
 332 query :: Monad m => Text -> m Text
 333 query s = pure s
 334
 335
 336 -- | Upload files
 337 -- TODO Is it possible to adapt the function according to iValue input ?
 338 --upload :: MultipartData -> Handler Text
 339 --upload multipartData = do
 340 --  liftIO $ do
 341 --    putStrLn "Inputs:"
 342 --    forM_ (inputs multipartData) $ \input ->
 343 --      putStrLn $ "  " <> show (iName input)
 344 --            <> " -> " <> show (iValue input)
 345 --
 346 --    forM_ (files multipartData) $ \file -> do
 347 --      content <- readFile (fdFilePath file)
 348 --      putStrLn $ "Content of " <> show (fdFileName file)
 349 --              <> " at " <> fdFilePath file
 350 --      putStrLn content
 351 --  pure (pack "Data loaded")
 352