[REFACT] HasDBid
[gargantext.git] / src / Gargantext / Core / Viz / Graph / API.hs
index 8acc29e63ff2374c8740647e3f9d44383bfd252e..b7db0ea8b714cdd85f890b12cbe0869109b9a545 100644 (file)
@@ -10,8 +10,6 @@ Portability : POSIX
 -}
 
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
 {-# LANGUAGE TypeOperators     #-}
 
@@ -20,22 +18,21 @@ module Gargantext.Core.Viz.Graph.API
 
 import Control.Lens (set, (^.), _Just, (^?))
 import Data.Aeson
-import qualified Data.Map as Map
-import Data.Maybe (Maybe(..))
 import Data.Swagger
 import Data.Text
 import Debug.Trace (trace)
 import GHC.Generics (Generic)
-import Servant
-import Servant.Job.Async
-import Servant.XML
-
 import Gargantext.API.Admin.Orchestrator.Types
-import Gargantext.API.Ngrams (NgramsRepo, r_version)
 import Gargantext.API.Ngrams.Tools
+import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
 import Gargantext.API.Prelude
+import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..))
 import Gargantext.Core.Types.Main
+import Gargantext.Core.Viz.Graph
+import Gargantext.Core.Viz.Graph.GEXF ()
+import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
+import Gargantext.Database.Action.Node (mkNodeWithParent)
 import Gargantext.Database.Admin.Config
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (Cmd)
@@ -43,20 +40,23 @@ import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.Select
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Query.Table.Node.User (getNodeUser)
 import Gargantext.Database.Schema.Ngrams
-import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata)
+import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata, node_name, node_userId)
 import Gargantext.Prelude
-import Gargantext.Core.Viz.Graph
-import Gargantext.Core.Viz.Graph.GEXF ()
-import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
-import Gargantext.Core.Viz.Graph.Distances (Distance(..), GraphMetric(..))
-
+import Servant
+import Servant.Job.Async
+import Servant.XML
+import qualified Data.HashMap.Strict as HashMap
 ------------------------------------------------------------------------
 -- | There is no Delete specific API for Graph since it can be deleted
 -- as simple Node.
-type GraphAPI   =  Get  '[JSON] Graph
+type GraphAPI   =  Get  '[JSON] HyperdataGraphAPI
+              :<|> "async" :> GraphAsyncAPI
+              :<|> "clone"
+                   :> ReqBody '[JSON] HyperdataGraphAPI
+                   :> Post '[JSON] NodeId
               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
-              :<|> GraphAsyncAPI
               :<|> "versions" :> GraphVersionsAPI
 
 data GraphVersions =
@@ -69,16 +69,18 @@ instance ToJSON GraphVersions
 instance ToSchema GraphVersions
 
 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
-graphAPI u n =  getGraph       u n
-         :<|> getGraphGexf     u n
-         :<|> graphAsync       u n
-         :<|> graphVersionsAPI u n
+graphAPI u n = getGraph         u n
+          :<|> graphAsync       u n
+          :<|> graphClone       u n
+          :<|> getGraphGexf     u n
+          :<|> graphVersionsAPI u n
 
 ------------------------------------------------------------------------
-getGraph :: UserId -> NodeId -> GargNoServer Graph
+getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
 getGraph _uId nId = do
-  nodeGraph <- getNodeWith nId HyperdataGraph
-  let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+  nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
+  let graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
+  let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 
   repo <- getRepo
 
@@ -90,21 +92,24 @@ getGraph _uId nId = do
   case graph of
     Nothing     -> do
         graph' <- computeGraph cId Conditional NgramsTerms repo
