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 import qualified Data.Map as Map
  49
  50 ------------------------------------------------------------------------
  51
  52 -- | There is no Delete specific API for Graph since it can be deleted
  53 -- as simple Node.
  54 type GraphAPI   =  Get  '[JSON] Graph
  55               :<|> Post '[JSON] [GraphId]
  56               :<|> Put  '[JSON] Int
  57
  58
  59 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  60 graphAPI u n =  getGraph  u n
  61          :<|> postGraph n
  62          :<|> putGraph  n
  63
  64 ------------------------------------------------------------------------
  65
  66 {- Model to fork Graph Computation
  67 -- This is not really optimized since it increases the need RAM
  68 -- and freezes the whole system
  69 -- This is mainly for documentation (see a better solution in the function below)
  70 -- Each process has to be tailored
  71 getGraph' :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
  72 getGraph' u n = do
  73   newGraph  <- liftIO newEmptyMVar
  74   g  <- getGraph u n
  75   _  <- liftIO $ forkIO $ putMVar newGraph g
  76   g' <- liftIO $ takeMVar newGraph
  77   pure g'
  78 -}
  79 getGraph :: UserId -> NodeId -> GargNoServer Graph
  80 getGraph uId nId = do
  81   nodeGraph <- getNodeWith nId HyperdataGraph
  82   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
  83   let listVersion = graph ^? _Just
  84                             . graph_metadata
  85                             . _Just
  86                             . gm_list
  87                             . lfg_version
  88
  89   repo <- getRepo
  90   let v = repo ^. r_version
  91   nodeUser <- getNodeUser (NodeId uId)
  92
  93   let uId' = nodeUser ^. node_userId
  94
  95   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
  96                   identity
  97                   $ nodeGraph ^. node_parentId
  98
  99   newGraph  <- liftIO newEmptyMVar
 100   g <- case graph of
 101     Nothing     -> do
 102       graph' <- computeGraph cId NgramsTerms repo
 103       _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
 104       pure graph'
 105
 106     Just graph' -> if listVersion == Just v
 107                      then pure graph'
 108                      else do
 109                        graph'' <- computeGraph cId NgramsTerms repo
 110                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 111                        pure graph''
 112   _  <- liftIO $ forkIO $ putMVar newGraph g
 113   g' <- liftIO $ takeMVar newGraph
 114   pure {- $ trace (show g) $ -} g'
 115
 116
 117 -- TODO use Database Monad only here ?
 118 computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
 119 computeGraph cId nt repo = do
 120   lId  <- defaultList cId
 121
 122   let metadata = GraphMetadata "Title" [cId]
 123                                      [ LegendField 1 "#FFF" "Cluster"
 124                                      , LegendField 2 "#FFF" "Cluster"
 125                                      ]
 126                                 (ListForGraph lId (repo ^. r_version))
 127                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 128
 129   lIds <- selectNodesWithUsername NodeList userMaster
 130   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 131
 132   myCooc <- Map.filter (>1)
 133          <$> getCoocByNgrams (Diagonal True)
 134          <$> groupNodesByNgrams ngs
 135          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 136
 137   graph <- liftIO $ cooc2graph 0 myCooc
 138   let graph' = set graph_metadata (Just metadata) graph
 139   pure graph'
 140
 141
 142
 143 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
 144 postGraph = undefined
 145
 146 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 147 putGraph = undefined
 148