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