{-# LANGUAGE TemplateHaskell #-}

module Tendermint.SDK.BaseApp.Store.RawStore
  (
  -- * Effects
    StoreEffs
  , Scope(..)
  , ReadStore(..)
  , storeGet
  , get
  , prove
  , WriteStore(..)
  , put
  , storePut
  , delete
  , storeDelete
  , CommitBlock(..)
  , commitBlock
  , Transaction(..)
  , beginTransaction
  , withSandbox
  , withTransaction
  , commit

  -- * Types
  , RawKey(..)
  , IsKey(..)
  , StoreKey(..)
  , KeyRoot(..)
  , makeKeyBytes
  , CommitResponse(..)
  , Store
  , nestStore
  , makeStore
  , makeStoreKey

  , Version(..)
  ) where

import           Control.Lens                  (Iso', iso, (^.))
import           Data.ByteArray.Base64String   (Base64String)
import qualified Data.ByteString               as BS
import           Data.Kind                     (Type)
import           Data.Proxy
import           Data.String.Conversions       (cs)
import           Data.Text
import           Data.Word                     (Word64)
import           Numeric.Natural               (Natural)
import           Polysemy                      (Member, Members, Sem, makeSem)
import           Polysemy.Error                (Error, catch, throw)
import           Polysemy.Resource             (Resource, finally, onException)
import           Polysemy.Tagged               (Tagged)
import           Tendermint.SDK.BaseApp.Errors (AppError, SDKError (ParseError),
                                                throwSDKError)
import           Tendermint.SDK.Codec          (HasCodec (..))
import           Tendermint.SDK.Types.Address  (Address, addressFromBytes,
                                                addressToBytes)

--------------------------------------------------------------------------------
-- | Keys
--------------------------------------------------------------------------------

class RawKey k where
  rawKey :: Iso' k BS.ByteString

instance RawKey Text where
  rawKey :: p ByteString (f ByteString) -> p Text (f Text)
rawKey = (Text -> ByteString)
-> (ByteString -> Text) -> Iso' Text ByteString
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs

instance RawKey Address where
    rawKey :: p ByteString (f ByteString) -> p Address (f Address)
rawKey = (Address -> ByteString)
-> (ByteString -> Address) -> Iso' Address ByteString
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Address -> ByteString
addressToBytes ByteString -> Address
addressFromBytes

instance RawKey Word64 where
    rawKey :: p ByteString (f ByteString) -> p Word64 (f Word64)
rawKey = (Word64 -> ByteString)
-> (ByteString -> Word64) -> Iso' Word64 ByteString
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Word64 -> ByteString
forall a. HasCodec a => a -> ByteString
encode ((Text -> Word64)
-> (Word64 -> Word64) -> Either Text Word64 -> Word64
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Text -> Word64
forall a. HasCallStack => [Char] -> a
error "Error decoding Word64 RawKey") Word64 -> Word64
forall a. a -> a
id (Either Text Word64 -> Word64)
-> (ByteString -> Either Text Word64) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Word64
forall a. HasCodec a => ByteString -> Either Text a
decode)

instance RawKey () where
    rawKey :: p ByteString (f ByteString) -> p () (f ())
rawKey = (() -> ByteString) -> (ByteString -> ()) -> Iso' () ByteString
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (ByteString -> () -> ByteString
forall a b. a -> b -> a
const "") (() -> ByteString -> ()
forall a b. a -> b -> a
const ())

class RawKey k => IsKey k ns where
  type Value k ns :: Type
  prefix :: Proxy k -> Proxy ns -> BS.ByteString

  default prefix :: Proxy k -> Proxy ns -> BS.ByteString
  prefix _ _ = ""

data StoreKey = StoreKey
  { StoreKey -> [ByteString]
skPathFromRoot :: [BS.ByteString]
  , StoreKey -> ByteString
skKey          :: BS.ByteString
  } deriving (StoreKey -> StoreKey -> Bool
(StoreKey -> StoreKey -> Bool)
-> (StoreKey -> StoreKey -> Bool) -> Eq StoreKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StoreKey -> StoreKey -> Bool
$c/= :: StoreKey -> StoreKey -> Bool
== :: StoreKey -> StoreKey -> Bool
$c== :: StoreKey -> StoreKey -> Bool
Eq, Int -> StoreKey -> ShowS
[StoreKey] -> ShowS
StoreKey -> [Char]
(Int -> StoreKey -> ShowS)
-> (StoreKey -> [Char]) -> ([StoreKey] -> ShowS) -> Show StoreKey
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [StoreKey] -> ShowS
$cshowList :: [StoreKey] -> ShowS
show :: StoreKey -> [Char]
$cshow :: StoreKey -> [Char]
showsPrec :: Int -> StoreKey -> ShowS
$cshowsPrec :: Int -> StoreKey -> ShowS
Show, Eq StoreKey
Eq StoreKey =>
(StoreKey -> StoreKey -> Ordering)
-> (StoreKey -> StoreKey -> Bool)
-> (StoreKey -> StoreKey -> Bool)
-> (StoreKey -> StoreKey -> Bool)
-> (StoreKey -> StoreKey -> Bool)
-> (StoreKey -> StoreKey -> StoreKey)
-> (StoreKey -> StoreKey -> StoreKey)
-> Ord StoreKey
StoreKey -> StoreKey -> Bool
StoreKey -> StoreKey -> Ordering
StoreKey -> StoreKey -> StoreKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StoreKey -> StoreKey -> StoreKey
$cmin :: StoreKey -> StoreKey -> StoreKey
max :: StoreKey -> StoreKey -> StoreKey
$cmax :: StoreKey -> StoreKey -> StoreKey
>= :: StoreKey -> StoreKey -> Bool
$c>= :: StoreKey -> StoreKey -> Bool
> :: StoreKey -> StoreKey -> Bool
$c> :: StoreKey -> StoreKey -> Bool
<= :: StoreKey -> StoreKey -> Bool
$c<= :: StoreKey -> StoreKey -> Bool
< :: StoreKey -> StoreKey -> Bool
$c< :: StoreKey -> StoreKey -> Bool
compare :: StoreKey -> StoreKey -> Ordering
$ccompare :: StoreKey -> StoreKey -> Ordering
$cp1Ord :: Eq StoreKey
Ord)

makeKeyBytes :: StoreKey -> BS.ByteString
makeKeyBytes :: StoreKey -> ByteString
makeKeyBytes StoreKey{..} =  [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString]
skPathFromRoot ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
skKey

--------------------------------------------------------------------------------
-- | Store
--------------------------------------------------------------------------------

newtype KeyRoot ns =
  KeyRoot BS.ByteString deriving (KeyRoot ns -> KeyRoot ns -> Bool
(KeyRoot ns -> KeyRoot ns -> Bool)
-> (KeyRoot ns -> KeyRoot ns -> Bool) -> Eq (KeyRoot ns)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (ns :: k). KeyRoot ns -> KeyRoot ns -> Bool
/= :: KeyRoot ns -> KeyRoot ns -> Bool
$c/= :: forall k (ns :: k). KeyRoot ns -> KeyRoot ns -> Bool
== :: KeyRoot ns -> KeyRoot ns -> Bool
$c== :: forall k (ns :: k). KeyRoot ns -> KeyRoot ns -> Bool
Eq, Int -> KeyRoot ns -> ShowS
[KeyRoot ns] -> ShowS
KeyRoot ns -> [Char]
(Int -> KeyRoot ns -> ShowS)
-> (KeyRoot ns -> [Char])
-> ([KeyRoot ns] -> ShowS)
-> Show (KeyRoot ns)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall k (ns :: k). Int -> KeyRoot ns -> ShowS
forall k (ns :: k). [KeyRoot ns] -> ShowS
forall k (ns :: k). KeyRoot ns -> [Char]
showList :: [KeyRoot ns] -> ShowS
$cshowList :: forall k (ns :: k). [KeyRoot ns] -> ShowS
show :: KeyRoot ns -> [Char]
$cshow :: forall k (ns :: k). KeyRoot ns -> [Char]
showsPrec :: Int -> KeyRoot ns -> ShowS
$cshowsPrec :: forall k (ns :: k). Int -> KeyRoot ns -> ShowS
Show)

data Store ns = Store
  { Store ns -> [ByteString]
storePathFromRoot :: [BS.ByteString]
  }

makeStore :: KeyRoot ns  -> Store ns
makeStore :: KeyRoot ns -> Store ns
makeStore (KeyRoot ns :: ByteString
ns) = Store :: forall k (ns :: k). [ByteString] -> Store ns
Store
  { storePathFromRoot :: [ByteString]
storePathFromRoot = [ByteString
ns]
  }

nestStore :: Store parentns -> Store childns -> Store childns
nestStore :: Store parentns -> Store childns -> Store childns
nestStore (Store parentPath :: [ByteString]
parentPath) (Store childPath :: [ByteString]
childPath) =
  Store :: forall k (ns :: k). [ByteString] -> Store ns
Store
    { storePathFromRoot :: [ByteString]
storePathFromRoot =  [ByteString]
parentPath [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
childPath
    }

makeStoreKey
  :: forall k ns.
     IsKey k ns
  => Store ns
  -> k
  -> StoreKey
makeStoreKey :: Store ns -> k -> StoreKey
makeStoreKey (Store path :: [ByteString]
path) k :: k
k =
  StoreKey :: [ByteString] -> ByteString -> StoreKey
StoreKey
    { skKey :: ByteString
skKey = Proxy k -> Proxy ns -> ByteString
forall k k (ns :: k).
IsKey k ns =>
Proxy k -> Proxy ns -> ByteString
prefix (Proxy k
forall k (t :: k). Proxy t
Proxy @k) (Proxy ns
forall k (t :: k). Proxy t
Proxy @ns) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> k
k k -> Getting ByteString k ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString k ByteString
forall k. RawKey k => Iso' k ByteString
rawKey
    , skPathFromRoot :: [ByteString]
skPathFromRoot = [ByteString]
path
    }


--------------------------------------------------------------------------------
-- | Read and Write Effects
--------------------------------------------------------------------------------


data ReadStore m a where
  StoreGet   :: StoreKey -> ReadStore m (Maybe BS.ByteString)
  StoreProve :: StoreKey -> ReadStore m (Maybe BS.ByteString)

makeSem ''ReadStore

data WriteStore m a where
  StorePut   :: StoreKey -> BS.ByteString -> WriteStore m ()
  StoreDelete :: StoreKey -> WriteStore m ()

makeSem ''WriteStore

put
  :: forall k r ns.
     IsKey k ns
  => HasCodec (Value k ns)
  => Member WriteStore r
  => Store ns
  -> k
  -> Value k ns
  -> Sem r ()
put :: Store ns -> k -> Value k ns -> Sem r ()
put store :: Store ns
store k :: k
k a :: Value k ns
a =
  let key :: StoreKey
key = Store ns -> k -> StoreKey
forall k k (ns :: k). IsKey k ns => Store ns -> k -> StoreKey
makeStoreKey Store ns
store k
k
      val :: ByteString
val = Value k ns -> ByteString
forall a. HasCodec a => a -> ByteString
encode Value k ns
a
  in StoreKey -> ByteString -> Sem r ()
forall (r :: [Effect]).
MemberWithError WriteStore r =>
StoreKey -> ByteString -> Sem r ()
storePut StoreKey
key ByteString
val

get
  :: forall k r ns.
     IsKey k ns
  => HasCodec (Value k ns)
  => Members [ReadStore, Error AppError] r
  => Store ns
  -> k
  -> Sem r (Maybe (Value k ns))
get :: Store ns -> k -> Sem r (Maybe (Value k ns))
get store :: Store ns
store k :: k
k = do
  let key :: StoreKey
key = Store ns -> k -> StoreKey
forall k k (ns :: k). IsKey k ns => Store ns -> k -> StoreKey
makeStoreKey Store ns
store k
k
  Maybe ByteString
mRes <- StoreKey -> Sem r (Maybe ByteString)
forall (r :: [Effect]).
MemberWithError ReadStore r =>
StoreKey -> Sem r (Maybe ByteString)
storeGet StoreKey
key
  case Maybe ByteString
mRes of
    Nothing -> Maybe (Value k ns) -> Sem r (Maybe (Value k ns))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Value k ns)
forall a. Maybe a
Nothing
    Just raw :: ByteString
raw -> case ByteString -> Either Text (Value k ns)
forall a. HasCodec a => ByteString -> Either Text a
decode ByteString
raw of
      Left e :: Text
e  -> SDKError -> Sem r (Maybe (Value k ns))
forall (r :: [Effect]) a.
Member (Error AppError) r =>
SDKError -> Sem r a
throwSDKError (Text -> SDKError
ParseError (Text -> SDKError) -> Text -> SDKError
forall a b. (a -> b) -> a -> b
$ "Impossible codec error: "  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
e)
      Right a :: Value k ns
a -> Maybe (Value k ns) -> Sem r (Maybe (Value k ns))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Value k ns) -> Sem r (Maybe (Value k ns)))
-> Maybe (Value k ns) -> Sem r (Maybe (Value k ns))
forall a b. (a -> b) -> a -> b
$ Value k ns -> Maybe (Value k ns)
forall a. a -> Maybe a
Just Value k ns
a

