[FIX] gargantext-upgrade to update hyperdata of NodeList

bin/gargantext-upgrade/Main.hs

+{-|
+Module      : Main.hs
+Description : Gargantext Import Corpus
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Import a corpus binary.
+
+ -}
+
+{-# LANGUAGE Strict            #-}
+
+module Main where
+
+import Data.Proxy
+import Gargantext.API.Admin.Settings (withDevEnv, runCmdDev)
+import Gargantext.API.Prelude (GargError)
+import Gargantext.API.Node () -- instances only
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Admin.Types.Hyperdata
+import Gargantext.Database.Query.Table.Node.UpdateOpaleye
+import Gargantext.Database.Prelude (Cmd, )
+import Gargantext.Prelude
+import System.Environment (getArgs)
+
+
+main :: IO ()
+main = do
+  [iniPath] <- getArgs
+
+  let
+    updateNodes :: Cmd GargError [Int64]
+    updateNodes = updateNodesWithType
+                    NodeList
+                    (Proxy :: Proxy HyperdataList)
+                    (\_ -> defaultHyperdataList)
+
+  withDevEnv iniPath $ \env -> do
+    x <- runCmdDev env updateNodes
+    putStrLn $ show x
+  pure ()

package.yaml

@@ -55,6 +55,7 @@ library:
   - Gargantext.Database.Action.Flow
   - Gargantext.Database.Query.Table.User
   - Gargantext.Database.Query.Table.Node
+  - Gargantext.Database.Query.Table.Node.UpdateOpaleye
   - Gargantext.Database.Prelude
   - Gargantext.Database.Admin.Trigger.Init
   - Gargantext.Database.Admin.Config
@@ -383,6 +384,19 @@ executables:
       - gargantext
       - base
 
+  gargantext-upgrade:
+    main: Main.hs
+    source-dirs: bin/gargantext-upgrade
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -O2
+    - -Wmissing-signatures
+    dependencies:
+      - gargantext
+      - base
+
   gargantext-cbor2json:
     main: Main.hs
     source-dirs: bin/gargantext-cbor2json

src/Gargantext/API/Ngrams/Types.hs

@@ -76,6 +76,7 @@ instance FromHttpApiData TabType
     parseUrlPiece "Contacts"   = pure Contacts
 
     parseUrlPiece _            = Left "Unexpected value of TabType"
+
 instance ToParamSchema TabType
 instance ToJSON        TabType
 instance FromJSON      TabType
@@ -83,6 +84,7 @@ instance ToSchema      TabType
 instance Arbitrary     TabType
   where
     arbitrary = elements [minBound .. maxBound]
+
 instance FromJSONKey TabType where
   fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
 instance ToJSONKey TabType where

src/Gargantext/API/Node/Get.hs

@@ -30,7 +30,7 @@ import Test.QuickCheck.Arbitrary
 
 import Gargantext.API.Prelude
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Query.Table.Node (JSONB{-, getNodeWith-})
+import Gargantext.Database.Prelude (JSONB{-, getNodeWith-})
 import Gargantext.Prelude
 
 ------------------------------------------------------------------------

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

@@ -23,7 +23,7 @@ module Gargantext.Database.Admin.Types.Hyperdata.List
 
 import Data.Map (Map)
 import qualified Data.Map as Map
-
+import Control.Applicative
 import Gargantext.Prelude
 import Gargantext.Core.Viz.Types (Histo(..))
 import Gargantext.API.Ngrams.NTree (MyTree)
@@ -47,14 +47,24 @@ data HyperdataList =
   --               } deriving (Show, Generic)
 
 defaultHyperdataList :: HyperdataList
