module Tendermint.SDK.BaseApp.Store.MemoryStore
  (
  -- * Environment
    DBVersions(..)
  , initDBVersions
  , DB
  , initDB
  -- * Eval
  , evalStoreEffs
  , evalRead
  , evalWrite
  ) where


import           Control.Monad.IO.Class                (liftIO)
import qualified Crypto.Data.Auth.Tree                 as AT
import qualified Crypto.Data.Auth.Tree.Class           as AT
import qualified Crypto.Data.Auth.Tree.Cryptonite      as Cryptonite
import qualified Crypto.Hash                           as Cryptonite
import           Data.ByteArray                        (convert)
import qualified Data.ByteArray.Base64String           as Base64
import           Data.ByteString                       (ByteString)
import           Data.IORef
import           Data.List                             (sortOn)
import           Data.Ord                              (Down (..))
import           Numeric.Natural                       (Natural)
import           Polysemy
import           Polysemy.Reader                       (Reader, ask)
import           Polysemy.Tagged                       (untag)
import           Tendermint.SDK.BaseApp.Store.RawStore (CommitBlock (..),
                                                        CommitResponse (..),
                                                        ReadStore (..),
                                                        StoreEffs,
                                                        Transaction (..),
                                                        Version (..),
                                                        WriteStore (..),
                                                        makeKeyBytes)
import           Tendermint.SDK.Types.Effects          ((:&))



newtype AuthTreeHash =  AuthTreeHash (Cryptonite.Digest Cryptonite.SHA256)

instance AT.MerkleHash AuthTreeHash where
    emptyHash :: AuthTreeHash
emptyHash = Digest SHA256 -> AuthTreeHash
AuthTreeHash Digest SHA256
forall a. HashAlgorithm a => Digest a
Cryptonite.emptyHash
    hashLeaf :: k -> v -> AuthTreeHash
hashLeaf k :: k
k v :: v
v = Digest SHA256 -> AuthTreeHash
AuthTreeHash (Digest SHA256 -> AuthTreeHash) -> Digest SHA256 -> AuthTreeHash
forall a b. (a -> b) -> a -> b
$ k -> v -> Digest SHA256
forall a k v.
(HashAlgorithm a, ByteArrayAccess k, ByteArrayAccess v) =>
k -> v -> Digest a
Cryptonite.hashLeaf k
k v
v
    concatHashes :: AuthTreeHash -> AuthTreeHash -> AuthTreeHash
concatHashes (AuthTreeHash a :: Digest SHA256
a) (AuthTreeHash b :: Digest SHA256
b) = Digest SHA256 -> AuthTreeHash
AuthTreeHash (Digest SHA256 -> AuthTreeHash) -> Digest SHA256 -> AuthTreeHash
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> Digest SHA256 -> Digest SHA256
forall a. HashAlgorithm a => Digest a -> Digest a -> Digest a
Cryptonite.concatHashes Digest SHA256
a Digest SHA256
b

data DB = DB
  { DB -> IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted :: IORef (AT.Tree Natural (AT.Tree ByteString ByteString))
  , DB -> IORef (Tree ByteString ByteString)
dbLatest    :: IORef (AT.Tree ByteString ByteString)
  }

initDB :: IO DB
initDB :: IO DB
initDB =
  IORef (Tree Natural (Tree ByteString ByteString))
-> IORef (Tree ByteString ByteString) -> DB
DB (IORef (Tree Natural (Tree ByteString ByteString))
 -> IORef (Tree ByteString ByteString) -> DB)
