From 28163d012304dd3d28c3e06102cd8c6ee56d3456 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Wed, 4 Oct 2023 13:38:35 +0300 Subject: [PATCH] storage rpc --- hbs2-core/lib/HBS2/Data/Types/Refs.hs | 17 ++- hbs2-core/lib/HBS2/Storage.hs | 7 +- hbs2-peer/app/CLI/Common.hs | 39 +++++ hbs2-peer/app/CLI/RefChan.hs | 24 ++-- hbs2-peer/app/PeerConfig.hs | 1 + hbs2-peer/app/PeerMain.hs | 43 +++--- hbs2-peer/app/PeerTypes.hs | 1 - hbs2-peer/app/RPC2.hs | 56 -------- hbs2-peer/app/RPC2/API.hs | 1 - hbs2-peer/app/RPC2/Client/Unix.hs | 6 + hbs2-peer/app/RPC2/Service/Storage/Unix.hs | 8 ++ hbs2-peer/app/RPC2/Storage.hs | 8 ++ hbs2-peer/app/RPC2/Types.hs | 8 +- hbs2-peer/app/RPC2/Unix.hs | 48 +++++++ hbs2-peer/hbs2-peer.cabal | 23 ++- hbs2-peer/lib/HBS2/Peer/RPC/API.hs | 3 + hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs | 22 +++ hbs2-peer/lib/HBS2/Peer/RPC/Class.hs | 6 + hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs | 46 ++++++ .../Peer/RPC/Internal/Service/Storage/Unix.hs | 81 +++++++++++ .../lib/HBS2/Peer/RPC/Internal/Storage.hs | 90 ++++++++++++ hbs2-tests/hbs2-tests.cabal | 53 ++++++- hbs2-tests/test/StorageServiceTest.hs | 134 ++++++++++++++++++ 23 files changed, 622 insertions(+), 103 deletions(-) create mode 100644 hbs2-peer/app/CLI/Common.hs create mode 100644 hbs2-peer/app/RPC2/Client/Unix.hs create mode 100644 hbs2-peer/app/RPC2/Service/Storage/Unix.hs create mode 100644 hbs2-peer/app/RPC2/Storage.hs create mode 100644 hbs2-peer/app/RPC2/Unix.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/API.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/Class.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/Internal/Service/Storage/Unix.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs create mode 100644 hbs2-tests/test/StorageServiceTest.hs diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 9731809b..f032df44 100644 --- 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) + diff --git a/hbs2-core/lib/HBS2/Storage.hs b/hbs2-core/lib/HBS2/Storage.hs index 198418f8..e0f8398e 100644 --- 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 diff --git a/hbs2-peer/app/CLI/Common.hs b/hbs2-peer/app/CLI/Common.hs new file mode 100644 index 00000000..6871d8c5 --- /dev/null +++ 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 + + diff --git a/hbs2-peer/app/CLI/RefChan.hs b/hbs2-peer/app/CLI/RefChan.hs index 5ab4cc26..fa5c35db 100644 --- 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 diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs index 2fa064f3..551d8334 100644 --- 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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 1eb3a30d..2bd38993 100644 --- 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 diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index 94798283..edd9b813 100644 --- 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 - diff --git a/hbs2-peer/app/RPC2.hs b/hbs2-peer/app/RPC2.hs index ca6b4f22..e3a79c7a 100644 --- 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] - diff --git a/hbs2-peer/app/RPC2/API.hs b/hbs2-peer/app/RPC2/API.hs index f402a17f..8d190632 100644 --- a/hbs2-peer/app/RPC2/API.hs +++ b/hbs2-peer/app/RPC2/API.hs @@ -45,4 +45,3 @@ type RPC2 = '[ RpcPoke , RpcDie ] - diff --git a/hbs2-peer/app/RPC2/Client/Unix.hs b/hbs2-peer/app/RPC2/Client/Unix.hs new file mode 100644 index 00000000..0aacf755 --- /dev/null +++ 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 + diff --git a/hbs2-peer/app/RPC2/Service/Storage/Unix.hs b/hbs2-peer/app/RPC2/Service/Storage/Unix.hs new file mode 100644 index 00000000..8393bebf --- /dev/null +++ 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 + diff --git a/hbs2-peer/app/RPC2/Storage.hs b/hbs2-peer/app/RPC2/Storage.hs new file mode 100644 index 00000000..d6a241e8 --- /dev/null +++ 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 diff --git a/hbs2-peer/app/RPC2/Types.hs b/hbs2-peer/app/RPC2/Types.hs index eb85314e..3fa8f4f5 100644 --- 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 diff --git a/hbs2-peer/app/RPC2/Unix.hs b/hbs2-peer/app/RPC2/Unix.hs new file mode 100644 index 00000000..9aef4e37 --- /dev/null +++ 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] + diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index d37fe63b..3db8ee29 100644 --- 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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API.hs new file mode 100644 index 00000000..65f73f34 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API.hs @@ -0,0 +1,3 @@ +module HBS2.Peer.RPC.API where + + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs new file mode 100644 index 00000000..8003a18a --- /dev/null +++ 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 + ] + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Class.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Class.hs new file mode 100644 index 00000000..d7ab268c --- /dev/null +++ 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 + + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs new file mode 100644 index 00000000..78fc08d5 --- /dev/null +++ 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] + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Service/Storage/Unix.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Service/Storage/Unix.hs new file mode 100644 index 00000000..0b93d46e --- /dev/null +++ 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) + ] + + + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs new file mode 100644 index 00000000..227c0193 --- /dev/null +++ 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 + + diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index 27579b49..df56619c 100644 --- 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 diff --git a/hbs2-tests/test/StorageServiceTest.hs b/hbs2-tests/test/StorageServiceTest.hs new file mode 100644 index 00000000..af5d7c35 --- /dev/null +++ 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 +