storage rpc

2023-10-04 13:38:35 +03:00 · 2023-10-04 13:38:35 +03:00 · 28163d0123
parent 613f26e418
commit 28163d0123
23 changed files with 622 additions and 103 deletions
--- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs
+++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs
@ -7,16 +7,11 @@ module HBS2.Data.Types.Refs

 import HBS2.Base58
 import HBS2.Hash
-import HBS2.Merkle
 import HBS2.Net.Proto.Types
-import HBS2.Net.Auth.Credentials
 import HBS2.Prelude

 import Codec.Serialise(serialise)
 import Data.Data
-import GHC.Generics
-import Data.Hashable hiding (Hashed)
-import Data.Maybe (fromMaybe)

 newtype HashRef = HashRef { fromHashRef :: Hash HbSync }
                  deriving newtype (Eq,Ord,IsString,Pretty,Hashable)
@ -67,7 +62,6 @@ instance Serialise SequentialRef
 instance Serialise HashRef


-
 type IsRefPubKey s =  ( Eq (PubKey 'Sign s)
                      , Serialise (PubKey 'Sign s)
                      , FromStringMaybe (PubKey 'Sign s)
@ -82,4 +76,15 @@ newtype SomeRefKey a = SomeRefKey a
 instance Serialise a => Hashed HbSync (SomeRefKey a) where
  hashObject (SomeRefKey s) = hashObject (serialise s)

+newtype RefAlias = RefAlias { unRefAlias :: HashRef }
+                   deriving stock (Eq,Ord,Show)
+                   deriving newtype (Pretty,Serialise)
+
+instance Hashed HbSync RefAlias  where
+  hashObject (RefAlias h) = fromHashRef h
+
+
+refAlias :: Hashed HbSync ref => ref -> RefAlias
+refAlias x = RefAlias (HashRef $ hashObject @HbSync x)
+

--- a/hbs2-core/lib/HBS2/Storage.hs
+++ b/hbs2-core/lib/HBS2/Storage.hs
@ -5,10 +5,9 @@ import HBS2.Hash
 import HBS2.Prelude.Plated

 import Data.Kind
-import Data.Hashable hiding (Hashed)
 import Lens.Micro.Platform
-import Prettyprinter

+import Codec.Serialise()

 class Pretty (Hash h) => IsKey h where
  type family Key h :: Type
@ -21,11 +20,11 @@ newtype StoragePrefix = StoragePrefix  { fromPrefix :: FilePath }
                        deriving newtype (IsString,Pretty)

 newtype Offset = Offset Integer
-                 deriving newtype (Eq,Ord,Enum,Num,Real,Integral,Hashable,Pretty)
+                 deriving newtype (Eq,Ord,Enum,Num,Real,Integral,Hashable,Pretty,Serialise)
                 deriving stock (Show)

 newtype Size = Size Integer
-               deriving newtype (Eq,Ord,Enum,Num,Real,Integral,Hashable,Pretty)
+               deriving newtype (Eq,Ord,Enum,Num,Real,Integral,Hashable,Pretty,Serialise)
               deriving stock (Show)

 class ( Monad m
--- a/hbs2-peer/app/CLI/Common.hs
+++ b/hbs2-peer/app/CLI/Common.hs
@ -0,0 +1,39 @@
+{-# Language TemplateHaskell #-}
+module CLI.Common where
+
+import HBS2.Net.Messaging.Unix
+import HBS2.Net.Proto.Service
+
+import PeerConfig
+
+import RPC2.Client.Unix
+import RPC2.Service.Unix (getSocketName)
+import RPC2.API
+
+import Control.Applicative
+import Control.Monad.Reader
+import Data.Maybe
+import Lens.Micro.Platform
+import UnliftIO
+
+data RPCOpt =
+  RPCOpt
+  { _rpcOptConf :: Maybe FilePath
+  , _rpcOptAddr :: Maybe String
+  }
+
+makeLenses 'RPCOpt
+
+withMyRPC :: forall api m . (MonadUnliftIO m, api ~ RPC2)
+          => RPCOpt
+          -> (ServiceCaller api UNIX -> m ())
+          -> m ()
+
+withMyRPC o m = do
+  conf  <- peerConfigRead (view rpcOptConf o)
+  soConf <- runReaderT getSocketName conf
+  let soOpt = view rpcOptAddr o
+  let soname = fromJust $ soOpt <|> Just soConf
+  withRPC2 @RPC2  @UNIX soname m
+
+
--- a/hbs2-peer/app/CLI/RefChan.hs
+++ b/hbs2-peer/app/CLI/RefChan.hs
@ -6,15 +6,15 @@ import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto.Definition()
 import HBS2.Net.Proto.RefChan
 import HBS2.Net.Proto.Types
-import HBS2.Net.Messaging.Unix
 import HBS2.Data.Types.SignedBox

 import HBS2.OrDie

 -- FIXME: to-remove-old-rpc
-import RPC2
+--
+import CLI.Common
 import RPC2.API
-import RPC2.Service.Unix
+import RPC2.Service.Unix as RPC2

 import Options.Applicative
 import Data.ByteString qualified as BS
@ -24,6 +24,7 @@ import Codec.Serialise
 import Data.Maybe
 import System.Exit

+
 pRefChan :: Parser (IO ())
 pRefChan = hsubparser (   command "head" (info pRefChanHead (progDesc "head commands" ))
                       <> command "propose" (info pRefChanPropose (progDesc "post propose transaction"))
@ -55,9 +56,6 @@ pRefChanHeadGen = do

 pRefChanHeadDump :: Parser (IO ())
 pRefChanHeadDump= do
-
-
-
  fn <- optional $ strArgument (metavar "refchan head blob")
  pure $ do
    lbs <- maybe1 fn LBS.getContents LBS.readFile
@ -82,7 +80,7 @@ pRefChanHeadPost :: Parser (IO ())
 pRefChanHeadPost = do
  opts <- pRpcCommon
  ref <- strArgument (metavar "HEAD-BLOCK-TREE-HASH")
-  pure $ withRPC2 @UNIX opts $ \caller -> do
+  pure $ withMyRPC opts $ \caller -> do
    href <- pure (fromStringMay ref) `orDie` "HEAD-BLOCK-TREE-HASH"
    -- FIXME: proper-error-handling
    void $ callService @RpcRefChanHeadPost caller href
@ -91,7 +89,7 @@ pRefChanHeadFetch :: Parser (IO ())
 pRefChanHeadFetch = do
  opts <- pRpcCommon
  ref <- strArgument (metavar "REFCHAH-HEAD-KEY")
-  pure $ withRPC2 @UNIX opts $ \caller -> do
+  pure $ withMyRPC opts $ \caller -> do
    href <- pure (fromStringMay ref) `orDie` "invalid REFCHAN-HEAD-REF"
    void $ callService @RpcRefChanHeadFetch caller href

@ -99,7 +97,7 @@ pRefChanHeadGet :: Parser (IO ())
 pRefChanHeadGet = do
  rpc <- pRpcCommon
  ref <- strArgument (metavar "REFCHAH-HEAD-KEY")
-  pure $ withRPC2 @UNIX rpc $ \caller -> do
+  pure $ withMyRPC rpc $ \caller -> do
    href <- pure (fromStringMay ref) `orDie` "invalid REFCHAN-HEAD-REF"
    callService @RpcRefChanHeadGet caller href >>= \case
      Left{} -> exitFailure
@ -113,7 +111,7 @@ pRefChanPropose = do
  fn  <- optional $ strOption (long "file" <> short 'f' <> help "file")
  dry <- optional (flag' True (long "dry" <> short 'n' <> help "only dump transaction")) <&> fromMaybe False
  sref <- strArgument (metavar "REFCHAH-KEY")
-  pure $ withRPC2 @UNIX opts $ \caller -> do
+  pure $ withMyRPC opts $ \caller -> do
    sc <- BS.readFile kra
    puk <- pure (fromStringMay @(RefChanId L4Proto) sref) `orDie` "can't parse refchan/public key"
    creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
@ -134,7 +132,7 @@ pRefChanNotify = do
  kra <- strOption (long "author" <> short 'a' <> help "author credentials")
  fn  <- optional $ strOption (long "file" <> short 'f' <> help "file")
  sref <- strArgument (metavar "REFCHAH-REF")
-  pure $ withRPC2 @UNIX opts $ \caller -> do
+  pure $ withMyRPC opts $ \caller -> do
    sc <- BS.readFile kra
    puk <- pure (fromStringMay @(RefChanId L4Proto) sref) `orDie` "can't parse refchan/public key"
    creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file"
@ -146,7 +144,7 @@ pRefChanGet :: Parser (IO ())
 pRefChanGet = do
  opts <- pRpcCommon
  sref <- strArgument (metavar "REFCHAH-KEY")
-  pure $ withRPC2 @UNIX opts $ \caller -> do
+  pure $ withMyRPC opts $ \caller -> do
    puk <- pure (fromStringMay @(RefChanId L4Proto) sref) `orDie` "can't parse refchan/public key"
    callService @RpcRefChanGet caller puk >>= \case
      Left{} -> exitFailure
@ -157,7 +155,7 @@ pRefChanFetch :: Parser (IO ())
 pRefChanFetch = do
  opts <- pRpcCommon
  ref <- strArgument (metavar "REFCHAH-KEY")
-  pure $ withRPC2 @UNIX opts $ \caller -> do
+  pure $ withMyRPC opts $ \caller -> do
    href <- pure (fromStringMay ref) `orDie` "invalid REFCHAN-HEAD-REF"
    void $ callService @RpcRefChanFetch caller href

--- a/hbs2-peer/app/PeerConfig.hs
+++ b/hbs2-peer/app/PeerConfig.hs
@ -183,6 +183,7 @@ peerConfigRead mbfp = do
          else pure x
      canonicalizeConfPaths _ _ x = pure x

+
 instance {-# OVERLAPPABLE #-} (IsString b, HasCfgKey a (Maybe b)) => HasCfgValue a (Maybe b) where
  cfgValue (PeerConfig syn) = val
    where
--- a/hbs2-peer/app/PeerMain.hs
+++ b/hbs2-peer/app/PeerMain.hs
@ -18,13 +18,12 @@ import HBS2.Data.Types.SignedBox
 import HBS2.Data.Types
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.IP.Addr
-import HBS2.Net.Messaging
 import HBS2.Net.Messaging.UDP
 import HBS2.Net.Messaging.TCP
 import HBS2.Net.PeerLocator
 import HBS2.Net.Proto as Proto
 import HBS2.Net.Proto.Definition
-import HBS2.Net.Proto.Dialog
+-- import HBS2.Net.Proto.Dialog
 import HBS2.Net.Proto.EncryptionHandshake
 import HBS2.Net.Proto.Event.PeerExpired
 import HBS2.Net.Proto.Peer
@ -35,7 +34,6 @@ import HBS2.Net.Proto.RefLog
 import HBS2.Net.Proto.RefChan
 import HBS2.Net.Proto.Sessions
 import HBS2.Net.Proto.Service
-import HBS2.Net.Messaging.Unix (UNIX,newMessagingUnix,runMessagingUnix)
 import HBS2.OrDie
 import HBS2.Storage.Simple
 import HBS2.Data.Detect
@ -46,7 +44,6 @@ import HBS2.System.Logger.Simple hiding (info)
 import Data.Config.Suckless.KeyValue(HasConf(..))

 import Brains
-import RPC2
 import PeerTypes
 import BlockDownload
 import BlockHttpDownload
@ -65,11 +62,13 @@ import ProxyMessaging
 -- import PeerMain.DialogCliCommand
 -- import PeerMain.Dialog.Server
 import PeerMeta
+import CLI.Common
 import CLI.RefChan
 import RefChan
 import Log

 import RPC2.Service.Unix as RPC2
+import RPC2.Service.Storage.Unix qualified as RS
 import RPC2.API

 import Codec.Serialise as Serialise
@ -270,14 +269,14 @@ runCLI = do

    pDie = do
      rpc <- pRpcCommon
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        l <- async $ void $ callService @RpcDie caller ()
        pause @'Seconds 0.25
        cancel l

    pPoke = do
      rpc <- pRpcCommon
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        r <- callService @RpcPoke caller ()
        case r of
          Left e -> err (viaShow e)
@ -286,19 +285,19 @@ runCLI = do
    pAnnounce = do
      rpc <- pRpcCommon
      h   <- strArgument ( metavar "HASH" )
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        void $ callService @RpcAnnounce caller h

    pFetch = do
      rpc <- pRpcCommon
      h   <- strArgument ( metavar "HASH" )
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        void $ callService @RpcFetch caller h

    pPing = do
      rpc <- pRpcCommon
      h   <- strArgument ( metavar "ADDR" )
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        callService @RpcPing caller h >>= \case
          Left e -> err (viaShow e)
          Right True  -> putStrLn "pong"
@ -306,7 +305,7 @@ runCLI = do

    pPeers = do
      rpc <- pRpcCommon
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        r <- callService @RpcPeers caller ()
        case r of
          Left e -> err (viaShow e)
@ -317,7 +316,7 @@ runCLI = do

    pPexInfo = do
      rpc <- pRpcCommon
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        r <- callService @RpcPexInfo caller ()
        case r of
          Left e -> err (viaShow e)
@ -334,7 +333,7 @@ runCLI = do
                  <|>
                hsubparser ( command "debug"  (info (onOff DebugOn) (progDesc "set debug")  ) )

-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        void $ callService @RpcLogLevel caller setlog

    pInit = do
@ -350,7 +349,7 @@ runCLI = do
    pRefLogSend = do
      rpc <- pRpcCommon
      kr <- strOption (long  "keyring" <> short 'k' <> help "reflog keyring" <> metavar "FILE")
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        s <- BS.readFile kr
        creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile s)) `orDie` "bad keyring file"
        bs <- BS.take defChunkSize  <$> BS.hGetContents stdin
@ -361,7 +360,7 @@ runCLI = do

    pRefLogSendRaw = do
      rpc <- pRpcCommon
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        bs <- LBS.take defChunkSize  <$> LBS.hGetContents stdin
        msg <- pure (deserialiseOrFail @(RefLogUpdate L4Proto) bs) `orDie` "Invalid reflog transaction"
        void $ callService @RpcRefLogPost caller msg
@ -369,14 +368,14 @@ runCLI = do
    pRefLogFetch = do
      rpc <- pRpcCommon
      ref <- strArgument ( metavar "REFLOG-KEY" )
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        href <- pure (fromStringMay ref) `orDie` "invalid REFLOG-KEY"
        void $ callService @RpcRefLogFetch caller href

    pRefLogGet = do
      rpc <- pRpcCommon
      ref <- strArgument ( metavar "REFLOG-KEY" )
-      pure $ withRPC2 @UNIX rpc $ \caller -> do
+      pure $ withMyRPC rpc $ \caller -> do
        href <- pure (fromStringMay ref) `orDie` "invalid REFLOG-KEY"
        callService @RpcRefLogGet caller href >>= \case
          Left{} -> exitFailure
@ -993,7 +992,17 @@ runPeer opts = Exception.handle (\e -> myException e
  rpc2 <- async (runReaderT RPC2.runService rpc2ctx)
  link rpc2

-  void $ waitAnyCancel $ w <> [udp,loop,rpc2,ann,messMcast,brainsThread]
+  rpcStorage <- async (runReaderT (RS.runService (AnyStorage s)) conf)
+  link rpcStorage
+
+  void $ waitAnyCancel $ w <> [ udp
+                              , loop
+                              , rpc2
+                              , rpcStorage
+                              , ann
+                              , messMcast
+                              , brainsThread
+                              ]

  liftIO $ simpleStorageStop s

--- a/hbs2-peer/app/PeerTypes.hs
+++ b/hbs2-peer/app/PeerTypes.hs
@ -580,4 +580,3 @@ trace1 :: (MonadIO m, ToLogStr a) => a -> m ()
 trace1 = log @TRACE1


-
--- a/hbs2-peer/app/RPC2.hs
+++ b/hbs2-peer/app/RPC2.hs
@ -1,60 +1,4 @@
-{-# Language TemplateHaskell #-}
 module RPC2 where

-import HBS2.Prelude
-import HBS2.Clock
-import HBS2.Net.Proto.Service
-import HBS2.Net.Messaging.Unix
-import HBS2.Net.Proto.Types
-
-import HBS2.System.Logger.Simple
-
 import Data.Config.Suckless.KeyValue()

-import RPC2.Service.Unix as RPC2
-import RPC2.API
-import PeerConfig
-
-import Data.Maybe
-import Control.Applicative
-import Lens.Micro.Platform
-import Control.Monad.Reader
-import UnliftIO
-
-data RPCOpt =
-  RPCOpt
-  { _rpcOptConf :: Maybe FilePath
-  , _rpcOptAddr :: Maybe String
-  }
-
-makeLenses 'RPCOpt
-
-
-withRPC2 :: forall e m . (e ~ UNIX, HasProtocol e (ServiceProto RPC2 e), MonadUnliftIO m)
-         => RPCOpt
-         -> ( ServiceCaller RPC2 e -> m () )
-         -> m ()
-
-withRPC2 o action = do
-  conf  <- peerConfigRead (view rpcOptConf o)
-  soConf <- runReaderT RPC2.getSocketName conf
-  let soOpt = view rpcOptAddr o
-  let soname = fromJust $ soOpt <|> Just soConf
-
-  debug $ "withRPC2" <+> pretty soname
-
-  client1 <- newMessagingUnix False 1.0 soname
-
-  m1 <- async $ runMessagingUnix client1
-  -- link m1
-
-  caller <- makeServiceCaller @RPC2 @UNIX (fromString soname)
-  p2 <- liftIO $ async $ runReaderT (runServiceClient @RPC2 @UNIX caller) client1
-
-  action caller
-
-  pause @'Seconds 0.05
-  cancel p2
-
-  void $ waitAnyCatchCancel [m1, p2]
-
--- a/hbs2-peer/app/RPC2/API.hs
+++ b/hbs2-peer/app/RPC2/API.hs
@ -45,4 +45,3 @@ type RPC2 = '[ RpcPoke
             , RpcDie
             ]

-
--- a/hbs2-peer/app/RPC2/Client/Unix.hs
+++ b/hbs2-peer/app/RPC2/Client/Unix.hs
@ -0,0 +1,6 @@
+module RPC2.Client.Unix
+  ( module HBS2.Peer.RPC.Client.Unix
+  )where
+
+import HBS2.Peer.RPC.Client.Unix
+
--- a/hbs2-peer/app/RPC2/Service/Storage/Unix.hs
+++ b/hbs2-peer/app/RPC2/Service/Storage/Unix.hs
@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module RPC2.Service.Storage.Unix
+  ( module HBS2.Peer.RPC.Internal.Service.Storage.Unix
+  )
+  where
+
+import HBS2.Peer.RPC.Internal.Service.Storage.Unix
+
--- a/hbs2-peer/app/RPC2/Storage.hs
+++ b/hbs2-peer/app/RPC2/Storage.hs
@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module RPC2.Storage
+  ( module HBS2.Peer.RPC.API.Storage
+  , module HBS2.Peer.RPC.Internal.Storage
+  ) where
+
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Internal.Storage
--- a/hbs2-peer/app/RPC2/Types.hs
+++ b/hbs2-peer/app/RPC2/Types.hs
@ -1,9 +1,13 @@
-module RPC2.Types where
+module RPC2.Types
+  ( module RPC2.Types
+  , module HBS2.Peer.RPC.Class
+  ) where

 import HBS2.Actors.Peer
 import HBS2.Net.Proto.Types
 import HBS2.Data.Types.Refs (HashRef)
 import HBS2.Data.Types.SignedBox
+import HBS2.Peer.RPC.Class

 import Data.Config.Suckless.Syntax
 import PeerTypes (DownloadEnv(..))
@ -24,6 +28,4 @@ data RPC2Context =
  , rpcDoRefChanNotify    :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO ()
  }

-class HasRpcContext a m where
-  getRpcContext :: m a

--- a/hbs2-peer/app/RPC2/Unix.hs
+++ b/hbs2-peer/app/RPC2/Unix.hs
@ -0,0 +1,48 @@
+module RPC2.Client.Unix where
+
+import HBS2.Prelude.Plated
+
+import HBS2.Clock
+import HBS2.Net.Messaging.Unix
+import HBS2.Net.Proto
+import HBS2.Net.Proto.Service
+
+import HBS2.System.Logger.Simple
+
+import RPC2.Service.Unix()
+
+import Data.Config.Suckless.KeyValue()
+
+
+import Control.Monad.Reader
+import UnliftIO
+
+withRPC2 :: forall api e m . ( e ~ UNIX
+                             , HasProtocol e (ServiceProto api e)
+                             , MonadUnliftIO m
+                             -- FIXME: remove-this-debug-shit
+                             , MonadUnliftIO m
+                             )
+         => FilePath
+         -> ( ServiceCaller api e -> m () )
+         -> m ()
+
+withRPC2 soname action = do
+
+  debug $ "withRPC2" <+> pretty soname
+
+  client1 <- newMessagingUnix False 1.0 soname
+
+  m1 <- async $ runMessagingUnix client1
+  -- link m1
+
+  caller <- makeServiceCaller @api @UNIX (fromString soname)
+  p2 <- liftIO $ async $ runReaderT (runServiceClient @api @e caller) client1
+
+  action caller
+
+  pause @'Seconds 0.05
+  cancel p2
+
+  void $ waitAnyCatchCancel [m1, p2]
+
--- a/hbs2-peer/hbs2-peer.cabal
+++ b/hbs2-peer/hbs2-peer.cabal
@ -123,6 +123,21 @@ common shared-properties
                     , TypeFamilies


+library
+    import:           shared-properties
+    import:           common-deps
+
+    hs-source-dirs:   lib
+
+    default-language: Haskell2010
+
+    exposed-modules:
+      HBS2.Peer.RPC.Class
+      HBS2.Peer.RPC.API
+      HBS2.Peer.RPC.API.Storage
+      HBS2.Peer.RPC.Client.Unix
+      HBS2.Peer.RPC.Internal.Storage
+      HBS2.Peer.RPC.Internal.Service.Storage.Unix

 executable hbs2-peer
    import:           shared-properties
@ -147,7 +162,9 @@ executable hbs2-peer
                    , Fetch
                    , Log
                    , RPC2
+                    , RPC2.Client.Unix
                    , RPC2.Service.Unix
+                    , RPC2.Service.Storage.Unix
                    , RPC2.API
                    , RPC2.Types
                    , RPC2.Poke
@ -160,6 +177,7 @@ executable hbs2-peer
                    , RPC2.Ping
                    , RPC2.RefLog
                    , RPC2.RefChan
+                    , RPC2.Storage
                    , PeerTypes
                    , PeerConfig
                    , RefLog
@ -168,11 +186,14 @@ executable hbs2-peer
                    , HttpWorker
                    , Brains
                    , ProxyMessaging
+                    , CLI.Common
                    , CLI.RefChan

    -- other-extensions:
-    build-depends:    base
+    build-depends:    base, hbs2-peer
+
    hs-source-dirs:   app
+
    default-language: Haskell2010


--- a/hbs2-peer/lib/HBS2/Peer/RPC/API.hs
+++ b/hbs2-peer/lib/HBS2/Peer/RPC/API.hs
@ -0,0 +1,3 @@
+module HBS2.Peer.RPC.API where
+
+
--- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs
+++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs
@ -0,0 +1,22 @@
+module HBS2.Peer.RPC.API.Storage where
+
+data RpcStorageHasBlock
+data RpcStorageGetBlock
+data RpcStorageEnqueueBlock
+data RpcStoragePutBlock
+data RpcStorageGetChunk
+data RpcStorageGetRef
+data RpcStorageUpdateRef
+data RpcStorageDelRef
+
+type StorageAPI = '[ RpcStorageHasBlock
+                   , RpcStorageHasBlock
+                   , RpcStorageGetBlock
+                   , RpcStorageEnqueueBlock
+                   , RpcStoragePutBlock
+                   , RpcStorageGetChunk
+                   , RpcStorageGetRef
+                   , RpcStorageUpdateRef
+                   , RpcStorageDelRef
+                   ]
+
--- a/hbs2-peer/lib/HBS2/Peer/RPC/Class.hs
+++ b/hbs2-peer/lib/HBS2/Peer/RPC/Class.hs
@ -0,0 +1,6 @@
+module HBS2.Peer.RPC.Class where
+
+class HasRpcContext a m where
+  getRpcContext :: m a
+
+
--- a/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs
+++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs
@ -0,0 +1,46 @@
+module HBS2.Peer.RPC.Client.Unix where
+
+import HBS2.Prelude.Plated
+
+import HBS2.Clock
+import HBS2.Net.Messaging.Unix
+import HBS2.Net.Proto
+import HBS2.Net.Proto.Service
+
+import HBS2.Peer.RPC.Internal.Service.Storage.Unix()
+
+import HBS2.System.Logger.Simple
+
+import Data.Kind
+import Control.Monad.Reader
+import UnliftIO
+
+withRPC2 :: forall (api :: [Type]) e m . ( e ~ UNIX
+                             , HasProtocol e (ServiceProto api e)
+                             , MonadUnliftIO m
+                             -- FIXME: remove-this-debug-shit
+                             , MonadUnliftIO m
+                             )
+         => FilePath
+         -> ( ServiceCaller api e -> m () )
+         -> m ()
+
+withRPC2 soname action = do
+
+  debug $ "withRPC2" <+> pretty soname
+
+  client1 <- newMessagingUnix False 1.0 soname
+
+  m1 <- async $ runMessagingUnix client1
+  -- link m1
+
+  caller <- makeServiceCaller @api @UNIX (fromString soname)
+  p2 <- liftIO $ async $ runReaderT (runServiceClient @api @e caller) client1
+
+  action caller
+
+  pause @'Seconds 0.05
+  cancel p2
+
+  void $ waitAnyCatchCancel [m1, p2]
+
--- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Service/Storage/Unix.hs
+++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Service/Storage/Unix.hs
@ -0,0 +1,81 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module HBS2.Peer.RPC.Internal.Service.Storage.Unix where
+
+import HBS2.Prelude.Plated
+import HBS2.Actors.Peer
+import HBS2.Net.Proto
+import HBS2.Net.Proto.Service
+import HBS2.Net.Messaging.Unix
+
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Internal.Storage
+
+import HBS2.System.Logger.Simple
+
+
+import Data.Config.Suckless.Syntax
+import Data.Config.Suckless.KeyValue
+
+import Data.ByteString.Lazy (ByteString)
+import Data.Text qualified as Text
+import Control.Monad.Reader
+import Codec.Serialise
+import UnliftIO
+
+
+instance HasProtocol UNIX  (ServiceProto StorageAPI UNIX) where
+  type instance ProtocolId (ServiceProto StorageAPI UNIX) = 0xDA2374610001
+  type instance Encoded UNIX = ByteString
+  decode = either (const Nothing) Just . deserialiseOrFail
+  encode = serialise
+
+
+sodef :: FilePath
+sodef = "/tmp/hbs2-rpc2.storage.socket"
+
+getSocketName :: HasConf m => m FilePath
+getSocketName = do
+  syn <- getConf
+
+  let soname = lastDef sodef [ Text.unpack n
+                             | ListVal @C (Key "rpc2.storage" [SymbolVal "unix", LitStrVal n]) <- syn
+                             ]
+  pure soname
+
+instance MonadUnliftIO m => (HasDeferred UNIX (ServiceProto StorageAPI UNIX) m) where
+  deferred _ m = void $ async m
+
+instance Monad m => HasFabriq UNIX (ReaderT (AnyStorage, MessagingUnix) m) where
+  getFabriq = asks (Fabriq . snd)
+
+instance Monad m => HasOwnPeer UNIX (ReaderT (AnyStorage, MessagingUnix) m) where
+  ownPeer = asks ( msgUnixSelf . snd )
+
+-- FIXME: fix-this-ugly-shit
+instance Monad m
+  => HasRpcContext AnyStorage (ResponseM UNIX (ReaderT (AnyStorage, MessagingUnix) m)) where
+  getRpcContext = lift $ asks fst
+
+
+runService :: ( HasConf m
+              , MonadUnliftIO m
+              , HasDeferred UNIX (ServiceProto StorageAPI UNIX) m
+              )
+           => AnyStorage -> m ()
+runService sto = do
+
+  soname <- getSocketName
+
+  notice $ "RPC2 Storage Service started" <+> pretty soname
+
+  server <- newMessagingUnixOpts [MUFork] True 1.0 soname
+  m1 <- async $ runMessagingUnix server
+  link m1
+
+  flip runReaderT (sto, server) do
+    runProto @UNIX
+      [ makeResponse (makeServer @StorageAPI)
+      ]
+
+
+
--- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs
+++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs
@ -0,0 +1,90 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module HBS2.Peer.RPC.Internal.Storage
+  ( module HBS2.Peer.RPC.API.Storage
+  , module HBS2.Peer.RPC.Class
+  )
+  where
+
+
+import HBS2.Actors.Peer.Types
+import HBS2.Prelude.Plated
+import HBS2.Data.Types.Refs (HashRef(..),RefAlias(..))
+import HBS2.Storage
+import HBS2.Peer.RPC.Class
+import HBS2.Peer.RPC.API.Storage
+
+import HBS2.Net.Proto.Service
+
+import Data.Functor
+import Data.ByteString.Lazy ( ByteString )
+import Control.Monad.Reader
+
+
+instance Monad m => HasRpcContext AnyStorage (ReaderT AnyStorage m) where
+  getRpcContext = ask
+
+instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageHasBlock where
+  type instance Input RpcStorageHasBlock = HashRef
+  type instance Output RpcStorageHasBlock = Maybe Integer
+
+  handleMethod href = do
+    sto <- getRpcContext @AnyStorage
+    liftIO $ hasBlock sto (fromHashRef href)
+
+instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageGetBlock where
+  type instance Input RpcStorageGetBlock = HashRef
+  type instance Output RpcStorageGetBlock = Maybe ByteString
+
+  handleMethod href = do
+    sto <- getRpcContext @AnyStorage
+    liftIO $ getBlock sto (fromHashRef href)
+
+instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageEnqueueBlock where
+  type instance Input RpcStorageEnqueueBlock = ByteString
+  type instance Output RpcStorageEnqueueBlock = Maybe HashRef
+
+  handleMethod lbs = do
+    sto <- getRpcContext @AnyStorage
+    liftIO $ enqueueBlock sto lbs <&> fmap HashRef
+
+instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStoragePutBlock where
+  type instance Input RpcStoragePutBlock = ByteString
+  type instance Output RpcStoragePutBlock = Maybe HashRef
+
+  handleMethod lbs = do
+    sto <- getRpcContext @AnyStorage
+    liftIO $ putBlock sto lbs <&> fmap HashRef
+
+instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageGetChunk where
+  type instance Input RpcStorageGetChunk = (HashRef, Offset, Size)
+  type instance Output RpcStorageGetChunk = Maybe ByteString
+
+  handleMethod (h,o,s) = do
+    sto <- getRpcContext @AnyStorage
+    liftIO $ getChunk sto (fromHashRef h) o s
+
+instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageGetRef where
+  type instance Input RpcStorageGetRef = RefAlias
+  type instance Output RpcStorageGetRef = Maybe HashRef
+
+  handleMethod ref = do
+    sto <- getRpcContext @AnyStorage
+    liftIO $ getRef sto ref <&> fmap HashRef
+
+instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageUpdateRef where
+  type instance Input RpcStorageUpdateRef = (RefAlias, HashRef)
+  type instance Output RpcStorageUpdateRef = ()
+
+  handleMethod (ref, val) = do
+    sto <- getRpcContext @AnyStorage
+    liftIO $ updateRef sto ref (fromHashRef val)
+
+instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageDelRef where
+  type instance Input RpcStorageDelRef = RefAlias
+  type instance Output RpcStorageDelRef = ()
+
+  handleMethod ref = do
+    sto <- getRpcContext @AnyStorage
+    liftIO $ delRef sto ref
+
+
--- a/hbs2-tests/hbs2-tests.cabal
+++ b/hbs2-tests/hbs2-tests.cabal
@ -18,7 +18,7 @@ common warnings

 common common-deps
    build-depends:
-          base, hbs2-core, hbs2-storage-simple
+          base, hbs2-core, hbs2-storage-simple, hbs2-peer
        , async
        , bytestring
        , cache
@ -313,6 +313,57 @@ test-suite test-proto-service
        , vector


+-- executable test-proto-service
+test-suite test-storage-service
+    import:           shared-properties
+    import:           common-deps
+    default-language: Haskell2010
+
+    ghc-options:
+      -- -prof
+      -- -fprof-auto
+
+    other-modules:
+
+    -- other-extensions:
+
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          StorageServiceTest.hs
+
+    build-depends:
+          base, hbs2-core, hbs2-storage-simple, hbs2-peer
+        , async
+        , attoparsec
+        , bytestring
+        , cache
+        , clock
+        , containers
+        , data-default
+        , data-textual
+        , directory
+        , hashable
+        , microlens-platform
+        , mtl
+        , mwc-random
+        , network
+        , network-ip
+        , prettyprinter
+        , QuickCheck
+        , random
+        , safe
+        , serialise
+        , stm
+        , streaming
+        , tasty
+        , tasty-hunit
+        , text
+        , transformers
+        , uniplate
+        , vector
+
+
+
 test-suite test-tcp
    import:           shared-properties
    import:           common-deps
--- a/hbs2-tests/test/StorageServiceTest.hs
+++ b/hbs2-tests/test/StorageServiceTest.hs
@ -0,0 +1,134 @@
+module Main where
+
+import HBS2.Hash
+import HBS2.Actors.Peer
+import HBS2.Actors.Peer.Types
+import HBS2.Data.Types.Refs
+import HBS2.Net.Messaging.Unix
+import HBS2.Net.Proto.Service
+import HBS2.Storage
+import HBS2.Storage.Simple (simpleStorageWorker,simpleStorageInit,SimpleStorage(..))
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client.Unix
+
+import HBS2.Peer.RPC.Internal.Storage()
+import HBS2.Peer.RPC.Internal.Service.Storage.Unix()
+
+import HBS2.OrDie
+
+import HBS2.System.Logger.Simple
+
+import Control.Monad.Reader
+import System.FilePath
+import UnliftIO
+import Prettyprinter
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy (ByteString)
+import Data.Maybe
+
+import Test.Tasty.HUnit
+
+main :: IO ()
+main = do
+
+  setLogging @DEBUG (logPrefix "[debug] ")
+  setLogging @INFO (logPrefix "")
+
+  withSystemTempDirectory "storageRpcTest" $ \dir -> do
+
+    let soname = dir </> "rpc.socket"
+
+    let opts = [ StoragePrefix (dir </> ".storage")
+               ]
+
+    sto <- simpleStorageInit @HbSync opts
+
+    worker <- async  (simpleStorageWorker sto)
+    link worker
+
+    let blk1 = "AAAAA"
+
+    h1 <- putBlock sto blk1 `orDie` "can't write block"
+
+    debug $ "written" <+> pretty h1
+
+    let rk1 = SomeRefKey ("SOMEREFKEY1" :: ByteString)
+
+    updateRef sto rk1 h1
+
+    rk1val <- getRef sto rk1
+
+    info $ "rk1val:" <+> pretty rk1val
+
+    rk1val1 <- getRef sto (refAlias rk1)
+
+    info $ "rk1val1:" <+> pretty rk1val1
+
+    assertBool "ref-alias-works-1" ( fromJust rk1val == fromJust rk1val1 )
+
+    server <- newMessagingUnix True 1.0 soname
+    m1 <- async $ runMessagingUnix server
+    link m1
+
+    proto <- async $ flip runReaderT (AnyStorage sto, server) do
+      runProto @UNIX
+        [ makeResponse (makeServer @StorageAPI)
+        ]
+
+    link proto
+
+    withRPC2 @StorageAPI soname $ \caller -> do
+
+      info "does it work?"
+
+      size <- callService @RpcStorageHasBlock caller (HashRef h1) `orDie` "can't read block"
+
+      info $ "got block size: " <+> pretty size
+
+      assertBool "block-size-1" (size == Just (fromIntegral $ LBS.length blk1))
+
+      b <-  callService @RpcStorageGetBlock caller (HashRef h1) `orDie` "can't read block"
+
+      info $ "got block" <+> viaShow b
+
+      assertBool "block-eq-1" ( b == Just blk1 )
+
+      let pechen = "PECHENTERSKI"
+
+      h2 <- callService @RpcStoragePutBlock caller pechen  `orDie` "service error"
+
+      info $ "stored block hash:" <+> pretty h2
+
+      let hh2  = fromJust h2
+
+      blk2 <- callService @RpcStorageGetBlock caller hh2 `orDie` "block lookup failed"
+
+      info $ "stored block value:" <+> viaShow blk2
+
+      assertBool "block-eq-2" (Just pechen == blk2)
+
+      let rk2 = refAlias rk1
+
+      rk2val <- callService @RpcStorageGetRef caller rk2 `orDie` "can't read ref"
+
+      info $ "rk2val:" <+> pretty rk2val
+
+      assertBool "ref-alias-works-2" (fromJust rk2val == HashRef h1)
+
+      callService @RpcStorageUpdateRef caller (rk2, hh2)
+
+      rk3val <- callService @RpcStorageGetRef caller rk2 `orDie` "can't update ref"
+
+      info $ "rk3val" <+> pretty rk3val
+
+      assertBool "ref-alias-update-works-1" (fromJust rk3val == hh2)
+
+      rk4val <- getRef sto rk1
+
+      info $ "rk4val" <+> pretty rk4val
+
+      assertBool "ref-alias-works-2" (fromJust rk4val == fromHashRef hh2)
+
+  setLoggingOff @DEBUG
+  setLoggingOff @INFO
+
				`@ -580,4 +580,3 @@ trace1 :: (MonadIO m, ToLogStr a) => a -> m ()`
				`trace1 = log @TRACE1`