[list] implement updates for remaining list charts

src/Gargantext/API/Metrics.hs

@@ -32,6 +32,7 @@ import Gargantext.Database.Action.Flow
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..))
 import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
 import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Prelude
 import Gargantext.Database.Schema.Node (node_hyperdata)
@@ -47,6 +48,11 @@ type ScatterAPI = Summary "SepGen IncExc metrics"
                   :> QueryParamR "ngramsType" TabType
                   :> QueryParam  "limit"      Int
                   :> Get '[JSON] Metrics
+              :<|> Summary "Scatter update"
+                  :> QueryParam  "list"       ListId
+                  :> QueryParamR "ngramsType" TabType
+                  :> QueryParam  "limit"      Int
+                  :> Post '[JSON] ()
 
 getScatter :: FlowCmdM env err m =>
   CorpusId
@@ -54,7 +60,36 @@ getScatter :: FlowCmdM env err m =>
   -> TabType
   -> Maybe Limit
   -> m Metrics
-getScatter cId maybeListId tabType maybeLimit = do
+getScatter cId maybeListId tabType _maybeLimit = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let (HyperdataList { hd_scatter = mChart }) = node ^. node_hyperdata
+
+  case mChart of
+    Just chart -> pure chart
+    Nothing    -> do
+      s <- updateScatter' cId maybeListId tabType Nothing
+      pure s
+
+updateScatter :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> m ()
+updateScatter cId maybeListId tabType maybeLimit = do
+  _ <- updateScatter' cId maybeListId tabType maybeLimit
+  pure ()
+
+updateScatter' :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> m Metrics
+updateScatter' cId maybeListId tabType maybeLimit = do
   (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
 
   let
@@ -63,44 +98,217 @@ getScatter cId maybeListId tabType maybeLimit = do
     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
     errorMsg     = "API.Node.metrics: key absent"
 
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let (HyperdataList { hd_chart = hdc
+                     , hd_list = hdl
+                     , hd_pie = hdp
+                     , hd_tree = hdt }) = node ^. node_hyperdata
+  _ <- updateHyperdata listId $ HyperdataList hdc hdl hdp (Just $ Metrics metrics) hdt
+
   pure $ Metrics metrics
 
 
+-------------------------------------------------------------
+-- | Chart metrics API
+type ChartApi = Summary " Chart API"
+              :> QueryParam "from" UTCTime
+              :> QueryParam "to"   UTCTime
+              :> QueryParam  "list"       ListId
+              :> QueryParamR "ngramsType" TabType
+              :> Get '[JSON] (ChartMetrics Histo)
+        :<|> Summary "Chart update"
+                :> QueryParam  "list"       ListId
+                :> QueryParamR "ngramsType" TabType
+                :> QueryParam  "limit"      Int
+                :> Post '[JSON] ()
+               
 -- TODO add start / end
-getChart :: CorpusId -> Maybe UTCTime -> Maybe UTCTime -> Cmd err (ChartMetrics Histo)
-getChart cId _start _end = do
-  h <- histoData cId
-  pure (ChartMetrics h)
+getChart :: HasNodeError err
+         => CorpusId
+         -> Maybe UTCTime
+         -> Maybe UTCTime
+         -> Maybe ListId
+         -> TabType
+         -> Cmd err (ChartMetrics Histo)
+getChart cId _start _end maybeListId tabType = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let (HyperdataList { hd_chart = mChart }) = node ^. node_hyperdata
 
-getPie :: FlowCmdM env err m => CorpusId -> Maybe UTCTime -> Maybe UTCTime -> TabType -> m (ChartMetrics Histo)
-getPie cId _start _end tt = do
-  p <- pieData cId (ngramsTypeFromTabType tt) GraphTerm
-  pure (ChartMetrics p)
+  case mChart of
+    Just chart -> pure chart
+    Nothing    -> do
+      h <- updateChart' cId maybeListId tabType Nothing
+      pure h
 
-getTree :: FlowCmdM env err m => CorpusId -> Maybe UTCTime -> Maybe UTCTime -> TabType -> ListType -> m (ChartMetrics [MyTree])
-getTree cId _start _end tt lt = do
-  p <- treeData cId (ngramsTypeFromTabType tt) lt
-  pure (ChartMetrics p)
+updateChart :: HasNodeError err =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> Cmd err ()
+updateChart cId maybeListId tabType maybeLimit = do
+  _ <- updateChart' cId maybeListId tabType maybeLimit
+  pure ()
 
+updateChart' :: HasNodeError err =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> Cmd err (ChartMetrics Histo)
+updateChart' cId maybeListId _tabType _maybeLimit = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let (HyperdataList { hd_list = hdl
+                     , hd_pie = hdp
+                     , hd_scatter = hds
+                     , hd_tree = hdt }) = node ^. node_hyperdata
+  h <- histoData cId
+  _ <- updateHyperdata listId $ HyperdataList (Just $ ChartMetrics h) hdl hdp hds hdt
+
+  pure $ ChartMetrics h
+-------------------------------------------------------------
+-- | Pie metrics API
+type PieApi = Summary "Pie Chart"
+           :> QueryParam "from" UTCTime
+           :> QueryParam "to"   UTCTime
+           :> QueryParam  "list"       ListId
+           :> QueryParamR "ngramsType" TabType
+           :> Get '[JSON] (ChartMetrics Histo)
+        :<|> Summary "Pie Chart update"
+                :> QueryParam  "list"       ListId
+                :> QueryParamR "ngramsType" TabType
+                :> QueryParam  "limit"      Int
+                :> Post '[JSON] ()
+
+getPie :: FlowCmdM env err m
+       => CorpusId
+       -> Maybe UTCTime
+       -> Maybe UTCTime
+       -> Maybe ListId
+       -> TabType
+       -> m (ChartMetrics Histo)
+getPie cId _start _end maybeListId tabType = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let (HyperdataList { hd_pie = mChart }) = node ^. node_hyperdata
 
