src/Gargantext/Core/Viz/Graph/API.hs

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