-> IO (IORef (Tree Natural (Tree ByteString ByteString)))
-> IO (IORef (Tree ByteString ByteString) -> DB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree Natural (Tree ByteString ByteString)
-> IO (IORef (Tree Natural (Tree ByteString ByteString)))
forall a. a -> IO (IORef a)
newIORef Tree Natural (Tree ByteString ByteString)
forall k v. Tree k v
AT.empty
     IO (IORef (Tree ByteString ByteString) -> DB)
-> IO (IORef (Tree ByteString ByteString)) -> IO DB
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tree ByteString ByteString
-> IO (IORef (Tree ByteString ByteString))
forall a. a -> IO (IORef a)
newIORef Tree ByteString ByteString
forall k v. Tree k v
AT.empty

evalWrite
  :: Member (Embed IO) r
  => DB
  -> forall a. Sem (WriteStore ': r) a -> Sem r a
evalWrite :: DB -> forall a. Sem (WriteStore : r) a -> Sem r a
evalWrite DB{IORef (Tree ByteString ByteString)
dbLatest :: IORef (Tree ByteString ByteString)
dbLatest :: DB -> IORef (Tree ByteString ByteString)
dbLatest} m :: Sem (WriteStore : r) a
m =
  (forall x (m :: * -> *). WriteStore m x -> Sem r x)
-> Sem (WriteStore : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret
    (\case
      StorePut k v ->
        IO () -> Sem r ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sem r ())
-> ((Tree ByteString ByteString -> Tree ByteString ByteString)
    -> IO ())
-> (Tree ByteString ByteString -> Tree ByteString ByteString)
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Tree ByteString ByteString)
-> (Tree ByteString ByteString -> Tree ByteString ByteString)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Tree ByteString ByteString)
dbLatest ((Tree ByteString ByteString -> Tree ByteString ByteString)
 -> Sem r x)
-> (Tree ByteString ByteString -> Tree ByteString ByteString)
-> Sem r x
forall a b. (a -> b) -> a -> b
$ ByteString
-> ByteString
-> Tree ByteString ByteString
-> Tree ByteString ByteString
forall k v. Ord k => k -> v -> Tree k v -> Tree k v
AT.insert (StoreKey -> ByteString
makeKeyBytes StoreKey
k) ByteString
v
      StoreDelete k ->
        IO () -> Sem r ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sem r ())
-> ((Tree ByteString ByteString -> Tree ByteString ByteString)
    -> IO ())
-> (Tree ByteString ByteString -> Tree ByteString ByteString)
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Tree ByteString ByteString)
-> (Tree ByteString ByteString -> Tree ByteString ByteString)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Tree ByteString ByteString)
dbLatest ((Tree ByteString ByteString -> Tree ByteString ByteString)
 -> Sem r x)
-> (Tree ByteString ByteString -> Tree ByteString ByteString)
-> Sem r x
forall a b. (a -> b) -> a -> b
$ ByteString
-> Tree ByteString ByteString -> Tree ByteString ByteString
forall k v. Ord k => k -> Tree k v -> Tree k v
AT.delete (StoreKey -> ByteString
makeKeyBytes StoreKey
k)
    ) Sem (WriteStore : r) a
m