delete
  :: forall k ns r.
     IsKey k ns
  => Member WriteStore r
  => Store ns
  -> k
  -> Sem r ()
delete :: Store ns -> k -> Sem r ()
delete store :: Store ns
store k :: k
k =
  let key :: StoreKey
key = Store ns -> k -> StoreKey
forall k k (ns :: k). IsKey k ns => Store ns -> k -> StoreKey
makeStoreKey Store ns
store k
k
  in StoreKey -> Sem r ()
forall (r :: [Effect]).
MemberWithError WriteStore r =>
StoreKey -> Sem r ()
storeDelete StoreKey
key

prove
  :: forall k ns r.
     IsKey k ns
  => Member ReadStore r
  => Store ns
  -> k
  -> Sem r (Maybe BS.ByteString)
prove :: Store ns -> k -> Sem r (Maybe ByteString)
prove store :: Store ns
store k :: k
k =
  let key :: StoreKey
key = Store ns -> k -> StoreKey
forall k k (ns :: k). IsKey k ns => Store ns -> k -> StoreKey
makeStoreKey Store ns
store k
k
  in StoreKey -> Sem r (Maybe ByteString)
forall (r :: [Effect]).
MemberWithError ReadStore r =>
StoreKey -> Sem r (Maybe ByteString)
storeProve StoreKey
key

--------------------------------------------------------------------------------
-- | Consensus Effects
--------------------------------------------------------------------------------

data CommitBlock m a where
  CommitBlock :: CommitBlock m Base64String

makeSem ''CommitBlock

data CommitResponse = CommitResponse
  { CommitResponse -> Base64String
rootHash   :: Base64String
  , CommitResponse -> Natural
newVersion :: Natural
  } deriving (CommitResponse -> CommitResponse -> Bool
(CommitResponse -> CommitResponse -> Bool)
-> (CommitResponse -> CommitResponse -> Bool) -> Eq CommitResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommitResponse -> CommitResponse -> Bool
$c/= :: CommitResponse -> CommitResponse -> Bool
== :: CommitResponse -> CommitResponse -> Bool
$c== :: CommitResponse -> CommitResponse -> Bool
Eq, Int -> CommitResponse -> ShowS
[CommitResponse] -> ShowS
CommitResponse -> [Char]
(Int -> CommitResponse -> ShowS)
-> (CommitResponse -> [Char])
-> ([CommitResponse] -> ShowS)
-> Show CommitResponse
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CommitResponse] -> ShowS
$cshowList :: [CommitResponse] -> ShowS
show :: CommitResponse -> [Char]
$cshow :: CommitResponse -> [Char]
showsPrec :: Int -> CommitResponse -> ShowS
$cshowsPrec :: Int -> CommitResponse -> ShowS
Show)