-defaultHyperdataList = HyperdataList {
-    _hl_chart   = Map.empty
+defaultHyperdataList =
+  HyperdataList { _hl_chart   = Map.empty
                 , _hl_list    = Nothing
                 , _hl_pie     = Map.empty
                 , _hl_scatter = Map.empty
                 , _hl_tree    = Map.empty
                 }
 
+------------------------------------------------------------------------
+-- Instances
+------------------------------------------------------------------------
+instance Hyperdata HyperdataList
+
+$(makeLenses ''HyperdataList)
+$(deriveJSON (unPrefix "_hl_") ''HyperdataList)
+
+
+------------------------------------------------------------------------
 data HyperdataListCooc =
   HyperdataListCooc { _hlc_preferences :: !Text }
   deriving (Generic)
@@ -62,17 +72,15 @@ data HyperdataListCooc =
 defaultHyperdataListCooc :: HyperdataListCooc
 defaultHyperdataListCooc = HyperdataListCooc ""
 
-------------------------------------------------------------------------
--- Instances
-------------------------------------------------------------------------
-instance Hyperdata HyperdataList
-instance Hyperdata HyperdataListCooc
 
-$(makeLenses ''HyperdataList)
+instance Hyperdata HyperdataListCooc
 $(makeLenses ''HyperdataListCooc)
-$(deriveJSON (unPrefix "_hl_") ''HyperdataList)
 $(deriveJSON (unPrefix "_hlc_") ''HyperdataListCooc)
 
+
+
+
+
 instance Arbitrary HyperdataList where
   arbitrary = pure defaultHyperdataList
 instance Arbitrary HyperdataListCooc where

src/Gargantext/Database/Prelude.hs

@@ -30,7 +30,7 @@ import Data.Word (Word16)
 import Database.PostgreSQL.Simple (Connection, connect)
 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
 import Database.PostgreSQL.Simple.Internal  (Field)
-import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
+import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery, PGJsonb, QueryRunnerColumnDefault)
 import Opaleye.Aggregate (countRows)
 import System.IO (FilePath)
 import System.IO (stderr)
@@ -55,6 +55,8 @@ class HasConfig env where
 instance HasConfig GargConfig where
   hasConfig = identity
 
+-------------------------------------------------------
+type JSONB = QueryRunnerColumnDefault PGJsonb
 -------------------------------------------------------
 type CmdM' env err m =
   ( MonadReader env m

src/Gargantext/Database/Query/Table/Node.hs

@@ -99,7 +99,7 @@ getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 
 -- TODO: Why is the second parameter ignored?
 -- TODO: Why not use getNodesWith?
-getNodesWithParentId :: (Hyperdata a, QueryRunnerColumnDefault PGJsonb a)
+getNodesWithParentId :: (Hyperdata a, JSONB a)
                      => Maybe NodeId
                      -> Cmd err [Node a]
 getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
@@ -154,13 +154,20 @@ selectNodesWithParentID n = proc () -> do
     restrict -< parent_id .== (pgNodeId n)
     returnA -< row
 
-selectNodesWithType :: Column PGInt4 -> Query NodeRead
-selectNodesWithType type_id = proc () -> do
+
+------------------------------------------------------------------------
+-- | Example of use:
+-- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
+getNodesWithType :: (HasNodeError err, JSONB a) => NodeType -> proxy a -> Cmd err [Node a]
+getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
+
+selectNodesWithType :: NodeType -> Query NodeRead
+selectNodesWithType nt = proc () -> do
     row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
-    restrict -< tn .== type_id
+    restrict -< tn .== (pgInt4 $ nodeTypeId nt)
     returnA -< row
 
-type JSONB = QueryRunnerColumnDefault PGJsonb
+------------------------------------------------------------------------
 
 
 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)

src/Gargantext/Database/Query/Table/Node/Children.hs

@@ -23,7 +23,6 @@ import Gargantext.Database.Admin.Config (nodeTypeId)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument, HyperdataContact)
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Filter
-import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.NodeNode
 import Gargantext.Database.Schema.Node
 import Opaleye

src/Gargantext/Database/Query/Table/Node/UpdateOpaleye.hs

@@ -15,13 +15,14 @@ Portability : POSIX
 module Gargantext.Database.Query.Table.Node.UpdateOpaleye
   where
 
-
 import Opaleye
 import Data.Aeson (encode, ToJSON)
 import Gargantext.Prelude
 import Gargantext.Database.Schema.Node
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (Cmd, mkCmd)
+import Gargantext.Database.Prelude (Cmd, mkCmd, JSONB)
+import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Table.Node.Error
 
 updateHyperdata :: ToJSON a => NodeId -> a -> Cmd err Int64
 updateHyperdata i h = mkCmd $ \c -> runUpdate_ c (updateHyperdataQuery i h)
@@ -37,3 +38,13 @@ updateHyperdataQuery i h = Update
    }
     where h' =  (pgJSONB $ cs $ encode $ h)
 
+----------------------------------------------------------------------------------
+updateNodesWithType :: ( HasNodeError err
+                       , JSONB a
+                       , ToJSON a
+                       ) => NodeType -> proxy a -> (a -> a) -> Cmd err [Int64]
+updateNodesWithType nt p f = do
+  ns <- getNodesWithType nt p
+  mapM (\n -> updateHyperdata (_node_id n) (f $ _node_hyperdata n)) ns
+
+