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