[nodeStory] db & migration from dir works now

bin/gargantext-client/Auth.hs

 module Auth where
 
 import Prelude
-import Data.Maybe
 import Core
 import Options
 

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.5.8.9.9
+version:        0.0.5.8.9.9
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -269,6 +269,7 @@ library
       Gargantext.Database.Admin.Types.Hyperdata.User
       Gargantext.Database.Admin.Types.Metrics
       Gargantext.Database.GargDB
+      Gargantext.Database.NodeStory
       Gargantext.Database.Query
       Gargantext.Database.Query.Facet
       Gargantext.Database.Query.Filter

src/Gargantext/Core/NodeStory.hs

@@ -34,6 +34,7 @@ import Data.Aeson hiding ((.=), decode)
 import Data.Map.Strict (Map)
 import Data.Monoid
 import Data.Semigroup
+import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
 import GHC.Generics (Generic)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types (NodeId)
@@ -41,6 +42,7 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
 import Gargantext.Prelude
+import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
 import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
 import System.IO (FilePath, hClose)
 import System.IO.Temp (withTempFile)
@@ -278,6 +280,12 @@ type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'
 type NgramsState'      = Map       TableNgrams.NgramsType NgramsTableMap
 type NgramsStatePatch' = PatchMap  TableNgrams.NgramsType NgramsTablePatch
 instance Serialise NgramsStatePatch'
+instance FromField (Archive NgramsState' NgramsStatePatch')
+  where
+    fromField = fromJSONField
+instance DefaultFromField SqlJsonb (Archive NgramsState' NgramsStatePatch')
+  where
+    defaultFromField = fromPGSFromField
 
 -- TODO Semigroup instance for unions
 -- TODO check this

src/Gargantext/Database/NodeStory.hs

+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE TemplateHaskell           #-}
+
+module Gargantext.Database.NodeStory where
+
+import Control.Arrow (returnA)
+import Control.Monad (foldM)
+import qualified Data.Map.Strict as Map
+import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+import Gargantext.API.Ngrams.Tools (getRepo)
+import Gargantext.Core (HasDBid)
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Core.NodeStory (Archive(..), NodeStory(..), NodeListStory, NgramsState', NgramsStatePatch')
+import qualified Gargantext.Core.NodeStory as NS
+import Gargantext.Core.Types (NodeId(..), NodeType(..))
+import Gargantext.Database.Prelude (Cmd, mkCmd, runOpaQuery)
+import Gargantext.Database.Query.Table.Node (getNodesIdWithType, nodeExists)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Prelude
+import Opaleye hiding (FromField)
+import Opaleye.Internal.Table (Table(..))
+
+
+data NodeStoryPoly a b = NodeStoryDB { node_id :: a
+                                     , archive :: b }
+  deriving (Eq)
+
+type ArchiveQ = Archive NgramsState' NgramsStatePatch'
+
+type NodeListStoryQ = NodeStoryPoly Int ArchiveQ
+
+type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
+type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
+
+$(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
+
+nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
+nodeStoryTable =
+  Table "node_stories"
+    ( pNodeStory NodeStoryDB { node_id = tableField "node_id"
+                             , archive = tableField "archive" } )
+  
+nodeStorySelect :: Select NodeStoryRead
+nodeStorySelect = selectTable nodeStoryTable
+
+getNodeStory :: NodeId -> Cmd err NodeListStory
+getNodeStory (NodeId nodeId) = do
+  res <- runOpaQuery query
+  pure $ NodeStory $ Map.fromListWith (<>) $ (\(NodeStoryDB nId a) -> (nId, a)) <$> res
+  where
+    query :: Select NodeStoryRead
+    query = proc () -> do
+      row@(NodeStoryDB node_id _) <- nodeStorySelect -< ()
+      restrict -< node_id .== sqlInt4 nodeId
+      returnA -< row
+
+insertNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
+insertNodeArchive (NodeId nId) a = mkCmd $ \c -> runInsert c insert
+  where
+    insert = Insert { iTable      = nodeStoryTable
+                    , iRows       = [NodeStoryDB { node_id = sqlInt4 nId
+                                                 , archive = sqlValueJSONB a }]
+                    , iReturning  = rCount
+                    , iOnConflict = Nothing }
+
+updateNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
+updateNodeArchive (NodeId nId) a = mkCmd $ \c -> runUpdate c update
+  where
+    update = Update { uTable      = nodeStoryTable
+                    , uUpdateWith = updateEasy (\(NodeStoryDB { .. }) -> NodeStoryDB { archive = sqlValueJSONB a, .. })
+                    , uWhere      = (\row -> node_id row .== sqlInt4 nId)
+                    , uReturning  = rCount }
+
+nodeStoryRemove :: NodeId -> Cmd err Int64
+nodeStoryRemove (NodeId nId) = mkCmd $ \c -> runDelete c delete
+  where
+    delete = Delete { dTable     = nodeStoryTable
+                    , dWhere     = (\row -> node_id row .== sqlInt4 nId)
+                    , dReturning = rCount }
+
+upsertNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
+upsertNodeArchive nId a = do
+  (NodeStory m) <- getNodeStory nId
+  case Map.lookup nId m of
+    Nothing -> insertNodeArchive nId a
+    Just _  -> updateNodeArchive nId a
+  
+-- | Returns a `NodeListStory`, updating the given one for given `NodeId`
+nodeStoryInc :: Maybe NodeListStory -> NodeId -> Cmd err NodeListStory
+nodeStoryInc Nothing nId = getNodeStory nId
+nodeStoryInc (Just ns@(NodeStory nls)) nId = do
+  case Map.lookup nId nls of
+    Nothing -> do
+      (NodeStory nls') <- getNodeStory nId
+      pure $ NodeStory $ Map.union nls nls'
+    Just _ -> pure ns
+
+nodeStoryIncs :: Maybe NodeListStory -> [NodeId] -> Cmd err NodeListStory
+nodeStoryIncs Nothing [] = panic "nodeStoryIncs: Empty"
+nodeStoryIncs (Just nls) ns = foldM (\m n -> nodeStoryInc (Just m) n) nls ns
+nodeStoryIncs Nothing (ni:ns) = do
+  m <- getNodeStory ni
+  nodeStoryIncs (Just m) ns
+
+nodeStoryDec :: NodeListStory -> NodeId -> Cmd err NodeListStory
+nodeStoryDec ns@(NodeStory nls) ni = do
+  case Map.lookup ni nls of
+    Nothing -> do
+      _ <- nodeStoryRemove ni
+      pure ns
+    Just _ -> do
+      let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
+      _ <- nodeStoryRemove ni
+      pure $ NodeStory ns'
+
+-- TODO
+-- readNodeStoryEnv
+
+-- getRepo from G.A.N.Tools
+
+migrateFromDir :: (HasMail env, HasNodeError err, NS.HasNodeStory env err m, HasDBid NodeType)
+               => m ()
+migrateFromDir = do
+  listIds <- getNodesIdWithType NodeList
+  (NodeStory nls) <- getRepo listIds
+  _ <- mapM (\(nId, a) -> do
+                n <- nodeExists nId
+                case n of
+                  False -> pure 0
+                  True  -> upsertNodeArchive nId a
+            ) $ Map.toList nls
+  _ <- nodeStoryIncs (Just $ NodeStory nls) listIds
+  pure ()

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

@@ -230,6 +230,9 @@ selectNodesIdWithType nt = proc () -> do
 
 ------------------------------------------------------------------------
 
+nodeExists :: (HasNodeError err) => NodeId -> Cmd err Bool
+nodeExists nId = (== [DPS.Only True])
+  <$> runPGSQuery [sql|SELECT true FROM nodes WHERE id = ? AND ?|] (nId, True)
 
 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 getNode nId = do