data Transaction m a where
  -- transact
  BeginTransaction :: Transaction m ()
  Rollback :: Transaction m ()
  Commit :: Transaction m CommitResponse

makeSem ''Transaction

withTransaction
  :: forall r a.
     Members [Transaction, Resource, Error AppError] r
  => Sem r a
  -> Sem r (a, CommitResponse)
withTransaction :: Sem r a -> Sem r (a, CommitResponse)
withTransaction m :: Sem r a
m =
   let tryTx :: Sem r a
tryTx = Sem r a
m Sem r a -> (Any -> Sem r a) -> Sem r a
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
`catch` (\e :: Any
e -> Sem r ()
forall (r :: [Effect]). MemberWithError Transaction r => Sem r ()
rollback Sem r () -> Sem r a -> Sem r a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Any -> Sem r a
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw Any
e)
       actionWithCommit :: Sem r (a, CommitResponse)
actionWithCommit = do
         a
res <- Sem r a
tryTx
         CommitResponse
c <- Sem r CommitResponse
forall (r :: [Effect]).
MemberWithError Transaction r =>
Sem r CommitResponse
commit
         (a, CommitResponse) -> Sem r (a, CommitResponse)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
res, CommitResponse
c)
   in do
      Sem r (a, CommitResponse) -> Sem r () -> Sem r (a, CommitResponse)
