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