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 Control.Lens (set, (^.), _Just, (^?))
  28 import Control.Monad.IO.Class (liftIO)
  29 import Data.Maybe (Maybe(..))
  30 import Gargantext.API.Ngrams (currentVersion)
  31 import Gargantext.API.Ngrams.Tools
  32 import Gargantext.API.Types
  33 import Gargantext.Core.Types.Main
  34 import Gargantext.Database.Config
  35 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  36 import Gargantext.Database.Schema.Ngrams
  37 import Gargantext.Database.Node.Select
  38 import Gargantext.Database.Schema.Node (getNode, defaultList, insertGraph)
  39 import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
  40 import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
  41 import Gargantext.Prelude
  42 import Gargantext.Viz.Graph
  43 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
  44 import Servant
  45 import qualified Data.Map as Map
  46
  47 ------------------------------------------------------------------------
  48
  49 -- | There is no Delete specific API for Graph since it can be deleted
  50 -- as simple Node.
  51 type GraphAPI   =  Get  '[JSON] Graph
  52               :<|> Post '[JSON] [GraphId]
  53               :<|> Put  '[JSON] Int
  54
  55
  56 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  57 graphAPI u n =  getGraph  u n
  58          :<|> postGraph n
  59          :<|> putGraph  n
  60
  61 ------------------------------------------------------------------------
  62
  63 getGraph :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
  64 getGraph uId nId = do
  65   nodeGraph <- getNode nId HyperdataGraph
  66   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
  67   let graphVersion = graph ^? _Just
  68                             . graph_metadata
  69                             . _Just
  70                             . gm_version
  71
  72   v <- currentVersion
  73   nodeUser <- getNode (NodeId uId) HyperdataUser
  74
  75   let uId' = nodeUser ^. node_userId
  76
  77   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
  78                   identity
  79                   $ nodeGraph ^. node_parentId
  80   case graph of
  81     Nothing     -> do
  82       graph' <- computeGraph cId NgramsTerms v
  83       _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
  84       pure graph'
  85
  86     Just graph' -> if graphVersion == Just v
  87                      then pure graph'
  88                      else do
  89                        graph'' <- computeGraph cId NgramsTerms v
  90                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
  91                        pure graph''
  92
  93 -- TODO use Database Monad only here ?
  94 computeGraph :: CorpusId -> NgramsType -> Int -> GargServer (Get '[JSON] Graph)
  95 computeGraph cId nt v = do
  96   lId  <- defaultList cId
  97
  98   let metadata = GraphMetadata "Title" [cId]
  99                                      [ LegendField 1 "#FFF" "Cluster"
 100                                      , LegendField 2 "#FFF" "Cluster"
 101                                      ]
 102                                 lId
 103                                 v
 104                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 105
 106   lIds <- selectNodesWithUsername NodeList userMaster
 107   ngs  <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] nt
 108
 109   myCooc <- Map.filter (>1)
 110          <$> getCoocByNgrams (Diagonal True)
 111          <$> groupNodesByNgrams ngs
 112          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 113
 114   graph <- liftIO $ cooc2graph 0 myCooc
 115   let graph' = set graph_metadata (Just metadata) graph
 116   pure graph'
 117
 118
 119
 120 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
 121 postGraph = undefined
 122
 123 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 124 putGraph = undefined
 125