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