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 getGraph :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
  66 getGraph u n = do
  67   newGraph  <- liftIO newEmptyMVar
  68   g  <- getGraph u n
  69   _  <- liftIO $ forkIO $ putMVar newGraph g
  70   g' <- liftIO $ takeMVar newGraph
  71   pure g'
  72
  73 getGraph' :: UserId -> NodeId -> GargNoServer Graph
  74 getGraph' uId nId = do
  75   nodeGraph <- getNodeWith nId HyperdataGraph
  76   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
  77   let listVersion = graph ^? _Just
  78                             . graph_metadata
  79                             . _Just
  80                             . gm_list
  81                             . lfg_version
  82
  83   repo <- getRepo
  84   let v = repo ^. r_version
  85   nodeUser <- getNodeUser (NodeId uId)
  86
  87   let uId' = nodeUser ^. node_userId
  88
  89   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
  90                   identity
  91                   $ nodeGraph ^. node_parentId
  92
  93   g <- case graph of
  94     Nothing     -> do
  95       graph' <- computeGraph cId NgramsTerms repo
  96       _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
  97       pure graph'
  98
  99     Just graph' -> if listVersion == Just v
 100                      then pure graph'
 101                      else do
 102                        graph'' <- computeGraph cId NgramsTerms repo
 103                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
 104                        pure graph''
 105   pure {- $ trace (show g) $ -} g
 106
 107
 108 -- TODO use Database Monad only here ?
 109 computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
 110 computeGraph cId nt repo = do
 111   lId  <- defaultList cId
 112
 113   let metadata = GraphMetadata "Title" [cId]
 114                                      [ LegendField 1 "#FFF" "Cluster"
 115                                      , LegendField 2 "#FFF" "Cluster"
 116                                      ]
 117                                 (ListForGraph lId (repo ^. r_version))
 118                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 119
 120   lIds <- selectNodesWithUsername NodeList userMaster
 121   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 122
 123   myCooc <- Map.filter (>1)
 124          <$> getCoocByNgrams (Diagonal True)
 125          <$> groupNodesByNgrams ngs
 126          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 127
 128   graph <- liftIO $ cooc2graph 0 myCooc
 129   let graph' = set graph_metadata (Just metadata) graph
 130   pure graph'
 131
 132
 133
 134 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
 135 postGraph = undefined
 136
 137 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 138 putGraph = undefined
 139