+  case mChart of
+    Just chart -> pure chart
+    Nothing    -> do
+      p <- updatePie' cId maybeListId tabType Nothing
+      pure p
 
-updateChart :: FlowCmdM env err m =>
+updatePie :: FlowCmdM env err m =>
   CorpusId
   -> Maybe ListId
   -> TabType
   -> Maybe Limit
   -> m ()
-updateChart cId maybeListId _tabType _maybeLimit = do
+updatePie cId maybeListId tabType maybeLimit = do
+  _ <- updatePie' cId maybeListId tabType maybeLimit
+  pure ()
+
+updatePie' :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> Maybe Limit
+  -> m (ChartMetrics Histo)
+updatePie' cId maybeListId tabType _maybeLimit = do
   listId <- case maybeListId of
     Just lid -> pure lid
     Nothing  -> defaultList cId
-
   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let (HyperdataList { hd_chart = hdc
+                     , hd_list = hdl
+                     , hd_scatter = hds
+                     , hd_tree = hdt }) = node ^. node_hyperdata
+
+  p <- pieData cId (ngramsTypeFromTabType tabType) GraphTerm
+  _ <- updateHyperdata listId $ HyperdataList hdc hdl (Just $ ChartMetrics p) hds hdt
 
-  let (HyperdataList { hd_list = hdl }) = node ^. node_hyperdata
+  pure $ ChartMetrics p
+
+-------------------------------------------------------------
+-- | Tree metrics API
 
-  h <- histoData listId
+type TreeApi = Summary " Tree API"
+           :> QueryParam "from" UTCTime
+           :> QueryParam "to"   UTCTime
+           :> QueryParam  "list"       ListId
+           :> QueryParamR "ngramsType" TabType
+           :> QueryParamR "listType"   ListType
+           :> Get '[JSON] (ChartMetrics [MyTree])
+        :<|> Summary "Tree Chart update"
+                :> QueryParam  "list"       ListId
+                :> QueryParamR "ngramsType" TabType
+                :> QueryParamR "listType"   ListType
+                :> Post '[JSON] ()
 
-  _ <- updateHyperdata listId $ HyperdataList hdl $ Just $ ChartMetrics h
+                -- Depending on the Type of the Node, we could post
+                -- New documents for a corpus
+                -- New map list terms
+             -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 
+getTree :: FlowCmdM env err m
+        => CorpusId
+        -> Maybe UTCTime
+        -> Maybe UTCTime
+        -> Maybe ListId
+        -> TabType
+        -> ListType
+        -> m (ChartMetrics [MyTree])
+getTree cId _start _end maybeListId tabType listType = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let (HyperdataList { hd_tree = mChart }) = node ^. node_hyperdata
+  case mChart of
+    Just chart -> pure chart
+    Nothing    -> do
+      t <- updateTree' cId maybeListId tabType listType
+      pure t
+
+updateTree :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> ListType
+  -> m ()
+updateTree cId maybeListId tabType listType = do
+  _ <- updateTree' cId maybeListId tabType listType
   pure ()
+
+updateTree' :: FlowCmdM env err m =>
+  CorpusId
+  -> Maybe ListId
+  -> TabType
+  -> ListType
+  -> m (ChartMetrics [MyTree])
+updateTree' cId maybeListId tabType listType = do
+  listId <- case maybeListId of
+    Just lid -> pure lid
+    Nothing  -> defaultList cId
+
+  node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
+  let (HyperdataList { hd_chart = hdc
+                     , hd_list = hdl
+                     , hd_scatter = hds
+                     , hd_pie = hdp }) = node ^. node_hyperdata
+  t <- treeData cId (ngramsTypeFromTabType tabType) listType
+  _ <- updateHyperdata listId $ HyperdataList hdc hdl hdp hds (Just $ ChartMetrics t)
+
+  pure $ ChartMetrics t

src/Gargantext/API/Node.hs

@@ -34,7 +34,6 @@ import Data.Aeson (FromJSON, ToJSON)
 import Data.Maybe
 import Data.Swagger
 import Data.Text (Text())
