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