Skip to content

Commit f6e4649

Browse files
tweag-ev-aktweag-ev-ak
committed
Add storage with sqlite
1 parent 0270d93 commit f6e4649

File tree

9 files changed

+198
-30
lines changed

9 files changed

+198
-30
lines changed

‎app/App.hs‎

Lines changed: 19 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ import PSR.Chain
1515
import PSR.ConfigMap qualified as CM
1616
import PSR.ContextBuilder
1717
import PSR.Streaming
18+
import PSR.Storage.SQLite
1819
import Streamly.Data.Fold.Prelude qualified as Fold
1920
import Streamly.Data.Stream.Prelude qualified as Stream
2021
import System.Exit (exitFailure)
@@ -38,21 +39,22 @@ main = do
3839
-- TODO: Use a logging interface instead of using putStrLn.
3940
putStrLn "Started..."
4041

41-
withAsync (HTTP.run httpServerPort) $ \serverAsync -> do
42-
link serverAsync
42+
withSqliteStorage sqlitePath $ \storage ->
43+
withAsync (HTTP.run storage httpServerPort) $ \serverAsync -> do
44+
link serverAsync
4345

44-
let confPolicyMap = Map.fromList [(CM.script_hash x, x) | x <- scripts]
45-
conn = mkLocalNodeConnectInfo networkId socketPath
46-
streamChainSyncEvents conn points
47-
& Stream.filter (not . isByron)
48-
& fmap getEventTransactions
49-
& Stream.postscanl trackPreviousChainPoint
50-
-- TODO: Try to replace "concatMap" with "unfoldEach".
51-
& Stream.concatMap (Stream.fromList . (\(a, b) -> (a,) <$> b))
52-
& Stream.mapM (mkContext1 conn . uncurry mkContext0)
53-
& Stream.filter
54-
( \ctx1@Context1{..} ->
55-
not . Map.null . Map.restrictKeys confPolicyMap $
56-
Set.union (getMintPolicies context0) (getSpendPolicies ctx1)
57-
)
58-
& Stream.fold (Fold.drainMapM print)
46+
let confPolicyMap = Map.fromList [(CM.script_hash x, x) | x <- scripts]
47+
conn = mkLocalNodeConnectInfo networkId socketPath
48+
streamChainSyncEvents conn points
49+
& Stream.filter (not . isByron)
50+
& fmap getEventTransactions
51+
& Stream.postscanl trackPreviousChainPoint
52+
-- TODO: Try to replace "concatMap" with "unfoldEach".
53+
& Stream.concatMap (Stream.fromList . (\(a, b) -> (a,) <$> b))
54+
& Stream.mapM (mkContext1 conn . uncurry mkContext0)
55+
& Stream.filter
56+
( \ctx1@Context1{..} ->
57+
not . Map.null . Map.restrictKeys confPolicyMap $
58+
Set.union (getMintPolicies context0) (getSpendPolicies ctx1)
59+
)
60+
& Stream.fold (Fold.drainMapM print)

‎app/Options.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ data Options = Options
1919
, networkId :: NetworkId
2020
, scriptYaml :: FilePath
2121
, httpServerPort :: Port
22+
, sqlitePath :: FilePath
2223
}
2324
deriving (Show, Eq)
2425

@@ -29,6 +30,7 @@ parseOptions =
2930
<*> optNetworkId
3031
<*> optScriptYaml
3132
<*> optHTTPServerPort
33+
<*> optSqlitePath
3234
where
3335
optSocketPath =
3436
File
@@ -61,6 +63,13 @@ parseOptions =
6163
<> help "Port of the http server"
6264
<> value 8080
6365
)
66+
optSqlitePath =
67+
strOption
68+
( long "sqlite-path"
69+
<> metavar "SQLITE_PATH"
70+
<> help "Path to sqlite database"
71+
<> value "psr.db"
72+
)
6473

6574
psrOpts :: ParserInfo Options
6675
psrOpts =

‎lib/Lib.hs‎

Lines changed: 0 additions & 5 deletions
This file was deleted.

‎lib/PSR/HTTP/API.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
module PSR.HTTP.API
22
( ServerAPI
3+
, EventType(..)
34
, FilterQueryParams(..)
45
) where
56

@@ -43,6 +44,7 @@ data FilterQueryParams = FilterQueryParams
4344
, _filterQueryParam_slot_end :: (Maybe Integer)
4445
, _filterQueryParam_limit :: (Maybe Integer)
4546
, _filterQueryParam_offset :: (Maybe Integer)
47+
, _filterQueryParam_name :: (Maybe Text)
4648
} deriving (Generic)
4749

4850
type ServerAPI

‎lib/PSR/HTTP/Server.hs‎