forall (r :: [Effect]) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
onException Sem r (a, CommitResponse)
actionWithCommit Sem r ()
forall (r :: [Effect]). MemberWithError Transaction r => Sem r ()
rollback

withSandbox
  :: forall r a.
     Members [Transaction, Resource, Error AppError] r
  => Sem r a
  -> Sem r a
withSandbox :: Sem r a -> Sem r a
withSandbox m :: Sem r a
m =
   let tryTx :: Sem r a
tryTx = Sem r a
m Sem r a -> (Any -> Sem r a) -> Sem r a
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
`catch` (\e :: Any
e -> Sem r ()
forall (r :: [Effect]). MemberWithError Transaction r => Sem r ()
rollback Sem r () -> Sem r a -> Sem r a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Any -> Sem r a
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw Any
e)
   in Sem r a -> Sem r () -> Sem r a
forall (r :: [Effect]) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
finally (Sem r a
tryTx Sem r a -> Sem r () -> Sem r a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Sem r ()
forall (r :: [Effect]). MemberWithError Transaction r => Sem r ()
rollback) Sem r ()
forall (r :: [Effect]). MemberWithError Transaction r => Sem r ()
rollback

data Version =
    Genesis
  | Version Natural
  | Latest
  deriving (Version -> Version -> Bool
(Version -> Version -> Bool)
-> (Version -> Version -> Bool) -> Eq Version
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Version -> Version -> Bool
$c/= :: Version -> Version -> Bool
== :: Version -> Version -> Bool
$c== :: Version -> Version -> Bool
Eq, Int -> Version -> ShowS
[Version] -> ShowS
Version -> [Char]
(Int -> Version -> ShowS)
-> (Version -> [Char]) -> ([Version] -> ShowS) -> Show Version
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Version] -> ShowS
$cshowList :: [Version] -> ShowS
show :: Version -> [Char]
$cshow :: Version -> [Char]
showsPrec :: Int -> Version -> ShowS
$cshowsPrec :: Int -> Version -> ShowS
Show)

--------------------------------------------------------------------------------
-- | Store Effects
--------------------------------------------------------------------------------

data Scope = Consensus | QueryAndMempool

type StoreEffs =
  [ Tagged 'Consensus ReadStore
  , Tagged 'QueryAndMempool ReadStore
  , Tagged 'Consensus WriteStore
  , Transaction
  , CommitBlock
  ]