[sqlite] replace putText with logLocM

Also, no need for `liftBase` in `getCorpusSQLite`.
parent 3e49fe87
Pipeline #7509 passed with stages
in 39 minutes and 56 seconds
...@@ -87,13 +87,14 @@ getCorpus cId = Named.CorpusExportAPI { ...@@ -87,13 +87,14 @@ getCorpus cId = Named.CorpusExportAPI {
, _c_hash = hash $ List.map DocumentExport._d_hash $ Map.elems r } , _c_hash = hash $ List.map DocumentExport._d_hash $ Map.elems r }
getCorpusSQLite :: (CES.MonadMask m, IsGargServer env err m) getCorpusSQLite :: ( CES.MonadMask m
=> CorpusId , IsGargServer env err m)
-> Maybe ListId => CorpusId
-> m (Headers '[Header "Content-Disposition" Text] CorpusSQLite) -> Maybe ListId
-> m (Headers '[Header "Content-Disposition" Text] CorpusSQLite)
getCorpusSQLite cId lId = do getCorpusSQLite cId lId = do
corpusSQLiteData <- mkCorpusSQLiteData cId lId corpusSQLiteData <- mkCorpusSQLiteData cId lId
corpusSQLite <- liftBase $ mkCorpusSQLite corpusSQLiteData corpusSQLite <- mkCorpusSQLite corpusSQLiteData
pure $ addHeader ("attachment; filename=GarganText_corpus-" <> pack (show cId) <> ".sqlite") pure $ addHeader ("attachment; filename=GarganText_corpus-" <> pack (show cId) <> ".sqlite")
$ corpusSQLite $ corpusSQLite
......
...@@ -8,6 +8,7 @@ Stability : experimental ...@@ -8,6 +8,7 @@ Stability : experimental
Portability : POSIX Portability : POSIX
-} -}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Gargantext.API.Node.Corpus.Export.Utils module Gargantext.API.Node.Corpus.Export.Utils
...@@ -46,6 +47,7 @@ import Gargantext.Database.Query.Table.NodeContext (selectDocNodes) ...@@ -46,6 +47,7 @@ import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername) import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.System.Logging (logLocM, LogLevel(..), MonadLogger)
import Paths_gargantext qualified as PG -- cabal magic build module import Paths_gargantext qualified as PG -- cabal magic build module
import Prelude qualified import Prelude qualified
import System.Directory (removeDirectoryRecursive) import System.Directory (removeDirectoryRecursive)
...@@ -122,57 +124,58 @@ mkCorpusSQLiteData cId lId = do ...@@ -122,57 +124,58 @@ mkCorpusSQLiteData cId lId = do
mkCorpusSQLite :: ( CES.MonadMask m mkCorpusSQLite :: ( CES.MonadMask m
, MonadBase IO m ) , MonadBase IO m
, MonadLogger m )
=> CorpusSQLiteData => CorpusSQLiteData
-> m CorpusSQLite -> m CorpusSQLite
mkCorpusSQLite (CorpusSQLiteData { .. }) = withTempSQLiteDir $ \(fp, _fname, fpath) -> liftBase $ do mkCorpusSQLite (CorpusSQLiteData { .. }) = withTempSQLiteDir $ \(fp, _fname, fpath) -> do
putText $ "[mkCorpusSQLite] listId: " <> show _csd_lId $(logLocM) DEBUG $ "listId: " <> show _csd_lId
putText $ "[mkCorpusSQLite] fp: " <> show fp $(logLocM) DEBUG $ "fp: " <> show fp
liftBase $ do
S.withConnection fpath $ \conn -> do S.withConnection fpath $ \conn -> do
-- better performance -- better performance
-- https://kerkour.com/sqlite-for-servers -- https://kerkour.com/sqlite-for-servers
S.execute_ conn "PRAGMA journal_mode = WAL" S.execute_ conn "PRAGMA journal_mode = WAL"
S.execute_ conn "CREATE TABLE info (key, value);" S.execute_ conn "CREATE TABLE info (key, value);"
S.execute conn "INSERT INTO info (key, value) VALUES ('gargVersion', ?)" (S.Only $ showVersion _csd_version) S.execute conn "INSERT INTO info (key, value) VALUES ('gargVersion', ?)" (S.Only $ showVersion _csd_version)
S.execute conn "INSERT INTO info (key, value) VALUES ('corpusId', ?)" (S.Only $ unNodeId _csd_cId) S.execute conn "INSERT INTO info (key, value) VALUES ('corpusId', ?)" (S.Only $ unNodeId _csd_cId)
S.execute conn "INSERT INTO info (key, value) VALUES ('listId', ?)" (S.Only $ unNodeId _csd_lId) S.execute conn "INSERT INTO info (key, value) VALUES ('listId', ?)" (S.Only $ unNodeId _csd_lId)
S.execute conn "INSERT INTO info (key, value) VALUES ('created', datetime(?))" (S.Only $ iso8601Show _csd_created) S.execute conn "INSERT INTO info (key, value) VALUES ('created', datetime(?))" (S.Only $ iso8601Show _csd_created)
S.execute_ conn "CREATE TABLE corpus (id, name, hash, parent_id, hyperdata)" S.execute_ conn "CREATE TABLE corpus (id, name, hash, parent_id, hyperdata)"
S.execute conn "INSERT INTO corpus (id, name, hash, parent_id, hyperdata) VALUES (?, ?, ?, ?, ?)" S.execute conn "INSERT INTO corpus (id, name, hash, parent_id, hyperdata) VALUES (?, ?, ?, ?, ?)"
( unNodeId _csd_cId ( unNodeId _csd_cId
, _csd_corpus_name , _csd_corpus_name
, _csd_corpus_hash , _csd_corpus_hash
, unNodeId <$> _csd_corpus_parent , unNodeId <$> _csd_corpus_parent
, Aeson.encode _csd_corpus_hyperdata ) , Aeson.encode _csd_corpus_hyperdata )
S.execute_ conn "CREATE TABLE lists (id, name, parent_id, hyperdata)" S.execute_ conn "CREATE TABLE lists (id, name, parent_id, hyperdata)"
S.execute conn "INSERT INTO lists (id, name, parent_id, hyperdata) VALUES (?, ?, ?, ?)" S.execute conn "INSERT INTO lists (id, name, parent_id, hyperdata) VALUES (?, ?, ?, ?)"
( unNodeId _csd_lId ( unNodeId _csd_lId
, _csd_list_name , _csd_list_name
, unNodeId <$> _csd_list_parent , unNodeId <$> _csd_list_parent
, Aeson.encode _csd_list_hyperdata ) , Aeson.encode _csd_list_hyperdata )
S.execute_ conn "CREATE TABLE ngrams (context_id, terms, type_)" S.execute_ conn "CREATE TABLE ngrams (context_id, terms, type_)"
let insertTerms ngs type_ = do let insertTerms ngs type_ = do
let ngs' = concatMap (\(ctxId, ngrams) -> (\n -> (_ContextId ctxId, unNgramsTerm n, type_)) <$> Set.toList ngrams) (Map.toList ngs) let ngs' = concatMap (\(ctxId, ngrams) -> (\n -> (_ContextId ctxId, unNgramsTerm n, type_)) <$> Set.toList ngrams) (Map.toList ngs)
S.executeMany conn "INSERT INTO ngrams (context_id, terms, type_) VALUES (?, ?, ?)" ngs' S.executeMany conn "INSERT INTO ngrams (context_id, terms, type_) VALUES (?, ?, ?)" ngs'
insertTerms _csd_map_context_ngrams ("map" :: Text) insertTerms _csd_map_context_ngrams ("map" :: Text)
insertTerms _csd_stop_context_ngrams ("stop" :: Text) insertTerms _csd_stop_context_ngrams ("stop" :: Text)
insertTerms _csd_candidate_context_ngrams ("candidate" :: Text) insertTerms _csd_candidate_context_ngrams ("candidate" :: Text)
S.execute_ conn "CREATE TABLE documents (context_id, name, date, hyperdata)" S.execute_ conn "CREATE TABLE documents (context_id, name, date, hyperdata)"
S.executeMany conn "INSERT INTO documents (context_id, name, date, hyperdata) VALUES (?, ?, date(?), ?)" S.executeMany conn "INSERT INTO documents (context_id, name, date, hyperdata) VALUES (?, ?, date(?), ?)"
((\(ctxId, ctxName, ctxDate, ctxHyperdata) -> ( unNodeId ctxId ((\(ctxId, ctxName, ctxDate, ctxHyperdata) -> ( unNodeId ctxId
, ctxName , ctxName
, iso8601Show ctxDate , iso8601Show ctxDate
, Aeson.encode ctxHyperdata )) <$> _csd_contexts) , Aeson.encode ctxHyperdata )) <$> _csd_contexts)
bsl <- BSL.readFile fpath bsl <- BSL.readFile fpath
pure $ CorpusSQLite { _cs_bs = bsl } pure $ CorpusSQLite { _cs_bs = bsl }
readCorpusSQLite :: ( CES.MonadMask m readCorpusSQLite :: ( CES.MonadMask m
......
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