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-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 module Gargantext.API.Node
  25   ( module Gargantext.API.Node
  26   , HyperdataAny(..)
  27   , HyperdataAnnuaire(..)
  28   , HyperdataCorpus(..)
  29   , HyperdataResource(..)
  30   , HyperdataUser(..)
  31   , HyperdataDocument(..)
  32   , HyperdataDocumentV3(..)
  33   ) where
  34
  35 import Control.Lens (prism', set)
  36 import Control.Monad ((>>))
  37 import Control.Monad.IO.Class (liftIO)
  38 import Data.Aeson (FromJSON, ToJSON)
  39 import Data.Swagger
  40 import Data.Text (Text())
  41 import Data.Time (UTCTime)
  42 import GHC.Generics (Generic)
  43 import Gargantext.API.Metrics
  44 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, HasRepo, QueryParamR)
  45 import Gargantext.API.Ngrams.Tools
  46 import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
  47 import Gargantext.Core.Types (Offset, Limit, ListType(..), HasInvalidError)
  48 import Gargantext.Core.Types.Main (Tree, NodeTree)
  49 import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),FacetChart,runViewAuthorsDoc)
  50 import qualified Gargantext.Database.Metrics as Metrics
  51 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  52 import Gargantext.Database.Node.Children (getChildren)
  53 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  54 import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mkNodeWithParent, JSONB, NodeError(..), HasNodeError(..))
  55 import Gargantext.Database.Schema.Node (defaultList)
  56 import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
  57 import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
  58 import Gargantext.Database.Types.Node
  59 import Gargantext.Database.Types.Node (CorpusId, ContactId)
  60 import Gargantext.Database.Utils -- (Cmd, CmdM)
  61 import Gargantext.Prelude
  62 import Gargantext.API.Settings
  63 import Gargantext.Text.Metrics (Scored(..))
  64 import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
  65 import Gargantext.Viz.Graph.Tools (cooc2graph)
  66 import Servant
  67 import Test.QuickCheck (elements)
  68 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  69 import qualified Data.Map as Map
  70 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  71
  72 {-
  73 import qualified Gargantext.Text.List.Learn as Learn
  74 import qualified Data.Vector as Vec
  75 --}
  76
  77 type GargServer api =
  78   forall env err m.
  79     ( CmdM env err m
  80     , HasNodeError err
  81     , HasInvalidError err
  82     , HasTreeError err
  83     , HasRepo env
  84     , HasSettings env
  85     )
  86     => ServerT api m
  87
  88 -------------------------------------------------------------------
  89 -- TODO-ACCESS: access by admin only.
  90 --              At first let's just have an isAdmin check.
  91 --              Later: check userId CanDeleteNodes Nothing
  92 -- TODO-EVENTS: DeletedNodes [NodeId]
  93 --              {"tag": "DeletedNodes", "nodes": [Int*]}
  94 type NodesAPI  = Delete '[JSON] Int
  95
  96 -- | Delete Nodes
  97 -- Be careful: really delete nodes
  98 -- Access by admin only
  99 nodesAPI :: [NodeId] -> GargServer NodesAPI
 100 nodesAPI ids = deleteNodes ids
 101
 102 ------------------------------------------------------------------------
 103 -- | TODO-ACCESS: access by admin only.
 104 -- At first let's just have an isAdmin check.
 105 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
 106 -- To manage the Users roots
 107 -- TODO-EVENTS:
 108 --   PutNode ?
 109 -- TODO needs design discussion.
 110 type Roots =  Get    '[JSON] [NodeAny]
 111          :<|> Put    '[JSON] Int -- TODO
 112
 113 -- | TODO: access by admin only
 114 roots :: GargServer Roots
 115 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
 116    :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 117
 118 -------------------------------------------------------------------
 119 -- | Node API Types management
 120 -- TODO-ACCESS : access by users
 121 -- No ownership check is needed if we strictly follow the capability model.
 122 --
 123 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
 124 --             SearchAPI)
 125 -- CanRenameNode (or part of CanEditNode?)
 126 -- CanCreateChildren (PostNodeApi)
 127 -- CanEditNode / CanPutNode TODO not implemented yet
 128 -- CanDeleteNode
 129 -- CanPatch (TableNgramsApi)
 130 -- CanFavorite
 131 -- CanMoveToTrash
 132 type NodeAPI a = Get '[JSON] (Node a)
 133              :<|> "rename" :> RenameApi
 134              :<|> PostNodeApi -- TODO move to children POST
 135              :<|> Put    '[JSON] Int
 136              :<|> Delete '[JSON] Int
 137              :<|> "children"  :> ChildrenApi a
 138
 139              -- TODO gather it
 140              :<|> "table"     :> TableApi
 141              :<|> "list"      :> TableNgramsApi
 142              :<|> "listGet"   :> TableNgramsApiGet
 143              :<|> "pairing"   :> PairingApi
 144
 145              :<|> "chart"     :> ChartApi
 146              :<|> "favorites" :> FavApi
 147              :<|> "documents" :> DocsApi
 148              :<|> "search":> Summary "Node Search"
 149                         :> ReqBody '[JSON] SearchInQuery
 150                         :> QueryParam "offset" Int
 151                         :> QueryParam "limit"  Int
 152                         :> QueryParam "order"  OrderBy
 153                         :> SearchAPI
 154             :<|> "metrics" :> MetricsAPI
 155
 156 -- TODO-ACCESS: check userId CanRenameNode nodeId
 157 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 158 type RenameApi = Summary " Rename Node"
 159                :> ReqBody '[JSON] RenameNode
 160                :> Put     '[JSON] [Int]
 161
 162 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 163                  :> ReqBody '[JSON] PostNode
 164                  :> Post    '[JSON] [NodeId]
 165
 166 type ChildrenApi a = Summary " Summary children"
 167                  :> QueryParam "type"   NodeType
 168                  :> QueryParam "offset" Int
 169                  :> QueryParam "limit"  Int
 170                  :> Get '[JSON] [Node a]
 171 ------------------------------------------------------------------------
 172 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 173 nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 174 nodeAPI p uId id
 175              =  getNode     id p
 176            :<|> rename      id
 177            :<|> postNode    uId id
 178            :<|> putNode     id
 179            :<|> deleteNode  id
 180            :<|> getChildren id p
 181
 182            -- TODO gather it
 183            :<|> getTable         id
 184            :<|> tableNgramsPatch id
 185            :<|> getTableNgrams   id
 186            :<|> getPairing       id
 187
 188            :<|> getChart id
 189            :<|> favApi   id
 190            :<|> delDocs  id
 191            :<|> searchIn id
 192            :<|> getMetrics id
 193            -- Annuaire
 194            -- :<|> upload
 195            -- :<|> query
 196
 197 ------------------------------------------------------------------------
 198 data RenameNode = RenameNode { r_name :: Text }
 199   deriving (Generic)
 200
 201 instance FromJSON  RenameNode
 202 instance ToJSON    RenameNode
 203 instance ToSchema  RenameNode
 204 instance Arbitrary RenameNode where
 205   arbitrary = elements [RenameNode "test"]
 206 ------------------------------------------------------------------------
 207 data PostNode = PostNode { pn_name :: Text
 208                          , pn_typename :: NodeType}
 209   deriving (Generic)
 210
 211 instance FromJSON  PostNode
 212 instance ToJSON    PostNode
 213 instance ToSchema  PostNode
 214 instance Arbitrary PostNode where
 215   arbitrary = elements [PostNode "Node test" NodeCorpus]
 216
 217 ------------------------------------------------------------------------
 218 type DocsApi = Summary "Docs : Move to trash"
 219              :> ReqBody '[JSON] Documents
 220              :> Delete  '[JSON] [Int]
 221
 222 data Documents = Documents { documents :: [NodeId]}
 223   deriving (Generic)
 224
 225 instance FromJSON  Documents
 226 instance ToJSON    Documents
 227 instance ToSchema  Documents
 228
 229 delDocs :: CorpusId -> Documents -> Cmd err [Int]
 230 delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 231
 232 ------------------------------------------------------------------------
 233 type FavApi =  Summary " Favorites label"
 234             :> ReqBody '[JSON] Favorites
 235             :> Put     '[JSON] [Int]
 236           :<|> Summary " Favorites unlabel"
 237             :> ReqBody '[JSON] Favorites
 238             :> Delete  '[JSON] [Int]
 239
 240 data Favorites = Favorites { favorites :: [NodeId]}
 241   deriving (Generic)
 242
 243 instance FromJSON  Favorites
 244 instance ToJSON    Favorites
 245 instance ToSchema  Favorites
 246
 247 putFav :: CorpusId -> Favorites -> Cmd err [Int]
 248 putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 249
 250 delFav :: CorpusId -> Favorites -> Cmd err [Int]
 251 delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 252
 253 favApi :: CorpusId -> GargServer FavApi
 254 favApi cId = putFav cId :<|> delFav cId
 255
 256 ------------------------------------------------------------------------
 257 type TableApi = Summary " Table API"
 258               :> QueryParam "view"   TabType
 259               :> QueryParam "offset" Int
 260               :> QueryParam "limit"  Int
 261               :> QueryParam "order"  OrderBy
 262               :> Get '[JSON] [FacetDoc]
 263
 264 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 265 type PairingApi = Summary " Pairing API"
 266               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 267               :> QueryParam "offset" Int
 268               :> QueryParam "limit"  Int
 269               :> QueryParam "order"  OrderBy
 270               :> Get '[JSON] [FacetDoc]
 271
 272 ------------------------------------------------------------------------
 273 type ChartApi = Summary " Chart API"
 274               :> QueryParam "from" UTCTime
 275               :> QueryParam "to"   UTCTime
 276               :> Get '[JSON] [FacetChart]
 277
 278                 -- Depending on the Type of the Node, we could post
 279                 -- New documents for a corpus
 280                 -- New map list terms
 281              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 282
 283                 -- To launch a query and update the corpus
 284              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 285
 286 ------------------------------------------------------------------------
 287 -- TODO-ACCESS: CanGetNode
 288 -- TODO-EVENTS: No events as this is a read only query.
 289 type GraphAPI   = Get '[JSON] Graph
 290
 291 graphAPI :: NodeId -> GargServer GraphAPI
 292 graphAPI nId = do
 293   nodeGraph <- getNode nId HyperdataGraph
 294
 295   let metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph]
 296                                      [ LegendField 1 "#FFF" "Cluster"
 297                                      , LegendField 2 "#FFF" "Cluster"
 298                                      ]
 299                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 300   let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
 301
 302   lId <- defaultList cId
 303   ngs    <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] NgramsTerms
 304
 305   myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal False)
 306                             <$> groupNodesByNgrams ngs
 307                             <$> getNodesByNgramsOnlyUser cId NgramsTerms (Map.keys ngs)
 308
 309   liftIO $ set graph_metadata (Just metadata) <$> cooc2graph myCooc
 310
 311
 312 instance HasNodeError ServantErr where
 313   _NodeError = prism' mk (const Nothing) -- $ panic "HasNodeError ServantErr: not a prism")
 314     where
 315       e = "Gargantext NodeError: "
 316       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 317       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 318       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 319       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 320
 321       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 322       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 323       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 324       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 325       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 326       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 327       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 328
 329 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 330 instance HasTreeError ServantErr where
 331   _TreeError = prism' mk (const Nothing) -- $ panic "HasTreeError ServantErr: not a prism")
 332     where
 333       e = "TreeError: "
 334       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 335       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 336       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 337
 338 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 339 -- TODO-ACCESS: CanTree or CanGetNode
 340 -- TODO-EVENTS: No events as this is a read only query.
 341 treeAPI :: NodeId -> GargServer TreeAPI
 342 treeAPI = treeDB
 343
 344 ------------------------------------------------------------------------
 345 -- | Check if the name is less than 255 char
 346 rename :: NodeId -> RenameNode -> Cmd err [Int]
 347 rename nId (RenameNode name') = U.update (U.Rename nId name')
 348
 349 getTable :: NodeId -> Maybe TabType
 350          -> Maybe Offset  -> Maybe Limit
 351          -> Maybe OrderBy -> Cmd err [FacetDoc]
 352 getTable cId ft o l order =
 353   case ft of
 354     (Just Docs)  -> runViewDocuments cId False o l order
 355     (Just Trash) -> runViewDocuments cId True  o l order
 356     _     -> panic "not implemented"
 357
 358 getPairing :: ContactId -> Maybe TabType
 359          -> Maybe Offset  -> Maybe Limit
 360          -> Maybe OrderBy -> Cmd err [FacetDoc]
 361 getPairing cId ft o l order =
 362   case ft of
 363     (Just Docs)  -> runViewAuthorsDoc cId False o l order
 364     (Just Trash) -> runViewAuthorsDoc cId True  o l order
 365     _     -> panic "not implemented"
 366
 367
 368 getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
 369                    -> Cmd err [FacetChart]
 370 getChart _ _ _ = undefined -- TODO
 371
 372 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 373 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 374
 375 putNode :: NodeId -> Cmd err Int
 376 putNode = undefined -- TODO
 377
 378 query :: Monad m => Text -> m Text
 379 query s = pure s
 380
 381
 382 -- | Upload files
 383 -- TODO Is it possible to adapt the function according to iValue input ?
 384 --upload :: MultipartData -> Handler Text
 385 --upload multipartData = do
 386 --  liftIO $ do
 387 --    putStrLn "Inputs:"
 388 --    forM_ (inputs multipartData) $ \input ->
 389 --      putStrLn $ "  " <> show (iName input)
 390 --            <> " -> " <> show (iValue input)
 391 --
 392 --    forM_ (files multipartData) $ \file -> do
 393 --      content <- readFile (fdFilePath file)
 394 --      putStrLn $ "Content of " <> show (fdFileName file)
 395 --              <> " at " <> fdFilePath file
 396 --      putStrLn content
 397 --  pure (pack "Data loaded")
 398
 399 -------------------------------------------------------------------------------
 400
 401 type MetricsAPI = Summary "SepGen IncExc metrics"
 402                 :> QueryParam  "list"       ListId
 403                 :> QueryParamR "ngramsType" TabType
 404                 :> QueryParam  "limit"      Int
 405                 :> Get '[JSON] Metrics
 406
 407 getMetrics :: NodeId -> GargServer MetricsAPI
 408 getMetrics cId maybeListId tabType maybeLimit = do
 409   (ngs', scores) <- Metrics.getMetrics' cId maybeListId tabType maybeLimit
 410
 411   let
 412     metrics      = map (\(Scored t s1 s2) -> Metric t s1 s2 (listType t ngs')) scores
 413     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 414     errorMsg     = "API.Node.metrics: key absent"
 415
 416   pure $ Metrics metrics
 417
 418
 419
 420