evalRead
  :: Member (Embed IO) r
  => DB
  -> IORef Version
  -> forall a. Sem (ReadStore ': r) a -> Sem r a
evalRead :: DB -> IORef Version -> forall a. Sem (ReadStore : r) a -> Sem r a
evalRead DB{IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted :: IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted :: DB -> IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted,IORef (Tree ByteString ByteString)
dbLatest :: IORef (Tree ByteString ByteString)
dbLatest :: DB -> IORef (Tree ByteString ByteString)
dbLatest} iavlVersion :: IORef Version
iavlVersion m :: Sem (ReadStore : r) a
m = do
  (forall x (m :: * -> *). ReadStore m x -> Sem r x)
-> Sem (ReadStore : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret
    (\case
      StoreGet k -> do
        Version
version <- IO Version -> Sem r Version
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Version -> Sem r Version) -> IO Version -> Sem r Version
forall a b. (a -> b) -> a -> b
$ IORef Version -> IO Version
forall a. IORef a -> IO a
readIORef IORef Version
iavlVersion
        case Version
version of
          Latest -> do
            Tree ByteString ByteString
tree <- IO (Tree ByteString ByteString)
-> Sem r (Tree ByteString ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree ByteString ByteString)
 -> Sem r (Tree ByteString ByteString))
-> IO (Tree ByteString ByteString)
-> Sem r (Tree ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ IORef (Tree ByteString ByteString)
-> IO (Tree ByteString ByteString)
forall a. IORef a -> IO a
readIORef IORef (Tree ByteString ByteString)
dbLatest
            Maybe ByteString -> Sem r x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> Sem r x) -> Maybe ByteString -> Sem r x
forall a b. (a -> b) -> a -> b
$ ByteString -> Tree ByteString ByteString -> Maybe ByteString
forall k v. Ord k => k -> Tree k v -> Maybe v
AT.lookup (StoreKey -> ByteString
makeKeyBytes StoreKey
k) Tree ByteString ByteString
tree
          Version v :: Natural
v -> do
            Tree Natural (Tree ByteString ByteString)
tree <- IO (Tree Natural (Tree ByteString ByteString))
-> Sem r (Tree Natural (Tree ByteString ByteString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree Natural (Tree ByteString ByteString))
 -> Sem r (Tree Natural (Tree ByteString ByteString)))
-> IO (Tree Natural (Tree ByteString ByteString))
-> Sem r (Tree Natural (Tree ByteString ByteString))
forall a b. (a -> b) -> a -> b
$ IORef (Tree Natural (Tree ByteString ByteString))
-> IO (Tree Natural (Tree ByteString ByteString))
forall a. IORef a -> IO a
readIORef IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted
            Maybe ByteString -> Sem r (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
-> Tree Natural (Tree ByteString ByteString)
-> Maybe (Tree ByteString ByteString)
forall k v. Ord k => k -> Tree k v -> Maybe v
AT.lookup Natural
v Tree Natural (Tree ByteString ByteString)
tree Maybe (Tree ByteString ByteString)
-> (Tree ByteString ByteString -> Maybe ByteString)
-> Maybe ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Tree ByteString ByteString -> Maybe ByteString
forall k v. Ord k => k -> Tree k v -> Maybe v
AT.lookup (StoreKey -> ByteString
makeKeyBytes StoreKey
k))
          Genesis -> Maybe ByteString -> Sem r (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
      StoreProve _ -> Maybe ByteString -> Sem r (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
    ) Sem (ReadStore : r) a
m

evalTransaction
  :: Member (Embed IO) r
  => DB
  -> forall a. Sem (Transaction ': r) a -> Sem r a
evalTransaction :: DB -> forall a. Sem (Transaction : r) a -> Sem r a
evalTransaction db :: DB
db@DB{..} m :: Sem (Transaction : r) a
m = do
  (forall x (m :: * -> *). Transaction m x -> Sem r x)
-> Sem (Transaction : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret
    (\case
      -- NOTICE :: Currently unnecessary with the DB commit/version implementation.
      BeginTransaction -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Rollback -> IO () -> Sem r x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sem r x) -> IO () -> Sem r x
forall a b. (a -> b) -> a -> b
$ do
          Tree ByteString ByteString
c <- DB -> IO (Tree ByteString ByteString)
getRecentCommit DB
db
          IORef (Tree ByteString ByteString)
-> Tree ByteString ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Tree ByteString ByteString)
dbLatest Tree ByteString ByteString
c
      Commit -> IO CommitResponse -> Sem r x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CommitResponse -> Sem r x) -> IO CommitResponse -> Sem r x
forall a b. (a -> b) -> a -> b
$ do
        Tree ByteString ByteString
l <- IORef (Tree ByteString ByteString)
-> IO (Tree ByteString ByteString)
forall a. IORef a -> IO a
readIORef IORef (Tree ByteString ByteString)
dbLatest
        Natural
v <- DB -> Tree ByteString ByteString -> IO Natural
makeCommit DB
db Tree ByteString ByteString
l
        ByteString
root <- DB -> IO ByteString
getRootHash DB
db
        CommitResponse -> IO CommitResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommitResponse -> IO CommitResponse)
-> CommitResponse -> IO CommitResponse
forall a b. (a -> b) -> a -> b
$ CommitResponse :: Base64String -> Natural -> CommitResponse
CommitResponse
          { rootHash :: Base64String
rootHash = ByteString -> Base64String
forall ba. ByteArrayAccess ba => ba -> Base64String
Base64.fromBytes ByteString
root
          , newVersion :: Natural
newVersion = Integer -> Natural
forall a. Num a => Integer -> a
fromInteger (Integer -> Natural) -> (Natural -> Integer) -> Natural -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Integer
forall a. Integral a => a -> Integer
toInteger (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Natural
v
          }
    ) Sem (Transaction : r) a
m

evalCommitBlock
  :: Member (Embed IO) r
  => DB
  -> DBVersions
  -> forall a. Sem (CommitBlock ': r) a -> Sem r a
evalCommitBlock :: DB -> DBVersions -> forall a. Sem (CommitBlock : r) a -> Sem r a
evalCommitBlock db :: DB
db DBVersions{..} = do
  (forall x (m :: * -> *). CommitBlock m x -> Sem r x)
-> Sem (CommitBlock : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret
    (\case
      CommitBlock -> IO Base64String -> Sem r x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Base64String -> Sem r x) -> IO Base64String -> Sem r x
forall a b. (a -> b) -> a -> b
$ do
        Maybe Natural
mv <- DB -> IO (Maybe Natural)
getVersion DB
db
        IORef Version -> Version -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Version
committed (Version -> IO ()) -> Version -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> (Natural -> Version) -> Maybe Natural -> Version
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Version
Genesis Natural -> Version
Version Maybe Natural
mv
        ByteString
root <- DB -> IO ByteString
getRootHash DB
db
        Base64String -> IO Base64String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Base64String -> IO Base64String)
-> (ByteString -> Base64String) -> ByteString -> IO Base64String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base64String
forall ba. ByteArrayAccess ba => ba -> Base64String
Base64.fromBytes (ByteString -> IO Base64String) -> ByteString -> IO Base64String
forall a b. (a -> b) -> a -> b
$ ByteString
root
    )

data DBVersions = DBVersions
  { DBVersions -> IORef Version
latest    :: IORef Version
  , DBVersions -> IORef Version
committed :: IORef Version
  }

initDBVersions :: IO DBVersions
initDBVersions :: IO DBVersions
initDBVersions = IORef Version -> IORef Version -> DBVersions
DBVersions (IORef Version -> IORef Version -> DBVersions)
-> IO (IORef Version) -> IO (IORef Version -> DBVersions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> IO (IORef Version)
forall a. a -> IO (IORef a)
newIORef Version
Latest IO (IORef Version -> DBVersions)
-> IO (IORef Version) -> IO DBVersions
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Version -> IO (IORef Version)
forall a. a -> IO (IORef a)
newIORef Version
Genesis

evalStoreEffs
  :: Members [Embed IO, Reader DBVersions, Reader DB] r
  => forall a.
     Sem (StoreEffs :& r) a
  -> Sem r a
evalStoreEffs :: forall a. Sem (StoreEffs :& r) a -> Sem r a
evalStoreEffs action :: Sem (StoreEffs :& r) a
action = do
  vs :: DBVersions
vs@DBVersions{..} <- Sem r DBVersions
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Reader i) r =>
Sem r i
ask
  DB
db <- Sem r DB
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Reader i) r =>
Sem r i
ask
  DB -> DBVersions -> forall a. Sem (CommitBlock : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
DB -> DBVersions -> forall a. Sem (CommitBlock : r) a -> Sem r a
evalCommitBlock DB
db DBVersions
vs (Sem (CommitBlock : r) a -> Sem r a)
-> (Sem
      (Tagged 'Consensus ReadStore
         : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
         : Transaction : CommitBlock : r)
      a
    -> Sem (CommitBlock : r) a)
-> Sem
     (Tagged 'Consensus ReadStore
        : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
        : Transaction : CommitBlock : r)
     a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    DB
-> forall a.
   Sem (Transaction : CommitBlock : r) a -> Sem (CommitBlock : r) a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
DB -> forall a. Sem (Transaction : r) a -> Sem r a
evalTransaction DB
db (Sem (Transaction : CommitBlock : r) a -> Sem (CommitBlock : r) a)
-> (Sem
      (Tagged 'Consensus ReadStore
         : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
         : Transaction : CommitBlock : r)
      a
    -> Sem (Transaction : CommitBlock : r) a)
-> Sem
     (Tagged 'Consensus ReadStore
        : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
        : Transaction : CommitBlock : r)
     a
-> Sem (CommitBlock : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    DB
-> forall a.
   Sem (WriteStore : Transaction : CommitBlock : r) a
   -> Sem (Transaction : CommitBlock : r) a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
DB -> forall a. Sem (WriteStore : r) a -> Sem r a
evalWrite DB
db (Sem (WriteStore : Transaction : CommitBlock : r) a
 -> Sem (Transaction : CommitBlock : r) a)
-> (Sem
      (Tagged 'Consensus ReadStore
         : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
         : Transaction : CommitBlock : r)
      a
    -> Sem (WriteStore : Transaction : CommitBlock : r) a)
-> Sem
     (Tagged 'Consensus ReadStore
        : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
        : Transaction : CommitBlock : r)
     a
-> Sem (Transaction : CommitBlock : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Sem
  (Tagged 'Consensus WriteStore : Transaction : CommitBlock : r) a
-> Sem (WriteStore : Transaction : CommitBlock : r) a
forall k1 (k2 :: k1) (e :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
Sem (Tagged k2 e : r) a -> Sem (e : r) a
untag (Sem
   (Tagged 'Consensus WriteStore : Transaction : CommitBlock : r) a
 -> Sem (WriteStore : Transaction : CommitBlock : r) a)
-> (Sem
      (Tagged 'Consensus ReadStore
         : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
         : Transaction : CommitBlock : r)
      a
    -> Sem
         (Tagged 'Consensus WriteStore : Transaction : CommitBlock : r) a)
-> Sem
     (Tagged 'Consensus ReadStore
        : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
        : Transaction : CommitBlock : r)
     a
-> Sem (WriteStore : Transaction : CommitBlock : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    DB
-> IORef Version
-> forall a.
   Sem
     (ReadStore
        : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
     a
   -> Sem
        (Tagged 'Consensus WriteStore : Transaction : CommitBlock : r) a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
DB -> IORef Version -> forall a. Sem (ReadStore : r) a -> Sem r a
evalRead DB
db IORef Version
committed (Sem
   (ReadStore
      : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
   a
 -> Sem
      (Tagged 'Consensus WriteStore : Transaction : CommitBlock : r) a)
-> (Sem
      (Tagged 'Consensus ReadStore
         : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
         : Transaction : CommitBlock : r)
      a
    -> Sem
         (ReadStore
            : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
         a)
-> Sem
     (Tagged 'Consensus ReadStore
        : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
        : Transaction : CommitBlock : r)
     a
-> Sem
     (Tagged 'Consensus WriteStore : Transaction : CommitBlock : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Sem
  (Tagged 'QueryAndMempool ReadStore
     : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
  a
-> Sem
     (ReadStore
        : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
     a
forall k1 (k2 :: k1) (e :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
Sem (Tagged k2 e : r) a -> Sem (e : r) a
untag (Sem
   (Tagged 'QueryAndMempool ReadStore
      : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
   a
 -> Sem
      (ReadStore
         : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
      a)
-> (Sem
      (Tagged 'Consensus ReadStore
         : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
         : Transaction : CommitBlock : r)
      a
    -> Sem
         (Tagged 'QueryAndMempool ReadStore
            : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
         a)
-> Sem
     (Tagged 'Consensus ReadStore
        : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
        : Transaction : CommitBlock : r)
     a
-> Sem
     (ReadStore
        : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    DB
-> IORef Version
-> forall a.
   Sem
     (ReadStore
        : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
        : Transaction : CommitBlock : r)
     a
   -> Sem
        (Tagged 'QueryAndMempool ReadStore
           : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
        a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
DB -> IORef Version -> forall a. Sem (ReadStore : r) a -> Sem r a
evalRead DB
db IORef Version
latest (Sem
   (ReadStore
      : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
      : Transaction : CommitBlock : r)
   a
 -> Sem
      (Tagged 'QueryAndMempool ReadStore
         : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
      a)
-> (Sem
      (Tagged 'Consensus ReadStore
         : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
         : Transaction : CommitBlock : r)
      a
    -> Sem
         (ReadStore
            : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
            : Transaction : CommitBlock : r)
         a)
-> Sem
     (Tagged 'Consensus ReadStore
        : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
        : Transaction : CommitBlock : r)
     a
-> Sem
     (Tagged 'QueryAndMempool ReadStore
        : Tagged 'Consensus WriteStore : Transaction : CommitBlock : r)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Sem
  (Tagged 'Consensus ReadStore
     : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
     : Transaction : CommitBlock : r)
  a
-> Sem
     (ReadStore
        : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
        : Transaction : CommitBlock : r)
     a
forall k1 (k2 :: k1) (e :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
Sem (Tagged k2 e : r) a -> Sem (e : r) a
untag (Sem
   (Tagged 'Consensus ReadStore
      : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
      : Transaction : CommitBlock : r)
   a
 -> Sem r a)
-> Sem
     (Tagged 'Consensus ReadStore
        : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
        : Transaction : CommitBlock : r)
     a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem
  (Tagged 'Consensus ReadStore
     : Tagged 'QueryAndMempool ReadStore : Tagged 'Consensus WriteStore
     : Transaction : CommitBlock : r)
  a
Sem (StoreEffs :& r) a
action

getRootHash
  :: DB
  -> IO ByteString
getRootHash :: DB -> IO ByteString
getRootHash db :: DB
db@DB{IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted :: IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted :: DB -> IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted} = do
  Maybe Natural
mcv <- DB -> IO (Maybe Natural)
getVersion DB
db
  case Maybe Natural
mcv of
    Nothing -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ""
    Just v :: Natural
v -> do
      Tree Natural (Tree ByteString ByteString)
c <- IORef (Tree Natural (Tree ByteString ByteString))
-> IO (Tree Natural (Tree ByteString ByteString))
forall a. IORef a -> IO a
readIORef IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted
      case Natural
-> Tree Natural (Tree ByteString ByteString)
-> Maybe (Tree ByteString ByteString)
forall k v. Ord k => k -> Tree k v -> Maybe v
AT.lookup Natural
v Tree Natural (Tree ByteString ByteString)
c of
        Nothing -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ""
        Just tree :: Tree ByteString ByteString
tree ->
          let AuthTreeHash hash :: Digest SHA256
hash = Tree ByteString ByteString -> AuthTreeHash
forall h k v.
(MerkleHash h, ByteArrayAccess k, ByteArrayAccess v) =>
Tree k v -> h
AT.merkleHash Tree ByteString ByteString
tree
          in ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert Digest SHA256
hash

getVersion
  :: DB
  -> IO (Maybe Natural)
getVersion :: DB -> IO (Maybe Natural)
getVersion DB{..}= do
  Tree Natural (Tree ByteString ByteString)
c <- IORef (Tree Natural (Tree ByteString ByteString))
-> IO (Tree Natural (Tree ByteString ByteString))
forall a. IORef a -> IO a
readIORef IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted
  Maybe Natural -> IO (Maybe Natural)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Natural -> IO (Maybe Natural))
-> Maybe Natural -> IO (Maybe Natural)
forall a b. (a -> b) -> a -> b
$
    if Tree Natural (Tree ByteString ByteString)
c Tree Natural (Tree ByteString ByteString)
-> Tree Natural (Tree ByteString ByteString) -> Bool
forall a. Eq a => a -> a -> Bool
== Tree Natural (Tree ByteString ByteString)
forall k v. Tree k v
AT.empty
      then Maybe Natural
forall a. Maybe a
Nothing
      else Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural) -> Natural -> Maybe Natural
forall a b. (a -> b) -> a -> b
$ [Natural] -> Natural
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ ((Natural, Tree ByteString ByteString) -> Natural)
-> [(Natural, Tree ByteString ByteString)] -> [Natural]
forall a b. (a -> b) -> [a] -> [b]
map (Natural, Tree ByteString ByteString) -> Natural
forall a b. (a, b) -> a
fst ([(Natural, Tree ByteString ByteString)] -> [Natural])
-> [(Natural, Tree ByteString ByteString)] -> [Natural]
forall a b. (a -> b) -> a -> b
$ Tree Natural (Tree ByteString ByteString)
-> [(Natural, Tree ByteString ByteString)]
forall k v. Tree k v -> [(k, v)]
AT.toList Tree Natural (Tree ByteString ByteString)
c

getRecentCommit
  :: DB
  -> IO (AT.Tree ByteString ByteString)
getRecentCommit :: DB -> IO (Tree ByteString ByteString)
getRecentCommit DB{..} = do
  Tree Natural (Tree ByteString ByteString)
c <- IORef (Tree Natural (Tree ByteString ByteString))
-> IO (Tree Natural (Tree ByteString ByteString))
forall a. IORef a -> IO a
readIORef IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted
  case ((Natural, Tree ByteString ByteString) -> Down Natural)
-> [(Natural, Tree ByteString ByteString)]
-> [(Natural, Tree ByteString ByteString)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Natural -> Down Natural
forall a. a -> Down a
Down (Natural -> Down Natural)
-> ((Natural, Tree ByteString ByteString) -> Natural)
-> (Natural, Tree ByteString ByteString)
-> Down Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural, Tree ByteString ByteString) -> Natural
forall a b. (a, b) -> a
fst) ([(Natural, Tree ByteString ByteString)]
 -> [(Natural, Tree ByteString ByteString)])
-> [(Natural, Tree ByteString ByteString)]
-> [(Natural, Tree ByteString ByteString)]
forall a b. (a -> b) -> a -> b
$ Tree Natural (Tree ByteString ByteString)
-> [(Natural, Tree ByteString ByteString)]
forall k v. Tree k v -> [(k, v)]
AT.toList Tree Natural (Tree ByteString ByteString)
c of
    []    -> Tree ByteString ByteString -> IO (Tree ByteString ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree ByteString ByteString
forall k v. Tree k v
AT.empty
    a :: (Natural, Tree ByteString ByteString)
a : _ -> Tree ByteString ByteString -> IO (Tree ByteString ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tree ByteString ByteString -> IO (Tree ByteString ByteString))
-> Tree ByteString ByteString -> IO (Tree ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ (Natural, Tree ByteString ByteString) -> Tree ByteString ByteString
forall a b. (a, b) -> b
snd (Natural, Tree ByteString ByteString)
a

makeCommit
  :: DB
  -> AT.Tree ByteString ByteString
  -> IO Natural
makeCommit :: DB -> Tree ByteString ByteString -> IO Natural
makeCommit db :: DB
db@DB{IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted :: IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted :: DB -> IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted} commit :: Tree ByteString ByteString
commit = do
  Maybe Natural
mv <- DB -> IO (Maybe Natural)
getVersion DB
db
  let v :: Natural
v = Natural -> (Natural -> Natural) -> Maybe Natural -> Natural
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 (Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+1) Maybe Natural
mv
  IORef (Tree Natural (Tree ByteString ByteString))
-> (Tree Natural (Tree ByteString ByteString)
    -> Tree Natural (Tree ByteString ByteString))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Tree Natural (Tree ByteString ByteString))
dbCommitted ((Tree Natural (Tree ByteString ByteString)
  -> Tree Natural (Tree ByteString ByteString))
 -> IO ())
-> (Tree Natural (Tree ByteString ByteString)
    -> Tree Natural (Tree ByteString ByteString))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Natural
-> Tree ByteString ByteString
-> Tree Natural (Tree ByteString ByteString)
-> Tree Natural (Tree ByteString ByteString)
forall k v. Ord k => k -> v -> Tree k v -> Tree k v
AT.insert Natural
v Tree ByteString ByteString
commit
  Natural -> IO Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
v