Lines changed: 14 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,11 @@
1-
module PSR.HTTP.Server (
2-
run
1+
module PSR.HTTP.Server
2+
( run
33
) where
44

55
import PSR.HTTP.API
6+
import PSR.Storage.Interface (Storage(..))
67

8+
import Control.Monad.IO.Class (liftIO)
79
import Data.Default (def)
810
import Servant
911
import Servant.Server.Generic ()
@@ -16,16 +18,20 @@ import Prometheus.Metric.GHC (ghcMetrics)
1618
serverApi :: Proxy ServerAPI
1719
serverApi = Proxy
1820

19-
server :: Server ServerAPI
20-
server = eventsH
21+
server :: Storage -> Server ServerAPI
22+
server Storage{..} = eventsH
2123
where
2224
eventsH params = (eventsHandler params Nothing) :<|> (eventsHandler params . Just)
2325

24-
eventsHandler FilterQueryParams{} _mName = do
26+
eventsHandler filterParams' mName = do
27+
-- The capture parameter `name` has a higher priority over the query param
28+
let nameFilterParameter = maybe (_filterQueryParam_name filterParams') Just mName
29+
let filterParams = filterParams' { _filterQueryParam_name = nameFilterParameter }
30+
_events <- liftIO $ getEvents filterParams
2531
pure []
2632

27-
run :: Warp.Port -> IO ()
28-
run port = do
33+
run :: Storage -> Warp.Port -> IO ()
34+
run storage port = do
2935
_ <- register ghcMetrics
3036

31-
Warp.run port (prometheus def $ serve serverApi server)
37+
Warp.run port (prometheus def $ serve serverApi (server storage))

‎lib/PSR/Storage/Interface.hs‎

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,38 @@
1+
module PSR.Storage.Interface
2+
( Event(..)
3+
, ExecutionEventPayload(..)
4+
, EventType(..)
5+
, Storage(..)
6+
, FilterQueryParams(..)
7+
) where
8+
9+
import Data.Text (Text)
10+
11+
import PSR.HTTP.API (FilterQueryParams(..), EventType(..))
12+
13+
import Cardano.Api (
14+
BlockHeader,
15+
ScriptHash,
16+
TxId,
17+
)
18+
19+
data Event = Event
20+
{ eventType :: EventType
21+
}
22+
23+
data ExecutionEventPayload = ExecutionEventPayload
24+
{ blockHeader :: BlockHeader
25+
, transactionHash :: TxId
26+
, scriptHash :: ScriptHash
27+
, scriptName :: Maybe Text
28+
, trace :: Text
29+
}
30+
31+
data Storage = Storage
32+
{ addExecutionEvent :: ExecutionEventPayload -> IO ()
33+
, addCancellationEvent :: BlockHeader -> ScriptHash -> IO ()
34+
, addSelectionEvent :: BlockHeader -> IO ()
35+
, getEvents :: FilterQueryParams -> IO [Event]
36+
}
37+
38+

‎lib/PSR/Storage/SQLite.hs‎

Lines changed: 110 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,110 @@
1+
{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+
module PSR.Storage.SQLite where
4+
5+
import PSR.Storage.Interface
6+
7+
import Cardano.Api (
8+
BlockHeader(..),
9+
BlockNo(..),
10+
SlotNo(..),
11+
Hash(..),
12+
ScriptHash(..),
13+
TxId,
14+
serialiseToRawBytes,
15+
)
16+
17+
import Database.SQLite.Simple
18+
import Database.SQLite.Simple.ToField
19+
20+
withSqliteStorage :: FilePath -> (Storage -> IO ()) -> IO ()
21+
withSqliteStorage dbPath act =
22+
withConnection dbPath $ \sqliteConn -> do
23+
storage <- mkStorage sqliteConn
24+
act storage
25+
26+
mkStorage :: Connection -> IO Storage
27+
mkStorage conn = do
28+
initSchema conn
29+
30+
let
31+
addExecutionEvent :: ExecutionEventPayload -> IO ()
32+
addExecutionEvent ExecutionEventPayload{..} = do
33+
let (BlockHeader slotNo hash blockNo) = blockHeader
34+
35+
withTransaction conn $ do
36+
execute conn
37+
"INSERT OR IGNORE INTO block (block_no, slot_no, hash) values (?, ?, ?)"
38+
(blockNo, slotNo, hash)
39+
40+
execute conn
41+
"INSERT INTO execution_event (block_no, transaction_hash, script_hash, name, trace) values (?, ?, ?, ?, ?)"
42+
(blockNo, transactionHash, scriptHash, scriptName, trace)
43+
44+
let
45+
addCancellationEvent :: BlockHeader -> ScriptHash -> IO ()
46+
addCancellationEvent (BlockHeader slotNo hash blockNo) scriptHash =
47+
withTransaction conn $ do
48+
execute conn
49+
"INSERT OR IGNORE INTO block (block_no, slot_no, hash) values (?, ?, ?)"
50+
(blockNo, slotNo, hash)
51+
52+
execute conn
53+
"INSERT INTO cancellation_event (block_no, script_hash) values (?, ?)"
54+
(blockNo, scriptHash)
55+
56+
let
57+
addSelectionEvent :: BlockHeader -> IO ()
58+
addSelectionEvent (BlockHeader slotNo hash blockNo) =
59+
withTransaction conn $ do
60+
execute conn
61+
"INSERT OR IGNORE INTO block (block_no, slot_no, hash) values (?, ?, ?)"
62+
(blockNo, slotNo, hash)
63+
64+
execute conn
65+
"INSERT INTO selection_event (block_no) values (?)"
66+
(Only blockNo)
67+
68+
let
69+
getEvents :: FilterQueryParams -> IO [Event]
70+
getEvents = undefined
71+
72+
pure $ Storage {..}
73+
74+
initSchema :: Connection -> IO ()
75+
initSchema conn = withTransaction conn $ do
76+
execute_ conn
77+
"CREATE TABLE IF NOT EXISTS block( \
78+
\ block_no UNSIGNED BIGINT NOT NULL PRIMARY KEY, \
79+
\ slot_no UNSIGNED BIGINT NOT NULL UNIQUE, \
80+
\ hash BLOB NOT NULL UNIQUE)"
81+
82+
execute_ conn
83+
"CREATE TABLE IF NOT EXISTS execution_event(\
84+
\ block_no UNSIGNED BIGINT NOT NULL REFERENCES block(block_no), \
85+
\ transaction_hash BLOB NOT NULL, \
86+
\ script_hash BLOB NOT NULL, \
87+
\ name TEXT, \
88+
\ trace TEXT)"
89+
90+
execute_ conn "CREATE TABLE IF NOT EXISTS cancellation_event (block_number UNSIGNED BIGINT NOT NULL REFERENCES block(block_no), script_hash BLOB NOT NULL)"
91+
92+
execute_ conn "CREATE TABLE IF NOT EXISTS selection_event (block_no UNSIGNED BIGINT NOT NULL REFERENCES block(block_no))"
93+
94+
95+
-- instances --
96+
97+
instance ToField BlockNo where
98+
toField (BlockNo blockNo) = toField blockNo
99+
100+
instance ToField SlotNo where
101+
toField (SlotNo slotNo) = toField slotNo
102+
103+
instance ToField (Hash BlockHeader) where
104+
toField hash = toField $ serialiseToRawBytes hash
105+
106+
instance ToField ScriptHash where
107+
toField hash = toField $ serialiseToRawBytes hash
108+
109+
instance ToField TxId where
110+
toField txId = toField $ serialiseToRawBytes txId

‎nix/shell.nix‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ let
99
"ghc966".stylish-haskell = project.projectVariants.ghc966.tool "stylish-haskell" "latest";
1010
"ghc966".fourmolu = project.projectVariants.ghc966.tool "fourmolu" "latest";
1111
"ghc966".hlint = project.projectVariants.ghc966.tool "hlint" "latest";
12+
"ghc966".ghcid = project.projectVariants.ghc966.tool "ghcid" "latest";
1213

1314
"ghc984".cabal = project.projectVariants.ghc984.tool "cabal" "latest";
1415
"ghc984".cabal-fmt = project.projectVariants.ghc984.tool "cabal-fmt" "latest";
@@ -82,6 +83,7 @@ let
8283
tools.cabal
8384
tools.hlint
8485
tools.cabal-fmt
86+
tools.ghcid
8587

8688
inputs.cardano-node.packages.${pkgs.system}.cardano-node
8789
inputs.cardano-node.packages.${pkgs.system}.cardano-testnet

‎plutus-script-reexecutor.cabal‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,8 @@ library
5252
PSR.Chain
5353
PSR.ConfigMap
5454
PSR.ContextBuilder
55+
PSR.Storage.Interface
56+
PSR.Storage.SQLite
5557
PSR.Streaming
5658
PSR.HTTP
5759
PSR.HTTP.API
@@ -60,6 +62,7 @@ library
6062
build-depends:
6163
, base >=4.9 && <5
6264
, aeson
65+
, bytestring
6366
, cardano-api
6467
, cardano-ledger-alonzo
6568
, cardano-ledger-core
@@ -75,6 +78,7 @@ library
7578
, servant-queryparam-server
7679
, streamly
7780
, streamly-core
81+
, sqlite-simple
7882
, prometheus-client
7983
, prometheus-metrics-ghc
8084
, text

0 commit comments

Comments
 (0)