]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Graph/API.hs
Merge branch 'testing'
[gargantext.git] / 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 listVersion = graph ^? _Just
70 . graph_metadata
71 . _Just
72 . gm_list
73 . lfg_version
74
75 repo <- getRepo
76 let v = repo ^. r_version
77 nodeUser <- getNodeWith (NodeId uId) HyperdataUser
78
79 let uId' = nodeUser ^. node_userId
80
81 let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
82 identity
83 $ nodeGraph ^. node_parentId
84
85 g <- case graph of
86 Nothing -> do
87 graph' <- computeGraph cId NgramsTerms repo
88 _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
89 pure graph'
90
91 Just graph' -> if listVersion == Just v
92 then pure graph'
93 else do
94 graph'' <- computeGraph cId NgramsTerms repo
95 _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
96 pure graph''
97 pure $ trace ("salut" <> show g) $ g
98
99
100 -- TODO use Database Monad only here ?
101 computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
102 computeGraph cId nt repo = do
103 lId <- defaultList cId
104
105 let metadata = GraphMetadata "Title" [cId]
106 [ LegendField 1 "#FFF" "Cluster"
107 , LegendField 2 "#FFF" "Cluster"
108 ]
109 (ListForGraph lId (repo ^. r_version))
110 -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
111
112 lIds <- selectNodesWithUsername NodeList userMaster
113 let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
114
115 myCooc <- Map.filter (>1)
116 <$> getCoocByNgrams (Diagonal True)
117 <$> groupNodesByNgrams ngs
118 <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
119
120 graph <- liftIO $ cooc2graph 0 myCooc
121 let graph' = set graph_metadata (Just metadata) graph
122 pure graph'
123
124
125
126 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
127 postGraph = undefined
128
129 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
130 putGraph = undefined
131