storage rpc

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)
+
 

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

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
+
+

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
 

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

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
 

hbs2-peer/app/PeerTypes.hs

@@ -580,4 +580,3 @@ trace1 :: (MonadIO m, ToLogStr a) => a -> m ()
 trace1 = log @TRACE1
 
 
-

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]
-

hbs2-peer/app/RPC2/API.hs

@@ -45,4 +45,3 @@ type RPC2 = '[ RpcPoke
              , RpcDie
              ]
 
-

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
+

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
+

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

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
 

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]
+

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
 
 

hbs2-peer/lib/HBS2/Peer/RPC/API.hs

@@ -0,0 +1,3 @@
+module HBS2.Peer.RPC.API where
+
+

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
+                   ]
+

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
+
+

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]
+

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)
+      ]
+
+
+

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
+
+

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

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
+