Skip to content

haskell-gargantext
haskell-gargantext
Commit d557b58d authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge remote-tracking branch 'origin/131-dev-ngrams-table-db-connection-2' into dev-merge

parents 6ef5f0af e2897f33
Hide whitespace changes
Inline Side-by-side
Showing with 665 additions and 228 deletions
bin/gargantext-client/Auth.hs
View file @ d557b58d
module Auth where
import Prelude
import Data.Maybe
import Core
import Options
......
devops/postgres/upgrade/0.0.5.9.1.sql 0 → 100644
View file @ d557b58d
create table public.node_story_archive_history (
id SERIAL,
node_id INTEGER NOT NULL,
ngrams_type_id INTEGER NOT NULL,
ngrams_id INTEGER NOT NULL,
patch jsonb DEFAULT '{}'::jsonb NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY (node_id) REFERENCES public.nodes(id) ON DELETE CASCADE,
FOREIGN KEY (ngrams_id) REFERENCES public.ngrams(id) ON DELETE CASCADE
);
ALTER TABLE public.node_story_archive_history OWNER TO gargantua;
-- INSERT INTO node_story_archive_history (node_id, ngrams_type_id, patch) SELECT t.node_id, t.ngrams_type_id, t.patch FROM
-- (
-- WITH q AS (SELECT node_id, history.*, row_number() over (ORDER BY node_id) AS sid
-- FROM node_stories,
-- jsonb_to_recordset(archive->'history') AS history("Authors" jsonb, "Institutes" jsonb, "NgramsTerms" jsonb, "Sources" jsonb))
-- (SELECT node_id, sid, 1 AS ngrams_type_id, "Authors" AS patch FROM q WHERE "Authors" IS NOT NULL)
-- UNION (SELECT node_id, sid, 2 AS ngrams_type_id, "Institutes" AS patch FROM q WHERE "Institutes" IS NOT NULL)
-- UNION (SELECT node_id, sid, 4 AS ngrams_type_id, "NgramsTerms" AS patch FROM q WHERE "NgramsTerms" IS NOT NULL)
-- UNION (SELECT node_id, sid, 3 AS ngrams_type_id, "Sources" AS patch FROM q WHERE "Sources" IS NOT NULL)
-- ORDER BY node_id, ngrams_type_id, sid
-- ) AS t;
devops/postgres/upgrade/0.0.5.9.sql 0 → 100644
View file @ d557b58d
create table public.node_stories (
id SERIAL,
node_id INTEGER NOT NULL,
archive jsonb DEFAULT '{}'::jsonb NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY (node_id) REFERENCES public.nodes(id) ON DELETE CASCADE
);
ALTER TABLE public.node_stories OWNER TO gargantua;
CREATE UNIQUE INDEX ON public.node_stories USING btree (node_id);
gargantext.cabal
View file @ d557b58d
......@@ -162,6 +162,7 @@ library
Gargantext.Core.Methods.Graph.BAC.Proxemy
Gargantext.Core.Methods.Graph.MaxClique
Gargantext.Core.Methods.Matrix.Accelerate.Utils
Gargantext.Core.NodeStoryFile
Gargantext.Core.Statistics
Gargantext.Core.Text.Convert
Gargantext.Core.Text.Corpus.API.Arxiv
......@@ -410,6 +411,7 @@ library
, jose
, json-stream
, lens
, lifted-base
, listsafe
, located-base
, logging-effect
......
package.yaml
View file @ d557b58d
......@@ -195,6 +195,7 @@ library:
- jose
- json-stream
- lens
- lifted-base
- listsafe
- located-base
- logging-effect
......
src/Gargantext/API.hs
View file @ d557b58d
......@@ -117,9 +117,9 @@ makeMockApp env = do
blocking <- fireWall req (env ^. menv_firewall)
case blocking of
True -> app req resp
False -> resp ( responseLBS status401 []
False -> resp ( responseLBS status401 []
"Invalid Origin or Host header")
let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
-- { corsOrigins = Just ([env^.settings.allowedOrigin], False)
{ corsOrigins = Nothing -- == /*
......@@ -135,7 +135,7 @@ makeMockApp env = do
--let warpS = Warp.setPort (8008 :: Int) -- (env^.settings.appPort)
-- $ Warp.defaultSettings
--pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
-}
......@@ -149,7 +149,7 @@ makeDevMiddleware mode = do
-- blocking <- fireWall req (env ^. menv_firewall)
-- case blocking of
-- True -> app req resp
-- False -> resp ( responseLBS status401 []
-- False -> resp ( responseLBS status401 []
-- "Invalid Origin or Host header")
--
let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
......
src/Gargantext/API/Admin/Settings.hs
View file @ d557b58d
{-|
{-|
Module : Gargantext.API.Admin.Settings
Description : Settings of the API (Server and Client)
Copyright : (c) CNRS, 2017-Present
......@@ -27,7 +27,7 @@ import Data.Maybe (fromMaybe)
import Data.Pool (Pool, createPool)
import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
import Gargantext.Core.NodeStory
import Gargantext.Prelude.Config (GargConfig(..), {-gc_repofilepath,-} readConfig)
import Gargantext.Prelude.Config ({-GargConfig(..),-} {-gc_repofilepath,-} readConfig)
import Network.HTTP.Client.TLS (newTlsManager)
import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
import Servant.Client (parseBaseUrl)
......@@ -180,7 +180,8 @@ newEnv port file = do
self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port
dbParam <- databaseParameters file
pool <- newPool dbParam
nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
--nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
nodeStory_env <- readNodeStoryEnv pool
scrapers_env <- newJobEnv defaultSettings manager_env
logger <- newStderrLoggerSet defaultBufSize
config_mail <- Mail.readConfig file
......
src/Gargantext/API/Dev.hs
View file @ d557b58d
{-|
Module : Gargantext.API.Dev
Description :
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
......@@ -22,7 +22,7 @@ import Gargantext.API.Prelude
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..), readConfig)
import Gargantext.Prelude.Config (readConfig)
import qualified Gargantext.Prelude.Mail as Mail
import Servant
import System.IO (FilePath)
......@@ -38,8 +38,9 @@ withDevEnv iniPath k = do
newDevEnv = do
cfg <- readConfig iniPath
dbParam <- databaseParameters iniPath
nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
--nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool dbParam
nodeStory_env <- readNodeStoryEnv pool
setts <- devSettings devJwkFile
mail <- Mail.readConfig iniPath
pure $ DevEnv
......@@ -61,7 +62,7 @@ runCmdReplServantErr = runCmdRepl
-- the command.
-- This function is constrained to the DevEnv rather than
-- using HasConnectionPool and HasRepoVar.
runCmdDev :: (Show err) => DevEnv -> Cmd'' DevEnv err a -> IO a
runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
runCmdDev env f =
(either (fail . show) pure =<< runCmd env f)
`finally`
......
src/Gargantext/API/Ngrams.hs
View file @ d557b58d
......@@ -11,7 +11,7 @@ Ngrams API
-- | TODO
get ngrams filtered by NgramsType
add get
add get
-}
......@@ -106,7 +106,7 @@ import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast')
import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Admin.Types.Node (NodeType(..))
import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig)
import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngramsType, ngrams_terms)
import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
......@@ -261,7 +261,9 @@ setListNgrams listId ngramsType ns = do
currentVersion :: HasNodeStory env err m
=> ListId -> m Version
currentVersion listId = do
nls <- getRepo [listId]
--nls <- getRepo [listId]
pool <- view connPool
nls <- liftBase $ getNodeStory pool listId
pure $ nls ^. unNodeStory . at listId . _Just . a_version
......@@ -282,13 +284,16 @@ commitStatePatch :: (HasNodeStory env err m, HasMail env)
=> ListId
-> Versioned NgramsStatePatch'
-> m (Versioned NgramsStatePatch')
commitStatePatch listId (Versioned p_version p) = do
commitStatePatch listId (Versioned _p_version p) = do
-- printDebug "[commitStatePatch]" listId
var <- getNodeStoryVar [listId]
vq' <- liftBase $ modifyMVar var $ \ns -> do
let
a = ns ^. unNodeStory . at listId . _Just
q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
-- apply patches from version p_version to a ^. a_version
-- TODO Check this
--q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
q = mconcat $ a ^. a_history
(p', q') = transformWith ngramsStatePatchConflictResolution p q
a' = a & a_version +~ 1
& a_state %~ act p'
......@@ -808,5 +813,3 @@ listNgramsChangedSince listId ngramsType version
Versioned <$> currentVersion listId <*> pure True
| otherwise =
tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
src/Gargantext/API/Ngrams/Tools.hs
View file @ d557b58d
......@@ -22,13 +22,16 @@ import Data.Hashable (Hashable)
import Data.Set (Set)
import Data.Validity
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (ListType(..), NodeId, ListId)
import Gargantext.Core.Types (ListType(..), NodeId, NodeType(..), ListId)
import Gargantext.Database.Prelude (CmdM, HasConnectionPool(..))
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Prelude
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Gargantext.Core.NodeStory
import qualified Gargantext.Core.NodeStoryFile as NSF
mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
mergeNgramsElement _neOld neNew = neNew
......@@ -193,3 +196,21 @@ getCoocByNgrams' f (Diagonal diag) m =
where ks = HM.keys m
------------------------------------------
migrateFromDirToDb :: (CmdM env err m, HasNodeStory env err m)
=> m ()
migrateFromDirToDb = do
pool <- view connPool
listIds <- liftBase $ getNodesIdWithType pool NodeList
printDebug "[migrateFromDirToDb] listIds" listIds
(NodeStory nls) <- NSF.getRepoReadConfig listIds
printDebug "[migrateFromDirToDb] nls" nls
_ <- mapM (\(nId, a) -> do
n <- liftBase $ nodeExists pool nId
case n of
False -> pure 0
True -> liftBase $ upsertNodeArchive pool nId a
) $ Map.toList nls
--_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
pure ()
src/Gargantext/API/Ngrams/Types.hs
View file @ d557b58d
......@@ -28,7 +28,8 @@ import Data.String (IsString, fromString)
import Data.Swagger hiding (version, patch)
import Data.Text (Text, pack, strip)
import Data.Validity
import Database.PostgreSQL.Simple.FromField (FromField, fromField, ResultError(ConversionFailed), returnError)
import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField, ResultError(ConversionFailed), returnError)
import Database.PostgreSQL.Simple.ToField (ToField, toJSONField, toField)
import GHC.Generics (Generic)
import Gargantext.Core.Text (size)
import Gargantext.Core.Types (ListType(..), ListId, NodeId, TODO)
......@@ -124,19 +125,14 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
------------------------------------------------------------------------
newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text }
deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable, NFData)
instance IsHashable NgramsTerm where
hash (NgramsTerm t) = hash t
instance Monoid NgramsTerm where
mempty = NgramsTerm ""
instance FromJSONKey NgramsTerm where
fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t
instance IsString NgramsTerm where
fromString s = NgramsTerm $ pack s
instance FromField NgramsTerm
where
fromField field mb = do
......@@ -147,6 +143,9 @@ instance FromField NgramsTerm
$ List.intercalate " " [ "cannot parse hyperdata for JSON: "
, show v
]
instance ToField NgramsTerm where
toField (NgramsTerm n) = toField n
data RootParent = RootParent
{ _rp_root :: NgramsTerm
......@@ -448,13 +447,16 @@ instance ToSchema NgramsPatch where
, ("old", nreSch)
, ("new", nreSch)
]
instance Arbitrary NgramsPatch where
arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
, (1, NgramsReplace <$> arbitrary <*> arbitrary)
]
instance Serialise NgramsPatch
instance FromField NgramsPatch where
fromField = fromJSONField
instance ToField NgramsPatch where
toField = toJSONField
instance Serialise (Replace ListType)
instance Serialise ListType
......@@ -512,7 +514,6 @@ instance Action (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepo
instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
applicable p = applicable (p ^. _NgramsPatch)
instance Action NgramsPatch (Maybe NgramsRepoElement) where
act p = act (p ^. _NgramsPatch)
......@@ -524,7 +525,11 @@ instance Serialise (PatchMap NgramsTerm NgramsPatch)
instance FromField NgramsTablePatch
where
fromField = fromField'
fromField = fromJSONField
--fromField = fromField'
instance ToField NgramsTablePatch
where
toField = toJSONField
instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
where
......@@ -751,4 +756,3 @@ instance ToSchema UpdateTableNgramsCharts where
------------------------------------------------------------------------
type NgramsList = (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
src/Gargantext/Core/NodeStory.hs
View file @ d557b58d
......@@ -10,6 +10,30 @@ Portability : POSIX
A Node Story is a Map between NodeId and an Archive (with state,
version and history) for that node.
Couple of words on how this is implemented.
First version used files which stored Archive for each NodeId in a
separate .cbor file.
For performance reasons, it is rewritten to use the DB.
The table `node_stories` contains two columns: `node_id` and
`archive`.
Next, it was observed that `a_history` in `Archive` takes much
space. So a new table was created, `node_story_archive_history` with
columns: `node_id`, `ngrams_type_id`, `patch`. This is because each
history item is in fact a map from `NgramsType` to `NgramsTablePatch`
(see the `NgramsStatePatch'` type).
Moreover, since in ~G.A.Ngrams.commitStatePatch~ we use current state
only, with only recent history items, I concluded that it is not
necessary to load whole history into memory. Instead, it is kept in DB
(history is immutable) and only recent changes are added to
`a_history`. Then that record is cleared whenever `Archive` is saved.
Please note that
TODO:
- remove
- filter
......@@ -17,36 +41,75 @@ TODO:
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.NodeStory where
module Gargantext.Core.NodeStory
( HasNodeStory
, HasNodeStoryEnv
, hasNodeStory
, HasNodeStoryVar
, hasNodeStoryVar
, HasNodeStorySaver
, hasNodeStorySaver
, NodeStory(..)
, NgramsStatePatch'
, NodeListStory
, initNodeListStoryMock
, NodeStoryEnv(..)
, initNodeStory
, nse_getter
, nse_saver
, nse_var
, unNodeStory
, getNodeArchiveHistory
, Archive(..)
, initArchive
, a_history
, a_state
, a_version
, nodeExists
, getNodesIdWithType
, readNodeStoryEnv
, upsertNodeArchive
, getNodeStory )
where
-- import Debug.Trace (traceShow)
import Codec.Serialise (serialise, deserialise)
import Codec.Serialise.Class
import Control.Concurrent (MVar(), withMVar, newMVar, modifyMVar_)
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Control.Lens (makeLenses, Getter, (^.))
import Codec.Serialise.Class
import Control.Arrow (returnA)
import Control.Concurrent (MVar(), withMVar, newMVar, modifyMVar_)
import Control.Exception (catch, throw, SomeException(..))
import Control.Lens (makeLenses, Getter, (^.), (.~), traverse)
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson hiding ((.=), decode)
import Data.ByteString.Char8 (hPutStrLn)
import Data.Map.Strict (Map)
import Data.Maybe (catMaybes, mapMaybe)
import Data.Monoid
import Data.Pool (Pool, withResource)
import Data.Semigroup
import qualified Database.PostgreSQL.Simple as PGS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import GHC.Generics (Generic)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (NodeId)
import Gargantext.Core.Types (NodeId(..), NodeType)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Prelude
import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
import System.IO (FilePath, hClose)
import System.IO.Temp (withTempFile)
import qualified Data.ByteString.Lazy as DBL
import qualified Data.List as List
import Opaleye (Column, DefaultFromField(..), Insert(..), Select, SqlInt4, SqlJsonb, Table, Update(..), (.==), fromPGSFromField, rCount, restrict, runInsert, runSelect, runUpdate, selectTable, sqlInt4, sqlValueJSONB, tableField, updateEasy)
import Opaleye.Internal.Table (Table(..))
import System.IO (stderr)
import qualified Data.Map.Strict as Map
import qualified Data.Map.Strict.Patch as PM
import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
------------------------------------------------------------------------
......@@ -79,183 +142,12 @@ class HasNodeStorySaver env where
hasNodeStorySaver :: Getter env (IO ())
------------------------------------------------------------------------
readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
readNodeStoryEnv nsd = do
mvar <- nodeStoryVar nsd Nothing [0]
saver <- mkNodeStorySaver nsd mvar
pure $ NodeStoryEnv { _nse_var = mvar
, _nse_saver = saver
, _nse_getter = nodeStoryVar nsd (Just mvar) }
------------------------------------------------------------------------
mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
mkNodeStorySaver nsd mvns = mkDebounce settings
where
settings = defaultDebounceSettings
{ debounceAction = withMVar mvns (writeNodeStories nsd)
, debounceFreq = 1 * minute
-- , debounceEdge = trailingEdge -- Trigger on the trailing edge
}
minute = 60 * second
second = 10^(6 :: Int)
nodeStoryVar :: NodeStoryDir
-> Maybe (MVar NodeListStory)
-> [NodeId]
-> IO (MVar NodeListStory)
nodeStoryVar nsd Nothing ni = nodeStoryIncs nsd Nothing ni >>= newMVar
nodeStoryVar nsd (Just mv) ni = do
_ <- modifyMVar_ mv $ \mv' -> (nodeStoryIncs nsd (Just mv') ni)
pure mv
nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
nodeStoryInc nsd (Just ns@(NodeStory nls)) ni = do
case Map.lookup ni nls of
Nothing -> do
(NodeStory nls') <- nodeStoryRead nsd ni
pure $ NodeStory $ Map.union nls nls'
Just _ -> pure ns
nodeStoryInc nsd Nothing ni = nodeStoryRead nsd ni
nodeStoryIncs :: NodeStoryDir
-> Maybe NodeListStory
-> [NodeId]
-> IO NodeListStory
nodeStoryIncs _ Nothing [] = panic "nodeStoryIncs: Empty"
nodeStoryIncs nsd (Just nls) ns = foldM (\m n -> nodeStoryInc nsd (Just m) n) nls ns
nodeStoryIncs nsd Nothing (ni:ns) = do
m <- nodeStoryRead nsd ni
nodeStoryIncs nsd (Just m) ns
nodeStoryDec :: NodeStoryDir
-> NodeListStory
-> NodeId
-> IO NodeListStory
nodeStoryDec nsd ns@(NodeStory nls) ni = do
case Map.lookup ni nls of
Nothing -> do
-- we make sure the corresponding file repo is really removed
_ <- nodeStoryRemove nsd ni
pure ns
Just _ -> do
let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
_ <- nodeStoryRemove nsd ni
pure $ NodeStory ns'
-- | TODO lock
nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
nodeStoryRead nsd ni = do
_repoDir <- createDirectoryIfMissing True nsd
let nsp = nodeStoryPath nsd ni
exists <- doesFileExist nsp
if exists
then deserialise <$> DBL.readFile nsp
else pure (initNodeStory ni)
nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
nodeStoryRemove nsd ni = do
let nsp = nodeStoryPath nsd ni
exists <- doesFileExist nsp
if exists
then removeFile nsp
else pure ()
nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
$ fmap Map.keys
$ fmap _a_state
$ Map.lookup ni
$ _unNodeStory n
------------------------------------------------------------------------
type NodeStoryDir = FilePath
writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
writeNodeStories fp nls = do
_done <- mapM (writeNodeStory fp) $ splitByNode nls
-- printDebug "[writeNodeStories]" done
pure ()
writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
writeNodeStory rdfp (n, ns) = saverAction' rdfp n ns
splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
splitByNode (NodeStory m) =
List.map (\(n,a) -> (n, NodeStory $ Map.singleton n a)) $ Map.toList m
saverAction' :: Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
saverAction' repoDir nId a = do
withTempFile repoDir ((cs $ show nId) <> "-tmp-repo.cbor") $ \fp h -> do
-- printDebug "[repoSaverAction]" fp
DBL.hPut h $ serialise a
hClose h
renameFile fp (nodeStoryPath repoDir nId)
nodeStoryPath :: NodeStoryDir -> NodeId -> FilePath
nodeStoryPath repoDir nId = repoDir <> "/" <> filename
where
filename = "repo" <> "-" <> (cs $ show nId) <> ".cbor"
------------------------------------------------------------------------
-- TODO : repo Migration TODO TESTS
{-
repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
repoToNodeListStory :: NgramsRepo -> NodeListStory
repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
where
s' = ngramsState_migration s
h' = ngramsStatePatch_migration h
ns = List.map (\(n,ns')
-> (n, let hs = fromMaybe [] (Map.lookup n h') in
Archive { _a_version = List.length hs
, _a_state = ns'
, _a_history = hs }
)
) $ Map.toList s'
ngramsState_migration :: NgramsState
-> Map NodeId NgramsState'
ngramsState_migration ns =
Map.fromListWith (Map.union) $
List.concat $
map (\(nt, nTable)
-> map (\(nid, table)
-> (nid, Map.singleton nt table)
) $ Map.toList nTable
) $ Map.toList ns
ngramsStatePatch_migration :: [NgramsStatePatch]
-> Map NodeId [NgramsStatePatch']
ngramsStatePatch_migration np' = Map.fromListWith (<>)
$ List.concat
$ map toPatch np'
where
toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
toPatch p =
List.concat $
map (\(nt, nTable)
-> map (\(nid, table)
-> (nid, [fst $ Patch.singleton nt table])
) $ Patch.toList nTable
) $ Patch.toList p
-}
------------------------------------------------------------------------
{- | Node Story for each NodeType where the Key of the Map is NodeId
TODO : generalize for any NodeType, let's start with NodeList which
is implemented already
-}
data NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
newtype NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
deriving (Generic, Show)
instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
......@@ -263,10 +155,18 @@ instance (ToJSON s, ToJSON p) => ToJSON (NodeStory s p)
instance (Serialise s, Serialise p) => Serialise (NodeStory s p)
data Archive s p = Archive
{ _a_version :: !Version
, _a_state :: !s
, _a_history :: ![p]
{ _a_version :: !Version
, _a_state :: !s
, _a_history :: ![p]
-- first patch in the list is the most recent
-- We use `take` in `commitStatePatch`, that's why.
-- History is immutable, we just insert things on top of existing
-- list.
-- We don't need to store the whole history in memory, this
-- structure holds only recent history, the one that will be
-- inserted to the DB.
}
deriving (Generic, Show)
......@@ -278,18 +178,24 @@ 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
instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
(<>) (Archive { _a_history = p }) (Archive { _a_version = v'
, _a_state = s'
, _a_history = p'}) =
, _a_history = p' }) =
Archive { _a_version = v'
, _a_state = s'
, _a_history = p' <> p }
instance Monoid (Archive NgramsState' NgramsStatePatch') where
instance (Monoid s, Semigroup p) => Monoid (Archive s p) where
mempty = Archive { _a_version = 0
, _a_state = mempty
, _a_history = [] }
......@@ -302,13 +208,11 @@ instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
toEncoding = genericToEncoding $ unPrefix "_a_"
------------------------------------------------------------------------
initNodeStory :: Monoid s => NodeId -> NodeStory s p
initNodeStory :: (Monoid s, Semigroup p) => NodeId -> NodeStory s p
initNodeStory ni = NodeStory $ Map.singleton ni initArchive
initArchive :: Monoid s => Archive s p
initArchive = Archive { _a_version = 0
, _a_state = mempty
, _a_history = [] }
initArchive :: (Monoid s, Semigroup p) => Archive s p
initArchive = mempty
initNodeListStoryMock :: NodeListStory
initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
......@@ -331,3 +235,243 @@ initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
makeLenses ''NodeStoryEnv
makeLenses ''NodeStory
makeLenses ''Archive
-----------------------------------------
data NodeStoryPoly a b = NodeStoryDB { node_id :: a
, archive :: b }
deriving (Eq)
type ArchiveQ = Archive NgramsState' NgramsStatePatch'
type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
$(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
runPGSExecuteMany :: (PGS.ToRow q) => Pool PGS.Connection -> PGS.Query -> [q] -> IO Int64
runPGSExecuteMany pool qs a = withResource pool $ \c -> catch (PGS.executeMany c qs a) (printError c)
where
printError _c (SomeException e) = do
--q' <- PGS.formatQuery c qs a
--hPutStrLn stderr q'
throw (SomeException e)
runPGSQuery :: (PGS.FromRow r, PGS.ToRow q) => Pool PGS.Connection -> PGS.Query -> q -> IO [r]
runPGSQuery pool q a = withResource pool $ \c -> catch (PGS.query c q a) (printError c)
where
printError c (SomeException e) = do
q' <- PGS.formatQuery c q a
hPutStrLn stderr q'
throw (SomeException e)
nodeExists :: Pool PGS.Connection -> NodeId -> IO Bool
nodeExists pool nId = (== [PGS.Only True])
<$> runPGSQuery pool [sql|SELECT true FROM nodes WHERE id = ? AND ? |] (nId, True)
getNodesIdWithType :: Pool PGS.Connection -> NodeType -> IO [NodeId]
getNodesIdWithType pool nt = do
ns <- runPGSQuery pool query (nodeTypeId nt, True)
pure $ map (\(PGS.Only nId) -> NodeId nId) ns
where
query :: PGS.Query
query = [sql|SELECT id FROM nodes WHERE typename = ? AND ? |]
nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
nodeStoryTable =
Table "node_stories"
( pNodeStory NodeStoryDB { node_id = tableField "node_id"
, archive = tableField "archive" } )
nodeStorySelect :: Select NodeStoryRead
nodeStorySelect = selectTable nodeStoryTable
-- TODO Check ordering, "first patch in the _a_history list is the most recent"
getNodeArchiveHistory :: Pool PGS.Connection -> NodeId -> IO [NgramsStatePatch']
getNodeArchiveHistory pool nodeId = do
as <- runPGSQuery pool query (nodeId, True)
let asTuples = mapMaybe (\(ngrams_type_id, ngrams, patch) -> (\ntId -> (ntId, ngrams, patch)) <$> (TableNgrams.fromNgramsTypeId ngrams_type_id)) as
pure $ (\(ntId, terms, patch) -> fst $ PM.singleton ntId (NgramsTablePatch $ fst $ PM.singleton terms patch)) <$> asTuples
where
query :: PGS.Query
query = [sql|SELECT ngrams_type_id, terms, patch
FROM node_story_archive_history
JOIN ngrams ON ngrams.id = ngrams_id
WHERE node_id = ? AND ? |]
insertNodeArchiveHistory :: Pool PGS.Connection -> NodeId -> [NgramsStatePatch'] -> IO ()
insertNodeArchiveHistory _ _ [] = pure ()
insertNodeArchiveHistory pool nodeId (h:hs) = do
let tuples = mconcat $ (\(nType, (NgramsTablePatch patch)) ->
(\(term, p) ->
(nodeId, TableNgrams.ngramsTypeId nType, term, p)) <$> PM.toList patch) <$> PM.toList h :: [(NodeId, TableNgrams.NgramsTypeId, NgramsTerm, NgramsPatch)]
tuplesM <- mapM (\(nId, nTypeId, term, patch) -> do
ngrams <- runPGSQuery pool ngramsQuery (term, True)
pure $ (\(PGS.Only termId) -> (nId, nTypeId, termId, term, patch)) <$> (headMay ngrams)
) tuples :: IO [Maybe (NodeId, TableNgrams.NgramsTypeId, Int, NgramsTerm, NgramsPatch)]
_ <- runPGSExecuteMany pool query $ ((\(nId, nTypeId, termId, _term, patch) -> (nId, nTypeId, termId, patch)) <$> (catMaybes tuplesM))
_ <- insertNodeArchiveHistory pool nodeId hs
pure ()
where
ngramsQuery :: PGS.Query
ngramsQuery = [sql| SELECT id FROM ngrams WHERE terms = ? AND ? |]
query :: PGS.Query
query = [sql| INSERT INTO node_story_archive_history(node_id, ngrams_type_id, ngrams_id, patch) VALUES (?, ?, ?, ?) |]
getNodeStory :: Pool PGS.Connection -> NodeId -> IO NodeListStory
getNodeStory pool (NodeId nodeId) = do
res <- withResource pool $ \c -> runSelect c query :: IO [NodeStoryPoly NodeId ArchiveQ]
withArchive <- mapM (\(NodeStoryDB { node_id = nId, archive = Archive { .. } }) -> do
--a <- getNodeArchiveHistory pool nId
let a = [] :: [NgramsStatePatch']
-- Don't read whole history. Only state is needed and most recent changes.
pure (nId, Archive { _a_history = a, .. })) res
pure $ NodeStory $ Map.fromListWith (<>) withArchive
--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 :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
insertNodeArchive pool nodeId@(NodeId nId) (Archive {..}) = do
ret <- withResource pool $ \c -> runInsert c insert
-- NOTE: It is assumed that the most recent change is the first in the
-- list, so we save these in reverse order
insertNodeArchiveHistory pool nodeId $ reverse _a_history
pure ret
where
emptyHistory = [] :: [NgramsStatePatch']
insert = Insert { iTable = nodeStoryTable
, iRows = [NodeStoryDB { node_id = sqlInt4 nId
, archive = sqlValueJSONB $ Archive { _a_history = emptyHistory
, .. } }]
, iReturning = rCount
, iOnConflict = Nothing }
updateNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
updateNodeArchive pool nodeId@(NodeId nId) (Archive {..}) = do
ret <- withResource pool $ \c -> runUpdate c update
-- NOTE: It is assumed that the most recent change is the first in the
-- list, so we save these in reverse order
insertNodeArchiveHistory pool nodeId $ reverse _a_history
pure ret
where
emptyHistory = [] :: [NgramsStatePatch']
update = Update { uTable = nodeStoryTable
, uUpdateWith = updateEasy (\(NodeStoryDB { node_id }) -> NodeStoryDB { archive = sqlValueJSONB $ Archive { _a_history = emptyHistory
, ..}
, .. })
, uWhere = (\row -> node_id row .== sqlInt4 nId)
, uReturning = rCount }
-- nodeStoryRemove :: Pool PGS.Connection -> NodeId -> IO Int64
-- nodeStoryRemove pool (NodeId nId) = withResource pool $ \c -> runDelete c delete
-- where
-- delete = Delete { dTable = nodeStoryTable
-- , dWhere = (\row -> node_id row .== sqlInt4 nId)
-- , dReturning = rCount }
upsertNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
upsertNodeArchive pool nId a = do
(NodeStory m) <- getNodeStory pool nId
case Map.lookup nId m of
Nothing -> insertNodeArchive pool nId a
Just _ -> updateNodeArchive pool nId a
writeNodeStories :: Pool PGS.Connection -> NodeListStory -> IO ()
writeNodeStories pool (NodeStory nls) = do
_ <- mapM (\(nId, a) -> upsertNodeArchive pool nId a) $ Map.toList nls
pure ()
-- | Returns a `NodeListStory`, updating the given one for given `NodeId`
nodeStoryInc :: Pool PGS.Connection -> Maybe NodeListStory -> NodeId -> IO NodeListStory
nodeStoryInc pool Nothing nId = getNodeStory pool nId
nodeStoryInc pool (Just ns@(NodeStory nls)) nId = do
case Map.lookup nId nls of
Nothing -> do
(NodeStory nls') <- getNodeStory pool nId
pure $ NodeStory $ Map.union nls nls'
Just _ -> pure ns
nodeStoryIncs :: Pool PGS.Connection -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
nodeStoryIncs _ Nothing [] = pure $ NodeStory $ Map.empty
nodeStoryIncs pool (Just nls) ns = foldM (\m n -> nodeStoryInc pool (Just m) n) nls ns
nodeStoryIncs pool Nothing (ni:ns) = do
m <- getNodeStory pool ni
nodeStoryIncs pool (Just m) ns
-- nodeStoryDec :: Pool PGS.Connection -> NodeListStory -> NodeId -> IO NodeListStory
-- nodeStoryDec pool ns@(NodeStory nls) ni = do
-- case Map.lookup ni nls of
-- Nothing -> do
-- _ <- nodeStoryRemove pool ni
-- pure ns
-- Just _ -> do
-- let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
-- _ <- nodeStoryRemove pool ni
-- pure $ NodeStory ns'
------------------------------------
readNodeStoryEnv :: Pool PGS.Connection -> IO NodeStoryEnv
readNodeStoryEnv pool = do
mvar <- nodeStoryVar pool Nothing []
saver <- mkNodeStorySaver pool mvar
-- let saver = modifyMVar_ mvar $ \mv -> do
-- writeNodeStories pool mv
-- printDebug "[readNodeStoryEnv] saver" mv
-- let mv' = clearHistory mv
-- printDebug "[readNodeStoryEnv] saver, cleared" mv'
-- return mv'
pure $ NodeStoryEnv { _nse_var = mvar
, _nse_saver = saver
, _nse_getter = nodeStoryVar pool (Just mvar) }
nodeStoryVar :: Pool PGS.Connection -> Maybe (MVar NodeListStory) -> [NodeId] -> IO (MVar NodeListStory)
nodeStoryVar pool Nothing nIds = do
state <- nodeStoryIncs pool Nothing nIds
newMVar state
nodeStoryVar pool (Just mv) nIds = do
_ <- modifyMVar_ mv $ \nsl -> (nodeStoryIncs pool (Just nsl) nIds)
pure mv
-- Debounce is useful since it could delay the saving to some later
-- time, asynchronously and we keep operating on memory only.
mkNodeStorySaver :: Pool PGS.Connection -> MVar NodeListStory -> IO (IO ())
mkNodeStorySaver pool mvns = mkDebounce settings
where
settings = defaultDebounceSettings
{ debounceAction = do
withMVar mvns (\ns -> writeNodeStories pool ns)
withMVar mvns (\ns -> printDebug "[mkNodeStorySaver] debounce nodestory" ns)
modifyMVar_ mvns $ \ns -> pure $ clearHistory ns
, debounceFreq = 1*minute
}
minute = 60*second
second = 10^(6 :: Int)
clearHistory :: NodeListStory -> NodeListStory
clearHistory (NodeStory ns) = NodeStory $ ns & (traverse . a_history) .~ emptyHistory
where
emptyHistory = [] :: [NgramsStatePatch']
-- mkNodeStorySaver :: MVar NodeListStory -> Cmd err (Cmd err ())
-- mkNodeStorySaver mvns = mkDebounce settings
-- where
-- settings = defaultDebounceSettings
-- { debounceAction = withMVar mvns (\ns -> writeNodeStories ns)
-- , debounceFreq = 1 * minute
-- -- , debounceEdge = trailingEdge -- Trigger on the trailing edge
-- }
-- minute = 60 * second
-- second = 10^(6 :: Int)
-----------------------------------------
src/Gargantext/Core/NodeStoryFile.hs 0 → 100644
View file @ d557b58d
{- NOTE This is legacy code. It keeps node stories in a directory
repo. We now have migrated to the DB. However this code is needed to
make the migration (see Gargantext.API.Ngrams.Tools) -}
module Gargantext.Core.NodeStoryFile where
import Control.Lens (view)
import Control.Monad (foldM)
import Codec.Serialise (serialise, deserialise)
import Codec.Serialise.Class
import Control.Concurrent (MVar(), modifyMVar_, newMVar, readMVar, withMVar)
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Gargantext.Core.NodeStory hiding (readNodeStoryEnv)
import Gargantext.Core.Types (ListId, NodeId(..))
import Gargantext.Database.Prelude (CmdM, hasConfig)
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_repofilepath)
import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
import System.IO (FilePath, hClose)
import System.IO.Temp (withTempFile)
import qualified Data.ByteString.Lazy as DBL
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
getRepo :: HasNodeStory env err m
=> [ListId] -> m NodeListStory
getRepo listIds = do
g <- getNodeListStory
liftBase $ do
v <- g listIds
readMVar v
-- v <- liftBase $ f listIds
-- v' <- liftBase $ readMVar v
-- pure $ v'
getRepoReadConfig :: (CmdM env err m)
=> [ListId] -> m NodeListStory
getRepoReadConfig listIds = do
repoFP <- view $ hasConfig . gc_repofilepath
env <- liftBase $ readNodeStoryEnv repoFP
let g = view nse_getter env
liftBase $ do
v <- g listIds
readMVar v
getNodeListStory :: HasNodeStory env err m
=> m ([NodeId] -> IO (MVar NodeListStory))
getNodeListStory = do
env <- view hasNodeStory
pure $ view nse_getter env
readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
readNodeStoryEnv nsd = do
mvar <- nodeStoryVar nsd Nothing []
saver <- mkNodeStorySaver nsd mvar
pure $ NodeStoryEnv { _nse_var = mvar
, _nse_saver = saver
, _nse_getter = nodeStoryVar nsd (Just mvar) }
------------------------------------------------------------------------
mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
mkNodeStorySaver nsd mvns = mkDebounce settings
where
settings = defaultDebounceSettings
{ debounceAction = withMVar mvns (writeNodeStories nsd)
, debounceFreq = 1 * minute
-- , debounceEdge = trailingEdge -- Trigger on the trailing edge
}
minute = 60 * second
second = 10^(6 :: Int)
nodeStoryVar :: NodeStoryDir
-> Maybe (MVar NodeListStory)
-> [NodeId]
-> IO (MVar NodeListStory)
nodeStoryVar nsd Nothing ni = nodeStoryIncs nsd Nothing ni >>= newMVar
nodeStoryVar nsd (Just mv) ni = do
_ <- modifyMVar_ mv $ \mv' -> (nodeStoryIncs nsd (Just mv') ni)
pure mv
nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
nodeStoryInc nsd (Just ns@(NodeStory nls)) ni = do
case Map.lookup ni nls of
Nothing -> do
(NodeStory nls') <- nodeStoryRead nsd ni
pure $ NodeStory $ Map.union nls nls'
Just _ -> pure ns
nodeStoryInc nsd Nothing ni = nodeStoryRead nsd ni
nodeStoryIncs :: NodeStoryDir
-> Maybe NodeListStory
-> [NodeId]
-> IO NodeListStory
nodeStoryIncs _ Nothing [] = pure $ NodeStory $ Map.empty
nodeStoryIncs nsd (Just nls) ns = foldM (\m n -> nodeStoryInc nsd (Just m) n) nls ns
nodeStoryIncs nsd Nothing (ni:ns) = do
m <- nodeStoryRead nsd ni
nodeStoryIncs nsd (Just m) ns
nodeStoryDec :: NodeStoryDir
-> NodeListStory
-> NodeId
-> IO NodeListStory
nodeStoryDec nsd ns@(NodeStory nls) ni = do
case Map.lookup ni nls of
Nothing -> do
-- we make sure the corresponding file repo is really removed
_ <- nodeStoryRemove nsd ni
pure ns
Just _ -> do
let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
_ <- nodeStoryRemove nsd ni
pure $ NodeStory ns'
-- | TODO lock
nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
nodeStoryRead nsd ni = do
_repoDir <- createDirectoryIfMissing True nsd
let nsp = nodeStoryPath nsd ni
exists <- doesFileExist nsp
if exists
then deserialise <$> DBL.readFile nsp
else pure (initNodeStory ni)
nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
nodeStoryRemove nsd ni = do
let nsp = nodeStoryPath nsd ni
exists <- doesFileExist nsp
if exists
then removeFile nsp
else pure ()
nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
$ fmap Map.keys
$ fmap _a_state
$ Map.lookup ni
$ _unNodeStory n
------------------------------------------------------------------------
type NodeStoryDir = FilePath
writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
writeNodeStories fp nls = do
_done <- mapM (writeNodeStory fp) $ splitByNode nls
-- printDebug "[writeNodeStories]" done
pure ()
writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
writeNodeStory rdfp (n, ns) = saverAction' rdfp n ns
splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
splitByNode (NodeStory m) =
List.map (\(n,a) -> (n, NodeStory $ Map.singleton n a)) $ Map.toList m
saverAction' :: Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
saverAction' repoDir nId a = do
withTempFile repoDir ((cs $ show nId) <> "-tmp-repo.cbor") $ \fp h -> do
-- printDebug "[repoSaverAction]" fp
DBL.hPut h $ serialise a
hClose h
renameFile fp (nodeStoryPath repoDir nId)
nodeStoryPath :: NodeStoryDir -> NodeId -> FilePath
nodeStoryPath repoDir nId = repoDir <> "/" <> filename
where
filename = "repo" <> "-" <> (cs $ show nId) <> ".cbor"
------------------------------------------------------------------------
-- TODO : repo Migration TODO TESTS
{-
repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
repoToNodeListStory :: NgramsRepo -> NodeListStory
repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
where
s' = ngramsState_migration s
h' = ngramsStatePatch_migration h
ns = List.map (\(n,ns')
-> (n, let hs = fromMaybe [] (Map.lookup n h') in
Archive { _a_version = List.length hs
, _a_state = ns'
, _a_history = hs }
)
) $ Map.toList s'
ngramsState_migration :: NgramsState
-> Map NodeId NgramsState'
ngramsState_migration ns =
Map.fromListWith (Map.union) $
List.concat $
map (\(nt, nTable)
-> map (\(nid, table)
-> (nid, Map.singleton nt table)
) $ Map.toList nTable
) $ Map.toList ns
ngramsStatePatch_migration :: [NgramsStatePatch]
-> Map NodeId [NgramsStatePatch']
ngramsStatePatch_migration np' = Map.fromListWith (<>)
$ List.concat
$ map toPatch np'
where
toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
toPatch p =
List.concat $
map (\(nt, nTable)
-> map (\(nid, table)
-> (nid, [fst $ Patch.singleton nt table])
) $ Patch.toList nTable
) $ Patch.toList p
-}
src/Gargantext/Core/Text/List/Social/History.hs
View file @ d557b58d
......@@ -68,5 +68,3 @@ history' types lists = (Map.map (Map.unionsWith (<>)))
-> Map NgramsType [HashMap NgramsTerm NgramsPatch]
toMap m = Map.map (cons . unNgramsTablePatch)
$ unPatchMapToMap m
src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs
View file @ d557b58d
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ViewPatterns #-}
module Gargantext.Core.Viz.Phylo.Legacy.LegacyMain
......
src/Gargantext/Database/Action/Flow/List.hs
View file @ d557b58d
......@@ -210,4 +210,3 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
& unNodeStory . at listId . _Just . a_history %~ (p :)
& unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
saveNodeStory
src/Gargantext/Database/Query/Table/Node.hs
View file @ d557b58d
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment