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