src/Gargantext/Viz/Graph/API.hs

   1 {-|
   2 Module      : Gargantext.Viz.Graph
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12
  13 {-# OPTIONS_GHC -fno-warn-orphans #-}
  14
  15 {-# LANGUAGE DataKinds         #-}
  16 {-# LANGUAGE DeriveGeneric     #-}
  17 {-# LANGUAGE FlexibleContexts  #-}
  18 {-# LANGUAGE FlexibleInstances #-}
  19 {-# LANGUAGE NoImplicitPrelude #-}
  20 {-# LANGUAGE OverloadedStrings #-}   -- allows to write Text literals
  21 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  22 {-# LANGUAGE RankNTypes        #-}
  23 {-# LANGUAGE TypeOperators     #-}
  24
  25 module Gargantext.Viz.Graph.API
  26   where
  27
  28 import Control.Lens (set, (^.), _Just, (^?))
  29 import Data.Aeson
  30 import Debug.Trace (trace)
  31 import qualified Data.Map as Map
  32 import Data.Maybe (Maybe(..))
  33 import Data.Swagger
  34 import Data.Text
  35 import GHC.Generics (Generic)
  36 import Servant
  37 import Servant.XML
  38 import Servant.Job.Async
  39 import Gargantext.API.Ngrams (NgramsRepo, r_version)
  40 import Gargantext.API.Ngrams.Tools
  41 import Gargantext.API.Admin.Orchestrator.Types
  42 import Gargantext.API.Prelude
  43 import Gargantext.Core.Types.Main
  44 import Gargantext.Database.Admin.Config
  45 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  46 import Gargantext.Database.Schema.Node (node_userId, node_parentId, node_hyperdata)
  47 import Gargantext.Database.Schema.Ngrams
  48 import Gargantext.Database.Query.Table.Node.Select
  49 import Gargantext.Database.Query.Table.Node
  50 import Gargantext.Database.Query.Table.Node.User
  51 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  52 import Gargantext.Database.Admin.Types.Node
  53 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  54 import Gargantext.Database.Prelude (Cmd)
  55 import Gargantext.Prelude
  56 import Gargantext.Viz.Graph
  57 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
  58 import Gargantext.Viz.Graph.GEXF ()
  59
  60 ------------------------------------------------------------------------
  61 -- | There is no Delete specific API for Graph since it can be deleted
  62 -- as simple Node.
  63 type GraphAPI   =  Get  '[JSON] Graph
  64               :<|> Post '[JSON] [GraphId]
  65               :<|> Put  '[JSON] Int
  66               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  67               :<|> GraphAsyncAPI
  68               :<|> "versions" :> GraphVersionsAPI
  69
  70
  71 data GraphVersions =
  72   GraphVersions { gv_graph :: Maybe Int
  73                 , gv_repo :: Int }
  74    deriving (Show, Generic)
  75
  76 instance ToJSON GraphVersions
  77 instance ToSchema GraphVersions
  78
  79 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  80 graphAPI u n =  getGraph       u n
  81          :<|> postGraph          n
  82          :<|> putGraph           n
  83          :<|> getGraphGexf     u n
  84          :<|> graphAsync       u n
  85          :<|> graphVersionsAPI u n
  86
  87 ------------------------------------------------------------------------
  88
  89 getGraph :: UserId -> NodeId -> GargNoServer Graph
  90 getGraph uId nId = do
  91   nodeGraph <- getNodeWith nId HyperdataGraph
  92   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
  93   -- let listVersion = graph ^? _Just
  94   --                           . graph_metadata
  95   --                           . _Just
  96   --                           . gm_list
  97   --                           . lfg_version
  98
  99   repo <- getRepo
 100   -- let v = repo ^. r_version
 101   nodeUser <- getNodeUser (NodeId uId)
 102
 103   let uId' = nodeUser ^. node_userId
 104
 105   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
 106                   identity
 107                   $ nodeGraph ^. node_parentId
 108
 109   g <- case graph of
 110     Nothing     -> do
 111         graph' <- computeGraph cId NgramsTerms repo
 112         _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
 113         pure $ trace "Graph empty, computing" $ graph'
 114
 115     Just graph' -> pure $ trace "Graph exists, returning" $ graph'
 116
 117     -- Just graph' -> if listVersion == Just v
 118     --                  then pure graph'
 119     --                  else do
 120     --                    graph'' <- computeGraph cId NgramsTerms repo
 121     --                    _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 122     --                    pure graph''
 123
 124   pure g
 125
 126
 127 recomputeGraph :: UserId -> NodeId -> GargNoServer Graph
 128 recomputeGraph uId nId = do
 129   nodeGraph <- getNodeWith nId HyperdataGraph
 130   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 131   let listVersion = graph ^? _Just
 132                             . graph_metadata
 133                             . _Just
 134                             . gm_list
 135                             . lfg_version
 136
 137   repo <- getRepo
 138   let v = repo ^. r_version
 139   nodeUser <- getNodeUser (NodeId uId)
 140
 141   let uId' = nodeUser ^. node_userId
 142
 143   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
 144                   identity
 145                   $ nodeGraph ^. node_parentId
 146
 147   g <- case graph of
 148     Nothing     -> do
 149       graph' <- computeGraph cId NgramsTerms repo
 150       _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
 151       pure $ trace "[recomputeGraph] Graph empty, computing" $ graph'
 152
 153     Just graph' -> if listVersion == Just v
 154                      then pure graph'
 155                      else do
 156                        graph'' <- computeGraph cId NgramsTerms repo
 157                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 158                        pure $ trace "[recomputeGraph] Graph exists, recomputing" $ graph''
 159   pure g
 160
 161
 162 -- TODO use Database Monad only here ?
 163 computeGraph :: HasNodeError err
 164              => CorpusId
 165              -> NgramsType
 166              -> NgramsRepo
 167              -> Cmd err Graph
 168 computeGraph cId nt repo = do
 169   lId  <- defaultList cId
 170
 171   let metadata = GraphMetadata "Title" [cId]
 172                                      [ LegendField 1 "#FFF" "Cluster"
 173                                      , LegendField 2 "#FFF" "Cluster"
 174                                      ]
 175                                 (ListForGraph lId (repo ^. r_version))
 176                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 177
 178   lIds <- selectNodesWithUsername NodeList userMaster
 179   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 180
 181   myCooc <- Map.filter (>1)
 182          <$> getCoocByNgrams (Diagonal True)
 183          <$> groupNodesByNgrams ngs
 184          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 185
 186   graph <- liftBase $ cooc2graph 0 myCooc
 187   let graph' = set graph_metadata (Just metadata) graph
 188   pure graph'
 189
 190
 191
 192 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
 193 postGraph = undefined
 194
 195 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 196 putGraph = undefined
 197
 198
 199 ------------------------------------------------------------
 200
 201 getGraphGexf :: UserId -> NodeId -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 202 getGraphGexf uId nId = do
 203   graph <- getGraph uId nId
 204   pure $ addHeader (concat [ "attachment; filename=graph.gexf" ]) graph
 205
 206 ------------------------------------------------------------
 207
 208 type GraphAsyncAPI = Summary "Update graph"
 209                    :> "async"
 210                    :> AsyncJobsAPI ScraperStatus () ScraperStatus
 211
 212 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 213 graphAsync u n =
 214   serveJobsAPI $
 215     JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
 216
 217
 218 graphAsync' :: UserId
 219            -> NodeId
 220            -> (ScraperStatus -> GargNoServer ())
 221            -> GargNoServer ScraperStatus
 222 graphAsync' u n logStatus = do
 223   logStatus ScraperStatus { _scst_succeeded = Just 0
 224                           , _scst_failed    = Just 0
 225                           , _scst_remaining = Just 1
 226                           , _scst_events    = Just []
 227                           }
 228   _g <- trace (show u) $ recomputeGraph u n
 229   pure  ScraperStatus { _scst_succeeded = Just 1
 230                       , _scst_failed    = Just 0
 231                       , _scst_remaining = Just 0
 232                       , _scst_events    = Just []
 233                       }
 234
 235 ------------------------------------------------------------
 236
 237 type GraphVersionsAPI = Summary "Graph versions"
 238                         :> Get '[JSON] GraphVersions
 239                    :<|> Summary "Recompute graph version"
 240                         :> Post '[JSON] Graph
 241
 242 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 243 graphVersionsAPI u n =
 244            graphVersions u n
 245       :<|> recomputeVersions u n
 246
 247 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
 248 graphVersions _uId nId = do
 249   nodeGraph <- getNodeWith nId HyperdataGraph
 250   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 251   let listVersion = graph ^? _Just
 252                             . graph_metadata
 253                             . _Just
 254                             . gm_list
 255                             . lfg_version
 256
 257   repo <- getRepo
 258   let v = repo ^. r_version
 259
 260   pure $ GraphVersions { gv_graph = listVersion
 261                        , gv_repo = v }
 262
 263 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 264 recomputeVersions uId nId = recomputeGraph uId nId