-        _      <- updateHyperdata nId (HyperdataGraph $ Just graph')
-        pure $ trace "[G.V.G.API] Graph empty, computing" graph'
+        mt     <- defaultGraphMetadata cId "Title" repo
+        let graph'' = set graph_metadata (Just mt) graph'
+        let hg = HyperdataGraphAPI graph'' camera
+       -- _      <- updateHyperdata nId hg
+        _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
+        pure $ trace "[G.V.G.API] Graph empty, computing" hg
 
-    Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" graph'
+    Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
+        HyperdataGraphAPI graph' camera
 
 
 recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
 recomputeGraph _uId nId d = do
-  nodeGraph <- getNodeWith nId HyperdataGraph
-  let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
-  let listVersion = graph ^? _Just
-                            . graph_metadata
-                            . _Just
-                            . gm_list
-                            . lfg_version
+  nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
+  let graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
+  let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
+  let graphMetadata = graph ^? _Just . graph_metadata . _Just
+  let listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 
   repo <- getRepo
   let v   = repo ^. r_version
@@ -115,15 +120,18 @@ recomputeGraph _uId nId d = do
   case graph of
     Nothing     -> do
       graph' <- computeGraph cId d NgramsTerms repo
-      _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
-      pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph'
+      mt     <- defaultGraphMetadata cId "Title" repo
+      let graph'' = set graph_metadata (Just mt) graph'
+      _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
+      pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
 
     Just graph' -> if listVersion == Just v
                      then pure graph'
                      else do
                        graph'' <- computeGraph cId d NgramsTerms repo
-                       _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
-                       pure $ trace "[G.V.G.API] Graph exists, recomputing" graph''
+                       let graph''' = set graph_metadata graphMetadata graph''
+                       _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
+                       pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
 
 
 -- TODO use Database Monad only here ?
@@ -140,56 +148,68 @@ computeGraph cId d nt repo = do
   let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
 
   -- TODO split diagonal
-  myCooc <- Map.filter (>1)
+  myCooc <- HashMap.filter (>1)
          <$> getCoocByNgrams (Diagonal True)
          <$> groupNodesByNgrams ngs
-         <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
+         <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 
   graph <- liftBase $ cooc2graph d 0 myCooc
 
+  pure graph
 
-  let metadata = GraphMetadata "Title"
-                               Order1
-                               [cId]
-                               [ LegendField 1 "#FFF" "Cluster1"
-                               , LegendField 2 "#FFF" "Cluster2"
-                               , LegendField 3 "#FFF" "Cluster3"
-                               , LegendField 4 "#FFF" "Cluster4"
-                               ]
-                               (ListForGraph lId (repo ^. r_version))
-                         -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 
-  pure $ set graph_metadata (Just metadata) graph
+defaultGraphMetadata :: HasNodeError err
+                     => CorpusId
+                     -> Text
+                     -> NgramsRepo
+                     -> Cmd err GraphMetadata
+defaultGraphMetadata cId t repo = do
+  lId  <- defaultList cId
+
+  pure $ GraphMetadata {
+      _gm_title = t
+    , _gm_metric = Order1
+    , _gm_corpusId = [cId]
+    , _gm_legend = [
+          LegendField 1 "#FFF" "Cluster1"
+        , LegendField 2 "#FFF" "Cluster2"
+        , LegendField 3 "#FFF" "Cluster3"
+        , LegendField 4 "#FFF" "Cluster4"
+        ]
+      , _gm_list = (ListForGraph lId (repo ^. r_version))
+      , _gm_startForceAtlas = True
+    }
+                         -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 
 
 ------------------------------------------------------------
-type GraphAsyncAPI = Summary "Update graph"
-                   :> "async"
-                   :> AsyncJobsAPI JobLog () JobLog
+type GraphAsyncAPI = Summary "Recompute graph"
+                     :> "recompute"
+                     :> AsyncJobsAPI JobLog () JobLog
 
 
 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 graphAsync u n =
   serveJobsAPI $
-    JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
+    JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 
 
-graphAsync' :: UserId
-           -> NodeId
-           -> (JobLog -> GargNoServer ())
-           -> GargNoServer JobLog
-graphAsync' u n logStatus = do
+graphRecompute :: UserId
+               -> NodeId
+               -> (JobLog -> GargNoServer ())
+               -> GargNoServer JobLog
+graphRecompute u n logStatus = do
   logStatus JobLog { _scst_succeeded = Just 0
-                          , _scst_failed    = Just 0
-                          , _scst_remaining = Just 1
-                          , _scst_events    = Just []
-                          }
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 1
+                   , _scst_events    = Just []
+                   }
   _g <- trace (show u) $ recomputeGraph u n Conditional
   pure  JobLog { _scst_succeeded = Just 1
-                      , _scst_failed    = Just 0
-                      , _scst_remaining = Just 0
-                      , _scst_events    = Just []
-                      }
+               , _scst_failed    = Just 0
+               , _scst_remaining = Just 0
+               , _scst_events    = Just []
+               }
 
 ------------------------------------------------------------
 type GraphVersionsAPI = Summary "Graph versions"
@@ -199,12 +219,12 @@ type GraphVersionsAPI = Summary "Graph versions"
 
 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 graphVersionsAPI u n =
-           graphVersions n
+           graphVersions n
       :<|> recomputeVersions u n
 
-graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
-graphVersions _uId nId = do
-  nodeGraph <- getNodeWith nId HyperdataGraph
+graphVersions :: NodeId -> GargNoServer GraphVersions
+graphVersions nId = do
+  nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
   let listVersion = graph ^? _Just
                             . graph_metadata
@@ -221,13 +241,32 @@ graphVersions _uId nId = do
 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 recomputeVersions uId nId = recomputeGraph uId nId Conditional
 
+------------------------------------------------------------
+graphClone :: UserId
+           -> NodeId
+           -> HyperdataGraphAPI
+           -> GargNoServer NodeId
+graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
+                                      , _hyperdataAPICamera = camera }) = do
+  let nodeType = NodeGraph
+  nodeUser <- getNodeUser (NodeId uId)
+  nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
+  let uId' = nodeUser ^. node_userId
+  nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
+  case nIds of
+    [] -> pure pId
+    (nId:_) -> do
+      let graphP = graph
+      let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
+
+      _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
+
+      pure nId
+
 ------------------------------------------------------------
 getGraphGexf :: UserId
              -> NodeId
              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 getGraphGexf uId nId = do
-  graph <- getGraph uId nId
+  HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
   pure $ addHeader "attachment; filename=graph.gexf" graph
-
-
-