src/Gargantext/Viz/Graph/API.hs

   1 {-|
   2 Module      : Gargantext.Viz.Phylo.Tools
   3 Description : Phylomemy Tools to build/manage it
   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 FlexibleContexts  #-}
  16 {-# LANGUAGE FlexibleInstances #-}
  17 {-# LANGUAGE RankNTypes        #-}
  18 {-# LANGUAGE NoImplicitPrelude #-}
  19 {-# LANGUAGE OverloadedStrings #-}   -- allows to write Text literals
  20 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  21 {-# LANGUAGE DataKinds         #-}
  22 {-# LANGUAGE TypeOperators     #-}
  23
  24 module Gargantext.Viz.Graph.API
  25   where
  26
  27 import Debug.Trace (trace)
  28 import Control.Concurrent -- (forkIO)
  29 import Control.Lens (set, (^.), _Just, (^?))
  30 import Control.Monad.IO.Class (liftIO)
  31 import Data.Maybe (Maybe(..))
  32 import Gargantext.API.Ngrams (NgramsRepo, r_version)
  33 import Gargantext.API.Ngrams.Tools
  34 import Gargantext.API.Types
  35 import Gargantext.Core.Types.Main
  36 import Gargantext.Database.Config
  37 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  38 import Gargantext.Database.Schema.Ngrams
  39 import Gargantext.Database.Node.Select
  40 import Gargantext.Database.Schema.Node (getNodeWith, getNodeUser, defaultList, insertGraph, HasNodeError)
  41 import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
  42 import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
  43 import Gargantext.Database.Utils (Cmd)
  44 import Gargantext.Prelude
  45 import Gargantext.Viz.Graph
  46 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
  47 import Servant
  48
  49 import Gargantext.API.Orchestrator.Types
  50 import Servant.Job.Types
  51 import Servant.Job.Async
  52 import qualified Data.Map as Map
  53
  54 ------------------------------------------------------------------------
  55
  56 -- | There is no Delete specific API for Graph since it can be deleted
  57 -- as simple Node.
  58 type GraphAPI   =  Get  '[JSON] Graph
  59               :<|> Post '[JSON] [GraphId]
  60               :<|> Put  '[JSON] Int
  61               :<|> GraphAsync
  62
  63
  64 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  65 graphAPI u n =  getGraph  u n
  66          :<|> postGraph n
  67          :<|> putGraph  n
  68          :<|> graphAsync u n
  69
  70 ------------------------------------------------------------------------
  71
  72 {- Model to fork Graph Computation
  73 -- This is not really optimized since it increases the need RAM
  74 -- and freezes the whole system
  75 -- This is mainly for documentation (see a better solution in the function below)
  76 -- Each process has to be tailored
  77 getGraph' :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
  78 getGraph' u n = do
  79   newGraph  <- liftIO newEmptyMVar
  80   g  <- getGraph u n
  81   _  <- liftIO $ forkIO $ putMVar newGraph g
  82   g' <- liftIO $ takeMVar newGraph
  83   pure g'
  84 -}
  85 getGraph :: UserId -> NodeId -> GargNoServer Graph
  86 getGraph uId nId = do
  87   nodeGraph <- getNodeWith nId HyperdataGraph
  88   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
  89   let listVersion = graph ^? _Just
  90                             . graph_metadata
  91                             . _Just
  92                             . gm_list
  93                             . lfg_version
  94
  95   repo <- getRepo
  96   let v = repo ^. r_version
  97   nodeUser <- getNodeUser (NodeId uId)
  98
  99   let uId' = nodeUser ^. node_userId
 100
 101   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
 102                   identity
 103                   $ nodeGraph ^. node_parentId
 104
 105   g <- case graph of
 106     Nothing     -> do
 107       graph' <- computeGraph cId NgramsTerms repo
 108       _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
 109       pure graph'
 110
 111     Just graph' -> if listVersion == Just v
 112                      then pure graph'
 113                      else do
 114                        graph'' <- computeGraph cId NgramsTerms repo
 115                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 116                        pure graph''
 117
 118   newGraph  <- liftIO newEmptyMVar
 119   _  <- liftIO $ forkIO $ putMVar newGraph g
 120   g' <- liftIO $ takeMVar newGraph
 121   pure {- $ trace (show g) $ -} g'
 122
 123
 124 -- TODO use Database Monad only here ?
 125 computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
 126 computeGraph cId nt repo = do
 127   lId  <- defaultList cId
 128
 129   let metadata = GraphMetadata "Title" [cId]
 130                                      [ LegendField 1 "#FFF" "Cluster"
 131                                      , LegendField 2 "#FFF" "Cluster"
 132                                      ]
 133                                 (ListForGraph lId (repo ^. r_version))
 134                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 135
 136   lIds <- selectNodesWithUsername NodeList userMaster
 137   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 138
 139   myCooc <- inMVarIO $ Map.filter (>1)
 140          <$> getCoocByNgrams (Diagonal False)
 141          <$> groupNodesByNgrams ngs
 142          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 143
 144   graph <- liftIO $ inMVar $ cooc2graph 0 myCooc
 145   let graph' = set graph_metadata (Just metadata) graph
 146   pure graph'
 147
 148
 149
 150 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
 151 postGraph = undefined
 152
 153 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 154 putGraph = undefined
 155
 156 ------------------------------------------------------------
 157
 158 type GraphAsync = Summary "Update graph"
 159                 :> "async"
 160                 :> AsyncJobsAPI ScraperStatus () ScraperStatus
 161
 162 graphAsync :: UserId -> NodeId -> GargServer GraphAsync
 163 graphAsync u n =
 164   serveJobsAPI $
 165     JobFunction (\_ log' -> graphAsync' u n (liftIO . log'))
 166
 167
 168 graphAsync' :: UserId
 169            -> NodeId
 170            -> (ScraperStatus -> GargNoServer ())
 171            -> GargNoServer ScraperStatus
 172 graphAsync' u n logStatus = do
 173   logStatus ScraperStatus { _scst_succeeded = Just 1
 174                           , _scst_failed    = Just 0
 175                           , _scst_remaining = Just 1
 176                           , _scst_events    = Just []
 177                           }
 178   _g <- trace (show u) $ getGraph u n
 179   pure  ScraperStatus { _scst_succeeded = Just 1
 180                           , _scst_failed    = Just 0
 181                           , _scst_remaining = Just 1
 182                           , _scst_events    = Just []
 183                           }