Skip to content

Commit

Permalink
Sqlite: add more locking to DBLayer methods
Browse files Browse the repository at this point in the history 
Was getting the following failed test:

  λ> quickCheck (prop_parallel db)
  *** Failed! Exception: 'SQLite3 returned ErrorError while attempting to perform step: not an error' (after 5 tests and 3 shrinks):
  ParallelCommands
    { prefix = Commands { unCommands = [] }
    , suffixes =
        [ Pair
            { proj1 =
                Commands
                  { unCommands =
                      [ Command
                          (At (ReadTxHistory (Val (MWid "c"))))
                          (At (Resp (Right (TxHistory (fromList [])))))
                          []
                      ]
                  }
            , proj2 =
                Commands
                  { unCommands =
                      [ Command
                          (At (PutTxHistory (Val (MWid "a")) (fromList [])))
                          (At (Resp (Left (NoSuchWallet (Reference (Symbolic (Var 0)))))))
                          [ Var 0 ]
                      ]
                  }
            }
        ]
    }
  • Loading branch information
@rvl
rvl committed May 29, 2019
1 parent ac18ead commit 1203861
Showing 1 changed file with 30 additions and 13 deletions.
43 changes: 30 additions & 13 deletions lib/core/src/Cardano/Wallet/DB/Sqlite.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -182,8 +182,9 @@ newDBLayer
-> IO (DBLayer IO s t)
newDBLayer fp = do
lock <- newMVar ()
writeLock <- newMVar ()
let withWriteLock = ExceptT . withMVar writeLock . const . runExceptT
bigLock <- newMVar ()
let withWriteLock = ExceptT . withMVar bigLock . const . runExceptT
withBigLock = withMVar bigLock . const

conn <- createSqliteBackend fp (dbLogs [LevelError])
runQuery conn $ void $ runMigrationSilent migrateAll
Expand All @@ -195,15 +196,17 @@ newDBLayer fp = do
Wallets
-----------------------------------------------------------------------}

{ createWallet = \(PrimaryKey wid) cp meta -> withWriteLock $
{ createWallet = \(PrimaryKey wid) cp meta ->
withWriteLock $
ExceptT $ runQuery conn $ do
res <- handleConstraint (ErrWalletAlreadyExists wid) $
insert_ (mkWalletEntity wid meta)
when (isRight res) $
insertCheckpoint wid cp
pure res

, removeWallet = \(PrimaryKey wid) -> withWriteLock $
, removeWallet = \(PrimaryKey wid) ->
withWriteLock $
ExceptT $ runQuery conn $
selectWallet wid >>= \case
Just _ -> Right <$> do
Expand All @@ -214,15 +217,18 @@ newDBLayer fp = do
deleteCascadeWhere [WalTableId ==. wid]
Nothing -> pure $ Left $ ErrNoSuchWallet wid

, listWallets = runQuery conn $
, listWallets =
withBigLock $
runQuery conn $
map (PrimaryKey . unWalletKey) <$>
selectKeysList [] [Asc WalTableId]

{-----------------------------------------------------------------------
Checkpoints
-----------------------------------------------------------------------}

, putCheckpoint = \(PrimaryKey wid) cp -> withWriteLock $
, putCheckpoint = \(PrimaryKey wid) cp ->
withWriteLock $
ExceptT $ runQuery conn $
selectWallet wid >>= \case
Just _ -> Right <$> do
Expand All @@ -231,7 +237,9 @@ newDBLayer fp = do
insertCheckpoint wid cp -- add this checkpoint
Nothing -> pure $ Left $ ErrNoSuchWallet wid

, readCheckpoint = \(PrimaryKey wid) -> runQuery conn $
, readCheckpoint = \(PrimaryKey wid) ->
withBigLock $
runQuery conn $
selectLatestCheckpoint wid >>= \case
Just cp -> do
utxo <- selectUTxO cp
Expand All @@ -245,7 +253,8 @@ newDBLayer fp = do
Wallet Metadata
-----------------------------------------------------------------------}

, putWalletMeta = \(PrimaryKey wid) meta -> withWriteLock $
, putWalletMeta = \(PrimaryKey wid) meta ->
withWriteLock $
ExceptT $ runQuery conn $
selectWallet wid >>= \case
Just _ -> do
Expand All @@ -254,15 +263,18 @@ newDBLayer fp = do
pure $ Right ()
Nothing -> pure $ Left $ ErrNoSuchWallet wid

, readWalletMeta = \(PrimaryKey wid) -> runQuery conn $
, readWalletMeta = \(PrimaryKey wid) ->
withBigLock $
runQuery conn $
fmap (metadataFromEntity . entityVal) <$>
selectFirst [WalTableId ==. wid] []

{-----------------------------------------------------------------------
Tx History
-----------------------------------------------------------------------}

, putTxHistory = \(PrimaryKey wid) txs -> withWriteLock $
, putTxHistory = \(PrimaryKey wid) txs ->
withWriteLock $
ExceptT $ runQuery conn $
selectWallet wid >>= \case
Just _ -> do
Expand All @@ -274,22 +286,27 @@ newDBLayer fp = do
pure $ Right ()
Nothing -> pure $ Left $ ErrNoSuchWallet wid

, readTxHistory = \(PrimaryKey wid) -> runQuery conn $
, readTxHistory = \(PrimaryKey wid) ->
withBigLock $
runQuery conn $
selectTxHistory wid

{-----------------------------------------------------------------------
Keystore
-----------------------------------------------------------------------}

, putPrivateKey = \(PrimaryKey wid) key -> withWriteLock $
, putPrivateKey = \(PrimaryKey wid) key ->
withWriteLock $
ExceptT $ runQuery conn $
selectWallet wid >>= \case
Just _ -> Right <$> do
deleteWhere [PrivateKeyTableWalletId ==. wid]
insert_ (mkPrivateKeyEntity wid key)
Nothing -> pure $ Left $ ErrNoSuchWallet wid

, readPrivateKey = \(PrimaryKey wid) -> runQuery conn $
, readPrivateKey = \(PrimaryKey wid) ->
withBigLock $
runQuery conn $
let keys = selectFirst [PrivateKeyTableWalletId ==. wid] []
toMaybe = either (const Nothing) Just
in (>>= toMaybe . privateKeyFromEntity . entityVal) <$> keys
Expand Down

0 comments on commit 1203861

Please sign in to comment.