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