{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} -- allows to write Text literals
{-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
module Gargantext.Viz.Graph.API
where
-import Control.Lens (set)
+import Debug.Trace (trace)
+import Control.Lens (set, (^.), _Just, (^?))
import Control.Monad.IO.Class (liftIO)
+import Data.Maybe (Maybe(..))
+import Gargantext.API.Ngrams (NgramsRepo, r_version)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Types
import Gargantext.Core.Types.Main
+import Gargantext.Database.Config
import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
import Gargantext.Database.Schema.Ngrams
-import Gargantext.Database.Schema.Node ( getNode)
-import Gargantext.Database.Schema.Node (defaultList)
-import Gargantext.Database.Types.Node -- (GraphId, ListId, CorpusId, NodeId)
+import Gargantext.Database.Node.Select
+import Gargantext.Database.Schema.Node (getNodeWith, defaultList, insertGraph, HasNodeError)
+import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
+import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Utils (Cmd)
import Gargantext.Prelude
import Gargantext.Viz.Graph
import Gargantext.Viz.Graph.Tools -- (cooc2graph)
:<|> Put '[JSON] Int
-graphAPI :: NodeId -> GargServer GraphAPI
-graphAPI n = getGraph n
+graphAPI :: UserId -> NodeId -> GargServer GraphAPI
+graphAPI u n = getGraph u n
:<|> postGraph n
:<|> putGraph n
------------------------------------------------------------------------
-getGraph :: NodeId -> GargServer (Get '[JSON] Graph)
-getGraph nId = do
- nodeGraph <- getNode nId HyperdataGraph
-
- let metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph]
+getGraph :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
+getGraph uId nId = do
+ nodeGraph <- getNodeWith nId HyperdataGraph
+ let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+ let listVersion = graph ^? _Just
+ . graph_metadata
+ . _Just
+ . gm_list
+ . lfg_version
+
+ repo <- getRepo
+ let v = repo ^. r_version
+ nodeUser <- getNodeWith (NodeId uId) HyperdataUser
+
+ let uId' = nodeUser ^. node_userId
+
+ let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
+ identity
+ $ nodeGraph ^. node_parentId
+
+ g <- case graph of
+ Nothing -> do
+ graph' <- computeGraph cId NgramsTerms repo
+ _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
+ pure graph'
+
+ Just graph' -> if listVersion == Just v
+ then pure graph'
+ else do
+ graph'' <- computeGraph cId NgramsTerms repo
+ _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
+ pure graph''
+ pure $ trace ("salut" <> show g) $ g
+
+
+-- TODO use Database Monad only here ?
+computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
+computeGraph cId nt repo = do
+ lId <- defaultList cId
+
+ let metadata = GraphMetadata "Title" [cId]
[ LegendField 1 "#FFF" "Cluster"
, LegendField 2 "#FFF" "Cluster"
]
+ (ListForGraph lId (repo ^. r_version))
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
- let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
- lId <- defaultList cId
- ngs <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] NgramsTerms
+ lIds <- selectNodesWithUsername NodeList userMaster
+ let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
+
+ myCooc <- Map.filter (>1)
+ <$> getCoocByNgrams (Diagonal True)
+ <$> groupNodesByNgrams ngs
+ <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
- myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal False)
- <$> groupNodesByNgrams ngs
- <$> getNodesByNgramsOnlyUser cId NgramsTerms (Map.keys ngs)
+ graph <- liftIO $ cooc2graph 0 myCooc
+ let graph' = set graph_metadata (Just metadata) graph
+ pure graph'
- liftIO $ set graph_metadata (Just metadata) <$> cooc2graph myCooc
postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
putGraph :: NodeId -> GargServer (Put '[JSON] Int)
putGraph = undefined
-
-
-
--- | Instances
-