-import Data.Time (UTCTime)
 import GHC.Generics (Generic)
 import Servant
 import Test.QuickCheck (elements)
@@ -43,8 +42,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 import Gargantext.API.Admin.Auth (withAccess, PathId(..))
 import Gargantext.API.Prelude
 import Gargantext.API.Metrics
-import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR)
-import Gargantext.API.Ngrams.NTree (MyTree)
+import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus)
 import Gargantext.API.Node.New
 import qualified Gargantext.API.Node.Share  as Share
 import qualified Gargantext.API.Node.Update as Update
@@ -52,9 +50,8 @@ import qualified Gargantext.API.Node.Update as Update
 import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
 import Gargantext.API.Table
 import Gargantext.Core.Types (NodeTableResult)
-import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
+import Gargantext.Core.Types.Main (Tree, NodeTree)
 import Gargantext.Database.Action.Flow.Pairing (pairing)
-import Gargantext.Database.Admin.Types.Metrics (ChartMetrics)
 import Gargantext.Database.Query.Facet (FacetDoc, OrderBy(..))
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Query.Table.Node
@@ -68,7 +65,6 @@ import Gargantext.Database.Prelude -- (Cmd, CmdM)
 import Gargantext.Database.Query.Table.NodeNode
 import Gargantext.Prelude
 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
-import Gargantext.Viz.Types
 import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
 import qualified Gargantext.Database.Action.Delete as Action (deleteNode)
 
@@ -216,20 +212,28 @@ nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode
 
            :<|> scatterApi id'
            :<|> chartApi   id'
-           :<|> getPie     id'
-           :<|> getTree    id'
+           :<|> pieApi     id'
+           :<|> treeApi    id'
            :<|> phyloAPI   id' uId
            -- :<|> nodeAddAPI id'
            -- :<|> postUpload id'
            :<|> Update.api  uId id'
 
 scatterApi :: NodeId -> GargServer ScatterAPI
-scatterApi id' =  getScatter id'
+scatterApi id' = getScatter id'
+            :<|> updateScatter id'
 
 chartApi :: NodeId -> GargServer ChartApi
-chartApi id' =  getChart id'
-           :<|> updateChart id'
+chartApi id' = getChart id'
+          :<|> updateChart id'
 
+pieApi :: NodeId -> GargServer PieApi
+pieApi id' = getPie id'
+        :<|> updatePie id'
+
+treeApi :: NodeId -> GargServer TreeApi
+treeApi id' = getTree id'
+         :<|> updateTree id'
 
 ------------------------------------------------------------------------
 data RenameNode = RenameNode { r_name :: Text }
@@ -294,33 +298,6 @@ pairWith cId aId lId = do
   pure r
 
 ------------------------------------------------------------------------
-type ChartApi = Summary " Chart API"
-              :> QueryParam "from" UTCTime
-              :> QueryParam "to"   UTCTime
-              :> Get '[JSON] (ChartMetrics Histo)
-        :<|> Summary "SepGen IncExc chart update"
-                :> QueryParam  "list"       ListId
-                :> QueryParamR "ngramsType" TabType
-                :> QueryParam  "limit"      Int
-                :> Post '[JSON] ()
-
-type PieApi = Summary " Chart API"
-           :> QueryParam "from" UTCTime
-           :> QueryParam "to"   UTCTime
-           :> QueryParamR "ngramsType" TabType
-           :> Get '[JSON] (ChartMetrics Histo)
-
-type TreeApi = Summary " Tree API"
-           :> QueryParam "from" UTCTime
-           :> QueryParam "to"   UTCTime
-           :> QueryParamR "ngramsType" TabType
-           :> QueryParamR "listType"   ListType
-           :> Get '[JSON] (ChartMetrics [MyTree])
-
-                -- Depending on the Type of the Node, we could post
-                -- New documents for a corpus
-                -- New map list terms
-             -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 
 ------------------------------------------------------------------------
 type TreeAPI   = QueryParams "type" NodeType :> Get '[JSON] (Tree NodeTree)

src/Gargantext/Database/Admin/Types/Hyperdata.hs

@@ -26,7 +26,8 @@ import Protolude hiding (ByteString)
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
 
-import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..))
+import Gargantext.API.Ngrams.NTree (MyTree)
+import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metrics)
 import Gargantext.Database.Prelude (fromField')
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Viz.Phylo (Phylo(..))
@@ -217,8 +218,11 @@ instance Arbitrary HyperdataCorpus where
 
 ------------------------------------------------------------------------
 data HyperdataList =
-  HyperdataList { hd_list :: !(Maybe Text)
-                , hd_chart :: !(Maybe (ChartMetrics Histo))
+  HyperdataList { hd_chart :: !(Maybe (ChartMetrics Histo))
+                , hd_list :: !(Maybe Text)
+                , hd_pie :: !(Maybe (ChartMetrics Histo))
+                , hd_scatter :: !(Maybe Metrics)
+                , hd_tree :: !(Maybe (ChartMetrics [MyTree]))
                 } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hd_") ''HyperdataList)