From 5cd40a17dd399e0b344bf219191e5a1d45f688c6 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 5 Oct 2023 13:38:21 +0300 Subject: [PATCH] StorageClient ... for RPC --- hbs2-core/lib/HBS2/Net/Proto/Service.hs | 9 +-- hbs2-peer/hbs2-peer.cabal | 1 + hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs | 2 + .../lib/HBS2/Peer/RPC/Client/StorageClient.hs | 63 +++++++++++++++++++ .../lib/HBS2/Peer/RPC/Internal/Storage.hs | 9 ++- hbs2-tests/test/StorageServiceTest.hs | 39 +++++++++++- 6 files changed, 115 insertions(+), 8 deletions(-) create mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs diff --git a/hbs2-core/lib/HBS2/Net/Proto/Service.hs b/hbs2-core/lib/HBS2/Net/Proto/Service.hs index 51d81de8..1fecd973 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Service.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Service.hs @@ -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 diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 58832efe..13ba5cc9 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs index bc00d3d2..2141582b 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs @@ -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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs new file mode 100644 index 00000000..8a36df29 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs @@ -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) + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs index 5b6d9b88..c656fae4 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs @@ -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 diff --git a/hbs2-tests/test/StorageServiceTest.hs b/hbs2-tests/test/StorageServiceTest.hs index b6fcbab6..df3e5719 100644 --- a/hbs2-tests/test/StorageServiceTest.hs +++ b/hbs2-tests/test/StorageServiceTest.hs @@ -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