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