mirror of https://github.com/voidlizard/hbs2
Dmitry Zuikov
parent
15d6a1d06f
commit
5cd40a17dd
|
|
@ -2,15 +2,16 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
module HBS2.Net.Proto.Service where
|
||||
module HBS2.Net.Proto.Service
|
||||
( module HBS2.Net.Proto.Service
|
||||
, module HBS2.Net.Proto.Types
|
||||
) where
|
||||
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Prelude.Plated
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Codec.Serialise
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
|
|
|
|||
|
|
@ -136,6 +136,7 @@ library
|
|||
HBS2.Peer.RPC.API
|
||||
HBS2.Peer.RPC.API.Storage
|
||||
HBS2.Peer.RPC.Client.Unix
|
||||
HBS2.Peer.RPC.Client.StorageClient
|
||||
HBS2.Peer.RPC.Internal.Storage
|
||||
HBS2.Peer.RPC.Internal.Types
|
||||
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ data RpcStorageHasBlock
|
|||
data RpcStorageGetBlock
|
||||
data RpcStorageEnqueueBlock
|
||||
data RpcStoragePutBlock
|
||||
data RpcStorageDelBlock
|
||||
data RpcStorageGetChunk
|
||||
data RpcStorageGetRef
|
||||
data RpcStorageUpdateRef
|
||||
|
|
@ -23,6 +24,7 @@ type StorageAPI = '[ RpcStorageHasBlock
|
|||
, RpcStorageGetBlock
|
||||
, RpcStorageEnqueueBlock
|
||||
, RpcStoragePutBlock
|
||||
, RpcStorageDelBlock
|
||||
, RpcStorageGetChunk
|
||||
, RpcStorageGetRef
|
||||
, RpcStorageUpdateRef
|
||||
|
|
|
|||
|
|
@ -0,0 +1,63 @@
|
|||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
module HBS2.Peer.RPC.Client.StorageClient
|
||||
( Storage(..)
|
||||
, StorageClient(..)
|
||||
) where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
|
||||
import HBS2.Hash
|
||||
import HBS2.Data.Types.Refs (HashRef(..),refAlias)
|
||||
import HBS2.Net.Proto.Service
|
||||
import HBS2.Storage
|
||||
|
||||
import HBS2.Peer.RPC.Internal.Storage()
|
||||
|
||||
import HBS2.Peer.RPC.API.Storage
|
||||
|
||||
import Data.Functor
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Either
|
||||
|
||||
newtype StorageClient e =
|
||||
StorageClient { fromStorageClient :: ServiceCaller StorageAPI e }
|
||||
|
||||
instance ( MonadIO m
|
||||
, HasProtocol e (ServiceProto StorageAPI e)
|
||||
)
|
||||
=> Storage (StorageClient e) HbSync ByteString m where
|
||||
|
||||
putBlock s lbs = liftIO do
|
||||
callService @RpcStoragePutBlock @StorageAPI (fromStorageClient s) lbs
|
||||
<&> either (const Nothing) (fmap fromHashRef)
|
||||
|
||||
enqueueBlock s lbs = liftIO do
|
||||
callService @RpcStorageEnqueueBlock @StorageAPI (fromStorageClient s) lbs
|
||||
<&> either (const Nothing) (fmap fromHashRef)
|
||||
|
||||
getBlock s key = liftIO do
|
||||
callService @RpcStorageGetBlock (fromStorageClient s) (HashRef key)
|
||||
<&> fromRight Nothing
|
||||
|
||||
getChunk s k off size = liftIO do
|
||||
callService @RpcStorageGetChunk (fromStorageClient s) (HashRef k, off, size)
|
||||
<&> fromRight Nothing
|
||||
|
||||
hasBlock s k = liftIO do
|
||||
callService @RpcStorageHasBlock (fromStorageClient s) (HashRef k)
|
||||
<&> fromRight Nothing
|
||||
|
||||
delBlock s h = liftIO do
|
||||
void $ callService @RpcStorageDelBlock (fromStorageClient s) (HashRef h)
|
||||
|
||||
updateRef s ref v = liftIO do
|
||||
void $ callService @RpcStorageUpdateRef (fromStorageClient s) (refAlias ref, HashRef v)
|
||||
|
||||
getRef s ref = liftIO do
|
||||
callService @RpcStorageGetRef (fromStorageClient s) (refAlias ref)
|
||||
<&> either (const Nothing) (fmap fromHashRef)
|
||||
|
||||
delRef s ref = liftIO do
|
||||
void $ callService @RpcStorageDelRef (fromStorageClient s) (refAlias ref)
|
||||
|
||||
|
|
@ -16,7 +16,6 @@ import HBS2.Peer.RPC.API.Storage
|
|||
|
||||
import HBS2.Net.Proto.Service
|
||||
|
||||
import HBS2.Peer.RPC.Internal.Types
|
||||
|
||||
import Data.Functor
|
||||
import Data.ByteString.Lazy ( ByteString )
|
||||
|
|
@ -56,6 +55,14 @@ instance (StorageContext m) => HandleMethod m RpcStoragePutBlock where
|
|||
sto <- getStorage
|
||||
liftIO $ putBlock sto lbs <&> fmap HashRef
|
||||
|
||||
instance (StorageContext m) => HandleMethod m RpcStorageDelBlock where
|
||||
type instance Input RpcStorageDelBlock = HashRef
|
||||
type instance Output RpcStorageDelBlock = ()
|
||||
|
||||
handleMethod href = do
|
||||
sto <- getStorage
|
||||
liftIO $ delBlock sto (fromHashRef href)
|
||||
|
||||
instance (StorageContext m) => HandleMethod m RpcStorageGetChunk where
|
||||
type instance Input RpcStorageGetChunk = (HashRef, Offset, Size)
|
||||
type instance Output RpcStorageGetChunk = Maybe ByteString
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
module Main where
|
||||
|
||||
import HBS2.Hash
|
||||
import HBS2.Base58
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Net.Messaging.Unix
|
||||
|
|
@ -13,6 +14,7 @@ import HBS2.Peer.RPC.Client.Unix
|
|||
|
||||
import HBS2.Peer.RPC.Class
|
||||
import HBS2.Peer.RPC.Internal.Storage()
|
||||
import HBS2.Peer.RPC.Client.StorageClient
|
||||
|
||||
import HBS2.OrDie
|
||||
|
||||
|
|
@ -91,19 +93,28 @@ main = do
|
|||
|
||||
withRPC2 @StorageAPI soname $ \caller -> do
|
||||
|
||||
let cto = StorageClient caller
|
||||
|
||||
info "does it work?"
|
||||
|
||||
size <- callService @RpcStorageHasBlock caller (HashRef h1) `orDie` "can't read block"
|
||||
|
||||
info $ "got block size: " <+> pretty size
|
||||
size2 <- hasBlock cto h1
|
||||
|
||||
info $ "got block size: " <+> pretty size <+> pretty size2
|
||||
|
||||
assertBool "block-size-1" (size == Just (fromIntegral $ LBS.length blk1))
|
||||
|
||||
assertBool "block-size-1.1" (fromJust size == fromJust size2)
|
||||
|
||||
b <- callService @RpcStorageGetBlock caller (HashRef h1) `orDie` "can't read block"
|
||||
|
||||
info $ "got block" <+> viaShow b
|
||||
b1 <- getBlock cto h1 `orDie` "cant read block via storage"
|
||||
|
||||
info $ "got block (0)" <+> viaShow b <+> viaShow b1
|
||||
|
||||
assertBool "block-eq-1" ( b == Just blk1 )
|
||||
assertBool "block-eq-1.1" ( b1 == blk1 )
|
||||
|
||||
let pechen = "PECHENTERSKI"
|
||||
|
||||
|
|
@ -113,11 +124,20 @@ main = do
|
|||
|
||||
let hh2 = fromJust h2
|
||||
|
||||
let jopakita = "JOPAKITA"
|
||||
h3 <- putBlock cto jopakita `orDie` "cant store block via client storage"
|
||||
|
||||
blk3 <- getBlock cto h3 `orDie` "cant read block via client storage"
|
||||
|
||||
info $ "stored block value" <+> viaShow jopakita <+> viaShow blk3
|
||||
|
||||
blk2 <- callService @RpcStorageGetBlock caller hh2 `orDie` "block lookup failed"
|
||||
|
||||
info $ "stored block value:" <+> viaShow blk2
|
||||
|
||||
assertBool "block-eq-2" (Just pechen == blk2)
|
||||
assertBool "block-eq-2.1" (Just pechen == blk2)
|
||||
|
||||
assertBool "block-eq-2.2" (jopakita == blk3)
|
||||
|
||||
let rk2 = refAlias rk1
|
||||
|
||||
|
|
@ -141,6 +161,19 @@ main = do
|
|||
|
||||
assertBool "ref-alias-works-2" (fromJust rk4val == fromHashRef hh2)
|
||||
|
||||
updateRef cto (SomeRefKey jopakita) h3
|
||||
|
||||
vjopa <- getRef cto (SomeRefKey jopakita)
|
||||
|
||||
info $ "refkey via client storage" <+> pretty vjopa <+> pretty h3
|
||||
|
||||
assertBool "ref-alias-works-3" (vjopa == Just h3)
|
||||
|
||||
pure ()
|
||||
|
||||
|
||||
|
||||
|
||||
setLoggingOff @DEBUG
|
||||
setLoggingOff @INFO
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue