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 RankNTypes         #-}
  16 {-# LANGUAGE NoImplicitPrelude #-}
  17 {-# LANGUAGE OverloadedStrings #-}   -- allows to write Text literals
  18 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  19 {-# LANGUAGE DataKinds            #-}
  20 {-# LANGUAGE TypeOperators      #-}
  21
  22 module Gargantext.Viz.Graph.API
  23   where
  24
  25 import Data.List (sortOn)
  26 import Control.Lens (set, over)
  27 import Control.Monad.IO.Class (liftIO)
  28 import Gargantext.API.Ngrams.Tools
  29 import Gargantext.API.Types
  30 import Gargantext.Core.Types.Main
  31 import Gargantext.Database.Config
  32 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  33 import Gargantext.Database.Schema.Ngrams
  34 import Gargantext.Database.Node.Select
  35 import Gargantext.Database.Schema.Node (getNode)
  36 import Gargantext.Database.Schema.Node (defaultList)
  37 import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
  38 import Gargantext.Prelude
  39 import Gargantext.Viz.Graph
  40 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
  41 import Servant
  42 import qualified Data.Map as Map
  43
  44 ------------------------------------------------------------------------
  45
  46 -- | There is no Delete specific API for Graph since it can be deleted
  47 -- as simple Node.
  48 type GraphAPI   =  Get  '[JSON] Graph
  49               :<|> Post '[JSON] [GraphId]
  50               :<|> Put  '[JSON] Int
  51
  52
  53 graphAPI :: NodeId -> GargServer GraphAPI
  54 graphAPI n =  getGraph  n
  55          :<|> postGraph n
  56          :<|> putGraph  n
  57
  58 ------------------------------------------------------------------------
  59
  60 getGraph :: NodeId -> GargServer (Get '[JSON] Graph)
  61 getGraph nId = do
  62   nodeGraph <- getNode nId HyperdataGraph
  63
  64   let metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph]
  65                                      [ LegendField 1 "#FFF" "Cluster"
  66                                      , LegendField 2 "#FFF" "Cluster"
  67                                      ]
  68                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
  69   let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
  70
  71   lIds <- selectNodesWithUsername NodeList userMaster
  72   lId  <- defaultList cId
  73   ngs  <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] NgramsTerms
  74
  75   myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal False)
  76                             <$> groupNodesByNgrams ngs
  77                             <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) NgramsTerms (Map.keys ngs)
  78
  79   graph <- liftIO $ cooc2graph myCooc
  80   pure $ set graph_metadata (Just metadata)
  81        $ over graph_nodes (sortOn node_id) graph
  82
  83
  84 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
  85 postGraph = undefined
  86
  87 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
  88 putGraph = undefined
  89
  90
  91
  92
  93 -- | Instances
  94