From 15d6a1d06f4b8c5e4751096e6ba5da2695f66b6b Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 5 Oct 2023 11:54:36 +0300 Subject: [PATCH] modular-rpc-api 1. Making the API modular 2. Running all via single socket, including storage --- hbs2-core/lib/HBS2/Net/Messaging/Unix.hs | 7 +- hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs | 8 +- hbs2-peer/app/CLI/Common.hs | 19 ++-- hbs2-peer/app/CLI/RefChan.hs | 21 ++-- hbs2-peer/app/Fetch.hs | 4 +- hbs2-peer/app/PeerConfig.hs | 15 +++ hbs2-peer/app/PeerMain.hs | 65 ++++++----- hbs2-peer/app/PeerTypes.hs | 5 - hbs2-peer/app/RPC2/API.hs | 47 -------- hbs2-peer/app/RPC2/Announce.hs | 11 +- hbs2-peer/app/RPC2/Die.hs | 5 +- hbs2-peer/app/RPC2/Fetch.hs | 14 +-- hbs2-peer/app/RPC2/LogLevel.hs | 5 +- hbs2-peer/app/RPC2/Peer.hs | 20 ++++ hbs2-peer/app/RPC2/Peer/API.hs | 42 +++++++ hbs2-peer/app/RPC2/Peers.hs | 11 +- hbs2-peer/app/RPC2/PexInfo.hs | 15 ++- hbs2-peer/app/RPC2/Ping.hs | 12 +- hbs2-peer/app/RPC2/Poke.hs | 14 ++- hbs2-peer/app/RPC2/RefChan.hs | 105 +++++++++--------- hbs2-peer/app/RPC2/RefLog.hs | 45 ++++++-- hbs2-peer/app/RPC2/Service/Storage/Unix.hs | 8 -- hbs2-peer/app/RPC2/Service/Unix.hs | 89 --------------- hbs2-peer/app/RPC2/Storage.hs | 8 -- hbs2-peer/app/RPC2/Types.hs | 31 +----- hbs2-peer/app/RPC2/Unix.hs | 48 -------- hbs2-peer/hbs2-peer.cabal | 12 +- hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs | 24 ++++ hbs2-peer/lib/HBS2/Peer/RPC/Class.hs | 8 +- hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs | 3 +- .../Peer/RPC/Internal/Service/Storage/Unix.hs | 81 -------------- .../lib/HBS2/Peer/RPC/Internal/Storage.hs | 43 +++---- hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs | 47 ++++++++ hbs2-tests/test/StorageServiceTest.hs | 22 +++- 34 files changed, 415 insertions(+), 499 deletions(-) delete mode 100644 hbs2-peer/app/RPC2/API.hs create mode 100644 hbs2-peer/app/RPC2/Peer.hs create mode 100644 hbs2-peer/app/RPC2/Peer/API.hs delete mode 100644 hbs2-peer/app/RPC2/Service/Storage/Unix.hs delete mode 100644 hbs2-peer/app/RPC2/Service/Unix.hs delete mode 100644 hbs2-peer/app/RPC2/Storage.hs delete mode 100644 hbs2-peer/app/RPC2/Unix.hs delete mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/Internal/Service/Storage/Unix.hs create mode 100644 hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs index 52bd973b..ab72d1ef 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs @@ -1,6 +1,10 @@ {-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} -module HBS2.Net.Messaging.Unix where +module HBS2.Net.Messaging.Unix + ( module HBS2.Net.Messaging.Unix + , module HBS2.Net.Messaging + , module HBS2.Net.Proto.Types + ) where import HBS2.Prelude.Plated import HBS2.Net.Proto.Types @@ -20,7 +24,6 @@ import Data.Functor import Data.Hashable import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict (HashMap) -import Data.List qualified as List import Network.ByteOrder hiding (ByteString) import Network.Socket import Network.Socket.ByteString diff --git a/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs b/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs index 370e1a7d..6aa966c9 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs @@ -141,10 +141,14 @@ getAllPex1Peers = do _ -> pure mempty pure $ mconcat pa' +type PexInfoContext e m = ( Sessions e (KnownPeer e) m + , HasPeerLocator L4Proto m + -- , Expired e ( + ) + getAllPex2Peers :: forall e m . ( MonadIO m - , Sessions e (KnownPeer e) m - , HasPeerLocator L4Proto m + , PexInfoContext e m , e ~ L4Proto ) => m [PeerAddr L4Proto] diff --git a/hbs2-peer/app/CLI/Common.hs b/hbs2-peer/app/CLI/Common.hs index 6871d8c5..bfa92c06 100644 --- a/hbs2-peer/app/CLI/Common.hs +++ b/hbs2-peer/app/CLI/Common.hs @@ -2,17 +2,14 @@ module CLI.Common where import HBS2.Net.Messaging.Unix +import HBS2.Net.Proto import HBS2.Net.Proto.Service import PeerConfig -import RPC2.Client.Unix -import RPC2.Service.Unix (getSocketName) -import RPC2.API +import HBS2.Peer.RPC.Client.Unix -import Control.Applicative -import Control.Monad.Reader -import Data.Maybe +import Data.Kind import Lens.Micro.Platform import UnliftIO @@ -24,16 +21,16 @@ data RPCOpt = makeLenses 'RPCOpt -withMyRPC :: forall api m . (MonadUnliftIO m, api ~ RPC2) +withMyRPC :: forall (api :: [Type]) m . ( MonadUnliftIO m + , HasProtocol UNIX (ServiceProto api UNIX) + ) => 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 + let soname = getRpcSocketName conf + withRPC2 @api @UNIX soname m diff --git a/hbs2-peer/app/CLI/RefChan.hs b/hbs2-peer/app/CLI/RefChan.hs index fa5c35db..94077316 100644 --- a/hbs2-peer/app/CLI/RefChan.hs +++ b/hbs2-peer/app/CLI/RefChan.hs @@ -7,14 +7,12 @@ import HBS2.Net.Proto.Definition() import HBS2.Net.Proto.RefChan import HBS2.Net.Proto.Types import HBS2.Data.Types.SignedBox +import HBS2.Net.Proto.Service import HBS2.OrDie --- FIXME: to-remove-old-rpc --- import CLI.Common -import RPC2.API -import RPC2.Service.Unix as RPC2 +import RPC2.RefChan import Options.Applicative import Data.ByteString qualified as BS @@ -24,7 +22,6 @@ 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")) @@ -80,7 +77,7 @@ pRefChanHeadPost :: Parser (IO ()) pRefChanHeadPost = do opts <- pRpcCommon ref <- strArgument (metavar "HEAD-BLOCK-TREE-HASH") - pure $ withMyRPC opts $ \caller -> do + pure $ withMyRPC @RefChanAPI opts $ \caller -> do href <- pure (fromStringMay ref) `orDie` "HEAD-BLOCK-TREE-HASH" -- FIXME: proper-error-handling void $ callService @RpcRefChanHeadPost caller href @@ -89,7 +86,7 @@ pRefChanHeadFetch :: Parser (IO ()) pRefChanHeadFetch = do opts <- pRpcCommon ref <- strArgument (metavar "REFCHAH-HEAD-KEY") - pure $ withMyRPC opts $ \caller -> do + pure $ withMyRPC @RefChanAPI opts $ \caller -> do href <- pure (fromStringMay ref) `orDie` "invalid REFCHAN-HEAD-REF" void $ callService @RpcRefChanHeadFetch caller href @@ -97,7 +94,7 @@ pRefChanHeadGet :: Parser (IO ()) pRefChanHeadGet = do rpc <- pRpcCommon ref <- strArgument (metavar "REFCHAH-HEAD-KEY") - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @RefChanAPI rpc $ \caller -> do href <- pure (fromStringMay ref) `orDie` "invalid REFCHAN-HEAD-REF" callService @RpcRefChanHeadGet caller href >>= \case Left{} -> exitFailure @@ -111,7 +108,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 $ withMyRPC opts $ \caller -> do + pure $ withMyRPC @RefChanAPI 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" @@ -132,7 +129,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 $ withMyRPC opts $ \caller -> do + pure $ withMyRPC @RefChanAPI 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" @@ -144,7 +141,7 @@ pRefChanGet :: Parser (IO ()) pRefChanGet = do opts <- pRpcCommon sref <- strArgument (metavar "REFCHAH-KEY") - pure $ withMyRPC opts $ \caller -> do + pure $ withMyRPC @RefChanAPI opts $ \caller -> do puk <- pure (fromStringMay @(RefChanId L4Proto) sref) `orDie` "can't parse refchan/public key" callService @RpcRefChanGet caller puk >>= \case Left{} -> exitFailure @@ -155,7 +152,7 @@ pRefChanFetch :: Parser (IO ()) pRefChanFetch = do opts <- pRpcCommon ref <- strArgument (metavar "REFCHAH-KEY") - pure $ withMyRPC opts $ \caller -> do + pure $ withMyRPC @RefChanAPI opts $ \caller -> do href <- pure (fromStringMay ref) `orDie` "invalid REFCHAN-HEAD-REF" void $ callService @RpcRefChanFetch caller href diff --git a/hbs2-peer/app/Fetch.hs b/hbs2-peer/app/Fetch.hs index c849b3c2..fd4a7b30 100644 --- a/hbs2-peer/app/Fetch.hs +++ b/hbs2-peer/app/Fetch.hs @@ -11,13 +11,13 @@ import PeerTypes import DownloadQ import BlockDownload -fetch :: forall e m . (e ~ L4Proto, MonadIO m) +fetchHash :: forall e m . (e ~ L4Proto, MonadIO m) => PeerEnv e -> DownloadEnv e -> HashRef -> m () -fetch penv denv href = do +fetchHash penv denv href = do debug $ "fetchAction" <+> pretty h liftIO $ withPeerM penv $ do downloadLogAppend @e h diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs index 551d8334..f2cd3730 100644 --- a/hbs2-peer/app/PeerConfig.hs +++ b/hbs2-peer/app/PeerConfig.hs @@ -128,6 +128,21 @@ peerConfDef = [qc| download-log "./download-log" |] +rpcSoDef :: FilePath +rpcSoDef = "/tmp/hbs2-rpc.socket" + +getRpcSocketNameM :: HasConf m => m FilePath +getRpcSocketNameM = do + syn <- getConf + + let soname = lastDef rpcSoDef [ Text.unpack n + | ListVal @C (Key "rpc2" [SymbolVal "unix", LitStrVal n]) <- syn + ] + pure soname + +getRpcSocketName :: PeerConfig -> FilePath +getRpcSocketName = runReader getRpcSocketNameM + peerConfigRead :: MonadIO m => Maybe FilePath -> m PeerConfig peerConfigRead mbfp = do diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 2bd38993..0bd91806 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -20,6 +20,7 @@ import HBS2.Net.Auth.Credentials import HBS2.Net.IP.Addr import HBS2.Net.Messaging.UDP import HBS2.Net.Messaging.TCP +import HBS2.Net.Messaging.Unix import HBS2.Net.PeerLocator import HBS2.Net.Proto as Proto import HBS2.Net.Proto.Definition @@ -40,9 +41,6 @@ import HBS2.Data.Detect import HBS2.System.Logger.Simple hiding (info) --- FIXME: move-to-peer-config-eventually -import Data.Config.Suckless.KeyValue(HasConf(..)) - import Brains import PeerTypes import BlockDownload @@ -65,11 +63,16 @@ import PeerMeta import CLI.Common import CLI.RefChan import RefChan +import Fetch (fetchHash) import Log -import RPC2.Service.Unix as RPC2 -import RPC2.Service.Storage.Unix qualified as RS -import RPC2.API +import HBS2.Peer.RPC.Internal.Types() +import HBS2.Peer.RPC.Internal.Storage() +import HBS2.Peer.RPC.API.Storage + +import RPC2.Peer +import RPC2.RefLog +import RPC2.RefChan import Codec.Serialise as Serialise import Control.Concurrent.STM @@ -88,7 +91,6 @@ import Data.Map qualified as Map import Data.Maybe import Data.Set qualified as Set import Data.Set (Set) -import Data.Text qualified as Text import Data.HashSet qualified as HashSet import Lens.Micro.Platform as Lens import Network.Socket @@ -269,14 +271,14 @@ runCLI = do pDie = do rpc <- pRpcCommon - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @PeerAPI rpc $ \caller -> do l <- async $ void $ callService @RpcDie caller () pause @'Seconds 0.25 cancel l pPoke = do rpc <- pRpcCommon - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @PeerAPI rpc $ \caller -> do r <- callService @RpcPoke caller () case r of Left e -> err (viaShow e) @@ -285,19 +287,19 @@ runCLI = do pAnnounce = do rpc <- pRpcCommon h <- strArgument ( metavar "HASH" ) - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @PeerAPI rpc $ \caller -> do void $ callService @RpcAnnounce caller h pFetch = do rpc <- pRpcCommon h <- strArgument ( metavar "HASH" ) - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @PeerAPI rpc $ \caller -> do void $ callService @RpcFetch caller h pPing = do rpc <- pRpcCommon h <- strArgument ( metavar "ADDR" ) - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @PeerAPI rpc $ \caller -> do callService @RpcPing caller h >>= \case Left e -> err (viaShow e) Right True -> putStrLn "pong" @@ -305,7 +307,7 @@ runCLI = do pPeers = do rpc <- pRpcCommon - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @PeerAPI rpc $ \caller -> do r <- callService @RpcPeers caller () case r of Left e -> err (viaShow e) @@ -316,7 +318,7 @@ runCLI = do pPexInfo = do rpc <- pRpcCommon - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @PeerAPI rpc $ \caller -> do r <- callService @RpcPexInfo caller () case r of Left e -> err (viaShow e) @@ -333,7 +335,7 @@ runCLI = do <|> hsubparser ( command "debug" (info (onOff DebugOn) (progDesc "set debug") ) ) - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @PeerAPI rpc $ \caller -> do void $ callService @RpcLogLevel caller setlog pInit = do @@ -349,7 +351,7 @@ runCLI = do pRefLogSend = do rpc <- pRpcCommon kr <- strOption (long "keyring" <> short 'k' <> help "reflog keyring" <> metavar "FILE") - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @RefLogAPI 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 @@ -360,7 +362,7 @@ runCLI = do pRefLogSendRaw = do rpc <- pRpcCommon - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @RefLogAPI 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 @@ -368,14 +370,14 @@ runCLI = do pRefLogFetch = do rpc <- pRpcCommon ref <- strArgument ( metavar "REFLOG-KEY" ) - pure $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @RefLogAPI 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 $ withMyRPC rpc $ \caller -> do + pure $ withMyRPC @RefLogAPI rpc $ \caller -> do href <- pure (fromStringMay ref) `orDie` "invalid REFLOG-KEY" callService @RpcRefLogGet caller href >>= \case Left{} -> exitFailure @@ -978,27 +980,38 @@ runPeer opts = Exception.handle (\e -> myException e , http ] + let rpcSa = getRpcSocketName conf + rpc2msg <- newMessagingUnixOpts [MUFork] True 1.0 rpcSa + let rpc2ctx = RPC2Context { rpcConfig = fromPeerConfig conf + , rpcMessaging = rpc2msg , rpcPokeAnswer = pokeAnsw , rpcPeerEnv = penv - , rpcDownloadEnv = denv , rpcLocalMultiCast = localMulticast , rpcStorage = AnyStorage s + , rpcDoFetch = liftIO . fetchHash penv denv , rpcDoRefChanHeadPost = refChanHeadPostAction , rpcDoRefChanPropose = refChanProposeAction , rpcDoRefChanNotify = refChanNotifyAction } - rpc2 <- async (runReaderT RPC2.runService rpc2ctx) - link rpc2 + m1 <- async $ runMessagingUnix rpc2msg + link m1 - rpcStorage <- async (runReaderT (RS.runService (AnyStorage s)) conf) - link rpcStorage + rpcProto <- async $ flip runReaderT rpc2ctx do + runProto @UNIX + [ makeResponse (makeServer @PeerAPI) + , makeResponse (makeServer @RefLogAPI) + , makeResponse (makeServer @RefChanAPI) + , makeResponse (makeServer @StorageAPI) + ] + + link rpcProto void $ waitAnyCancel $ w <> [ udp , loop - , rpc2 - , rpcStorage + , m1 + , rpcProto , ann , messMcast , brainsThread diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index edd9b813..0f61718d 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -6,7 +6,6 @@ module PeerTypes where import HBS2.Actors.Peer -import HBS2.Actors.Peer.Types import HBS2.Clock import HBS2.Data.Types.SignedBox import HBS2.Data.Types.Peer @@ -16,7 +15,6 @@ import HBS2.Defaults import HBS2.Events import HBS2.Hash import HBS2.Merkle (AnnMetaData) -import HBS2.Net.Auth.Credentials import HBS2.Net.IP.Addr import HBS2.Net.Proto import HBS2.Net.Proto.Peer @@ -36,14 +34,11 @@ import PeerConfig import Prelude hiding (log) import Data.Foldable (for_) import Control.Concurrent.Async --- import Control.Concurrent.STM import Control.Monad.Reader import Control.Monad.Writer qualified as W -import Crypto.Saltine.Core.Box qualified as Encrypt import Data.ByteString.Lazy (ByteString) import Data.Cache (Cache) import Data.Cache qualified as Cache -import Data.HashSet (HashSet) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Data.List qualified as L diff --git a/hbs2-peer/app/RPC2/API.hs b/hbs2-peer/app/RPC2/API.hs deleted file mode 100644 index 8d190632..00000000 --- a/hbs2-peer/app/RPC2/API.hs +++ /dev/null @@ -1,47 +0,0 @@ -module RPC2.API - ( module RPC2.API - , module RPC2.Poke - , module RPC2.Ping - , module RPC2.Peers - , module RPC2.PexInfo - , module RPC2.Announce - , module RPC2.Fetch - , module RPC2.Die - , module RPC2.LogLevel - , module RPC2.RefLog - , module RPC2.RefChan - , module RPC2.Types - ) where - -import RPC2.Announce -import RPC2.Die -import RPC2.Fetch -import RPC2.Poke -import RPC2.Ping -import RPC2.Peers -import RPC2.PexInfo -import RPC2.LogLevel -import RPC2.RefLog -import RPC2.RefChan -import RPC2.Types - -type RPC2 = '[ RpcPoke - , RpcPing - , RpcAnnounce - , RpcFetch - , RpcPeers - , RpcPexInfo - , RpcRefLogGet - , RpcRefLogFetch - , RpcRefLogPost - , RpcRefChanHeadGet - , RpcRefChanHeadFetch - , RpcRefChanHeadPost - , RpcRefChanGet - , RpcRefChanFetch - , RpcRefChanPropose - , RpcRefChanNotify - , RpcLogLevel - , RpcDie - ] - diff --git a/hbs2-peer/app/RPC2/Announce.hs b/hbs2-peer/app/RPC2/Announce.hs index 0a383eb9..7a28131d 100644 --- a/hbs2-peer/app/RPC2/Announce.hs +++ b/hbs2-peer/app/RPC2/Announce.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} module RPC2.Announce where import HBS2.Prelude.Plated @@ -7,16 +9,17 @@ import HBS2.Net.Proto.Service import HBS2.System.Logger.Simple import SendBlockAnnounce -import RPC2.Types -data RpcAnnounce +import HBS2.Peer.RPC.Internal.Types +import RPC2.Peer.API -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcAnnounce where + +instance (MonadIO m,HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcAnnounce where type instance Input RpcAnnounce = HashRef type instance Output RpcAnnounce = () handleMethod href = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @PeerAPI debug $ "rpc2.announce:" <+> pretty href sendBlockAnnounce (rpcPeerEnv co) (rpcLocalMultiCast co) (fromHashRef href) diff --git a/hbs2-peer/app/RPC2/Die.hs b/hbs2-peer/app/RPC2/Die.hs index 1b228032..b84f2c43 100644 --- a/hbs2-peer/app/RPC2/Die.hs +++ b/hbs2-peer/app/RPC2/Die.hs @@ -7,11 +7,12 @@ import HBS2.Net.Proto.Service import HBS2.System.Logger.Simple import Data.Config.Suckless.KeyValue -import RPC2.Types +import HBS2.Peer.RPC.Internal.Types +import RPC2.Peer.API + import System.Exit qualified as Exit import Control.Concurrent.Async -data RpcDie instance (MonadIO m) => HandleMethod m RpcDie where type instance Input RpcDie = () diff --git a/hbs2-peer/app/RPC2/Fetch.hs b/hbs2-peer/app/RPC2/Fetch.hs index 9b0276ab..305b9e35 100644 --- a/hbs2-peer/app/RPC2/Fetch.hs +++ b/hbs2-peer/app/RPC2/Fetch.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} module RPC2.Fetch where import HBS2.Prelude.Plated @@ -6,19 +8,17 @@ import HBS2.Net.Proto.Service import HBS2.System.Logger.Simple -import Fetch -import RPC2.Types +import HBS2.Peer.RPC.Internal.Types +import RPC2.Peer.API -data RpcFetch - -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcFetch where +instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcFetch where type instance Input RpcFetch = HashRef type instance Output RpcFetch = () handleMethod href = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @PeerAPI debug $ "rpc2.fetch:" <+> pretty href - fetch (rpcPeerEnv co) (rpcDownloadEnv co) href + liftIO $ rpcDoFetch co href diff --git a/hbs2-peer/app/RPC2/LogLevel.hs b/hbs2-peer/app/RPC2/LogLevel.hs index 331a749c..192433d8 100644 --- a/hbs2-peer/app/RPC2/LogLevel.hs +++ b/hbs2-peer/app/RPC2/LogLevel.hs @@ -5,11 +5,12 @@ import HBS2.Net.Proto.Service import Log +import HBS2.Peer.RPC.Internal.Types +import RPC2.Peer.API + import HBS2.System.Logger.Simple import Codec.Serialise -data RpcLogLevel - data SetLogging = DebugOn Bool | TraceOn Bool diff --git a/hbs2-peer/app/RPC2/Peer.hs b/hbs2-peer/app/RPC2/Peer.hs new file mode 100644 index 00000000..0a39b854 --- /dev/null +++ b/hbs2-peer/app/RPC2/Peer.hs @@ -0,0 +1,20 @@ +module RPC2.Peer + ( module RPC2.Peer + , module RPC2.Peer.API + , module RPC2.LogLevel + -- , SetLogging(..) + ) where + +import RPC2.Peer.API +import RPC2.Announce() +import RPC2.Fetch() +import RPC2.Peers() +import RPC2.PexInfo() +import RPC2.Ping() +import RPC2.Poke +import RPC2.RefLog() +import RPC2.RefChan() +import RPC2.Die() +import RPC2.LogLevel +-- import RPC2.LogLevel(SetLogging(..)) + diff --git a/hbs2-peer/app/RPC2/Peer/API.hs b/hbs2-peer/app/RPC2/Peer/API.hs new file mode 100644 index 00000000..22073e12 --- /dev/null +++ b/hbs2-peer/app/RPC2/Peer/API.hs @@ -0,0 +1,42 @@ +module RPC2.Peer.API where + +import HBS2.Net.Messaging.Unix +import HBS2.Net.Proto.Service +import HBS2.Actors.Peer + +import HBS2.Peer.RPC.Internal.Types + +import Control.Monad.Reader +import Data.ByteString.Lazy (ByteString) +import Codec.Serialise + +data RpcPoke +data RpcAnnounce +data RpcPing +data RpcPexInfo +data RpcPeers +data RpcFetch +data RpcLogLevel +data RpcDie + +type PeerAPI = '[ RpcPoke + , RpcPing + , RpcAnnounce + , RpcFetch + , RpcPeers + , RpcPexInfo + , RpcLogLevel + , RpcDie + ] + +instance HasProtocol UNIX (ServiceProto PeerAPI UNIX) where + type instance ProtocolId (ServiceProto PeerAPI UNIX) = 0xDA2374610000 + type instance Encoded UNIX = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise + +instance (Monad m) + => HasRpcContext PeerAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where + -- type instance RpcContext PeerAPI = RPC2Context + getRpcContext = lift ask + diff --git a/hbs2-peer/app/RPC2/Peers.hs b/hbs2-peer/app/RPC2/Peers.hs index 31e8ccae..b7b2789a 100644 --- a/hbs2-peer/app/RPC2/Peers.hs +++ b/hbs2-peer/app/RPC2/Peers.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} module RPC2.Peers where import HBS2.Actors.Peer @@ -12,20 +14,20 @@ import HBS2.Net.Proto.Definition() import PeerTypes -import RPC2.Types +import HBS2.Peer.RPC.Internal.Types +import RPC2.Peer.API import Control.Monad import Lens.Micro.Platform import Data.Maybe -data RpcPeers -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcPeers where +instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcPeers where type instance Input RpcPeers = () type instance Output RpcPeers = [(PubKey 'Sign HBS2Basic, PeerAddr L4Proto)] handleMethod _ = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @PeerAPI withPeerM (rpcPeerEnv co) $ do ps <- getKnownPeers @L4Proto r <- forM ps $ \p -> do @@ -38,4 +40,3 @@ instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcPeers whe pure $ catMaybes r - diff --git a/hbs2-peer/app/RPC2/PexInfo.hs b/hbs2-peer/app/RPC2/PexInfo.hs index 007c8c83..6add1522 100644 --- a/hbs2-peer/app/RPC2/PexInfo.hs +++ b/hbs2-peer/app/RPC2/PexInfo.hs @@ -1,23 +1,26 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} module RPC2.PexInfo where - import HBS2.Actors.Peer import HBS2.Net.Proto.Types import HBS2.Net.Proto.Service import HBS2.Prelude.Plated +import HBS2.Net.Proto.Definition() import HBS2.Net.Proto.PeerExchange -import RPC2.Types +import HBS2.Peer.RPC.Internal.Types +import RPC2.Peer.API -data RpcPexInfo - -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcPexInfo where +instance ( MonadIO m + , HasRpcContext PeerAPI RPC2Context m + ) => HandleMethod m RpcPexInfo where type instance Input RpcPexInfo = () type instance Output RpcPexInfo = [PeerAddr L4Proto] handleMethod _ = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @PeerAPI withPeerM (rpcPeerEnv co) getAllPex2Peers diff --git a/hbs2-peer/app/RPC2/Ping.hs b/hbs2-peer/app/RPC2/Ping.hs index 539a2a84..266604c2 100644 --- a/hbs2-peer/app/RPC2/Ping.hs +++ b/hbs2-peer/app/RPC2/Ping.hs @@ -1,23 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} module RPC2.Ping where import HBS2.Prelude.Plated import HBS2.Actors.Peer +-- import HBS2.Actors.Peer.Types import HBS2.Net.Proto.Types import HBS2.Net.Proto.Service import HBS2.System.Logger.Simple +import HBS2.Peer.RPC.Internal.Types + import PeerTypes -import RPC2.Types +import RPC2.Peer.API -data RpcPing -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcPing where +instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcPing where type instance Input RpcPing = PeerAddr L4Proto type instance Output RpcPing = Bool handleMethod pa = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @PeerAPI debug $ "rpc2.ping:" <+> pretty pa liftIO $ withPeerM (rpcPeerEnv co) $ do pingPeerWait pa diff --git a/hbs2-peer/app/RPC2/Poke.hs b/hbs2-peer/app/RPC2/Poke.hs index 58490f60..92e9e496 100644 --- a/hbs2-peer/app/RPC2/Poke.hs +++ b/hbs2-peer/app/RPC2/Poke.hs @@ -1,21 +1,25 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} module RPC2.Poke where import HBS2.Prelude.Plated import HBS2.Net.Proto.Service import HBS2.System.Logger.Simple -import Data.Config.Suckless.KeyValue -import RPC2.Types +import HBS2.Peer.RPC.Internal.Types +import RPC2.Peer.API -data RpcPoke -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcPoke where +instance ( MonadIO m + , HasRpcContext PeerAPI RPC2Context m) + + => HandleMethod m RpcPoke where type instance Input RpcPoke = () type instance Output RpcPoke = String handleMethod n = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @PeerAPI debug $ "rpc2.poke: alive and kicking!" <+> pretty n pure $ rpcPokeAnswer co diff --git a/hbs2-peer/app/RPC2/RefChan.hs b/hbs2-peer/app/RPC2/RefChan.hs index 9617485f..954f9bb1 100644 --- a/hbs2-peer/app/RPC2/RefChan.hs +++ b/hbs2-peer/app/RPC2/RefChan.hs @@ -1,30 +1,33 @@ -module RPC2.RefChan where - +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +module RPC2.RefChan + ( module RPC2.RefChan + , module HBS2.Peer.RPC.Internal.Types + ) where import HBS2.Prelude.Plated import HBS2.Actors.Peer -import HBS2.Hash import HBS2.Base58 -import HBS2.Data.Detect import HBS2.Data.Types.Refs (HashRef(..)) import HBS2.Net.Proto.Definition() import HBS2.Net.Proto.Service import HBS2.Net.Proto.Types import HBS2.Data.Types.SignedBox import HBS2.Net.Proto.RefChan +import HBS2.Net.Messaging.Unix import HBS2.Storage +import HBS2.Peer.RPC.Internal.Types + import HBS2.System.Logger.Simple import PeerTypes -import RPC2.Types -import Data.ByteString (ByteString) +import Data.ByteString.Lazy (ByteString) +import Data.ByteString qualified as BS import Data.Functor -import Lens.Micro.Platform -import Streaming.Prelude qualified as S -import Data.ByteString.Lazy qualified as LBS import Codec.Serialise +import Control.Monad.Reader -- NOTE: refchan-head-endpoints data RpcRefChanHeadGet @@ -38,100 +41,100 @@ data RpcRefChanPropose data RpcRefChanNotify -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefChanHeadGet where +type RefChanAPI = '[ RpcRefChanHeadGet + , RpcRefChanHeadFetch + , RpcRefChanHeadPost + , RpcRefChanGet + , RpcRefChanFetch + , RpcRefChanPropose + , RpcRefChanNotify + ] + + +type RefChanAPIProto = 0xDA2374630001 + +-- FIXME: hbs2-peer-protocols-to- +instance HasProtocol UNIX (ServiceProto RefChanAPI UNIX) where + type instance ProtocolId (ServiceProto RefChanAPI UNIX) = RefChanAPIProto + type instance Encoded UNIX = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise + +type RefChanContext m = (MonadIO m, HasRpcContext RefChanAPI RPC2Context m) + +instance (Monad m) + => HasRpcContext RefChanAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where + -- type instance RpcContext RefChanAPI = RPC2Context + getRpcContext = lift ask + +instance RefChanContext m => HandleMethod m RpcRefChanHeadGet where type instance Input RpcRefChanHeadGet = PubKey 'Sign HBS2Basic type instance Output RpcRefChanHeadGet = Maybe HashRef handleMethod puk = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @RefChanAPI let penv = rpcPeerEnv co debug $ "rpc2.refchanHeadGet:" <+> pretty (AsBase58 puk) liftIO $ withPeerM penv $ do sto <- getStorage liftIO $ getRef sto (RefChanHeadKey @HBS2Basic puk) <&> fmap HashRef -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefChanHeadFetch where +instance (RefChanContext m) => HandleMethod m RpcRefChanHeadFetch where type instance Input RpcRefChanHeadFetch = PubKey 'Sign HBS2Basic type instance Output RpcRefChanHeadFetch = () handleMethod puk = do debug $ "rpc2.refchanHeadFetch:" <+> pretty (AsBase58 puk) - penv <- rpcPeerEnv <$> getRpcContext @RPC2Context + penv <- rpcPeerEnv <$> getRpcContext @RefChanAPI void $ liftIO $ withPeerM penv $ do broadCastMessage (RefChanGetHead @L4Proto puk) -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefChanFetch where +instance RefChanContext m => HandleMethod m RpcRefChanFetch where type instance Input RpcRefChanFetch = PubKey 'Sign HBS2Basic type instance Output RpcRefChanFetch = () handleMethod puk = do debug $ "rpc2.refchanFetch:" <+> pretty (AsBase58 puk) - penv <- rpcPeerEnv <$> getRpcContext @RPC2Context + penv <- rpcPeerEnv <$> getRpcContext @RefChanAPI void $ liftIO $ withPeerM penv $ do gossip (RefChanRequest @L4Proto puk) -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefChanGet where +instance RefChanContext m => HandleMethod m RpcRefChanGet where type instance Input RpcRefChanGet = PubKey 'Sign HBS2Basic type instance Output RpcRefChanGet = Maybe HashRef handleMethod puk = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @RefChanAPI let penv = rpcPeerEnv co debug $ "rpc2.refchanGet:" <+> pretty (AsBase58 puk) liftIO $ withPeerM penv $ do sto <- getStorage liftIO $ getRef sto (RefChanLogKey @HBS2Basic puk) <&> fmap HashRef - -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefChanPropose where - type instance Input RpcRefChanPropose = (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) +instance RefChanContext m => HandleMethod m RpcRefChanPropose where + type instance Input RpcRefChanPropose = (PubKey 'Sign HBS2Basic, SignedBox BS.ByteString L4Proto) type instance Output RpcRefChanPropose = () handleMethod (puk, box) = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @RefChanAPI debug $ "rpc2.refChanNotifyAction" <+> pretty (AsBase58 puk) liftIO $ rpcDoRefChanPropose co (puk, box) -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefChanNotify where - type instance Input RpcRefChanNotify = (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) +instance RefChanContext m => HandleMethod m RpcRefChanNotify where + type instance Input RpcRefChanNotify = (PubKey 'Sign HBS2Basic, SignedBox BS.ByteString L4Proto) type instance Output RpcRefChanNotify = () handleMethod (puk, box) = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @RefChanAPI debug $ "rpc2.refChanNotifyAction" <+> pretty (AsBase58 puk) liftIO $ rpcDoRefChanNotify co (puk, box) -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefChanHeadPost where +instance RefChanContext m => HandleMethod m RpcRefChanHeadPost where type instance Input RpcRefChanHeadPost = HashRef type instance Output RpcRefChanHeadPost = () handleMethod href = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @RefChanAPI liftIO $ rpcDoRefChanHeadPost co href --- instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefLogFetch where --- type instance Input RpcRefLogFetch = PubKey 'Sign HBS2Basic --- type instance Output RpcRefLogFetch = () - --- handleMethod pk = do --- co <- getRpcContext @RPC2Context --- debug $ "rpc2.reflogFetch:" <+> pretty (AsBase58 pk) - --- liftIO $ withPeerM (rpcPeerEnv co) $ do --- broadCastMessage (RefLogRequest @L4Proto pk) - --- instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefLogPost where --- type instance Input RpcRefLogPost = RefLogUpdate L4Proto --- type instance Output RpcRefLogPost = () - --- handleMethod msg = do --- co <- getRpcContext @RPC2Context --- let pk = view refLogId msg --- debug $ "rpc2.reflogPost:" <+> pretty (AsBase58 pk) - --- liftIO $ withPeerM (rpcPeerEnv co) $ do --- emit @L4Proto RefLogUpdateEvKey (RefLogUpdateEvData (pk, msg)) --- doRefLogBroadCast msg - - diff --git a/hbs2-peer/app/RPC2/RefLog.hs b/hbs2-peer/app/RPC2/RefLog.hs index d29cb5a6..19536ed9 100644 --- a/hbs2-peer/app/RPC2/RefLog.hs +++ b/hbs2-peer/app/RPC2/RefLog.hs @@ -1,4 +1,9 @@ -module RPC2.RefLog where +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +module RPC2.RefLog + ( module RPC2.RefLog + , module HBS2.Peer.RPC.Internal.Types + ) where import HBS2.Prelude.Plated @@ -12,26 +17,50 @@ import HBS2.Net.Proto.RefLog import HBS2.Net.Proto.Service import HBS2.Net.Proto.Types import HBS2.Storage +import HBS2.Net.Messaging.Unix import HBS2.System.Logger.Simple import PeerTypes import RefLog (doRefLogBroadCast) -import RPC2.Types + +import HBS2.Peer.RPC.Internal.Types import Data.Functor import Lens.Micro.Platform +import Data.ByteString.Lazy ( ByteString ) +import Codec.Serialise +import Control.Monad.Reader data RpcRefLogGet data RpcRefLogFetch data RpcRefLogPost +type RefLogAPI = '[ RpcRefLogGet + , RpcRefLogFetch + , RpcRefLogPost + ] -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefLogGet where + +type RefLogContext m = (MonadIO m, HasRpcContext RefLogAPI RPC2Context m) + +instance HasProtocol UNIX (ServiceProto RefLogAPI UNIX) where + type instance ProtocolId (ServiceProto RefLogAPI UNIX) = 0xDA2371620001 + type instance Encoded UNIX = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise + + +instance (Monad m) + => HasRpcContext RefLogAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where + -- type instance RpcContext RefLogAPI = RPC2Context + getRpcContext = lift ask + +instance (RefLogContext m) => HandleMethod m RpcRefLogGet where type instance Input RpcRefLogGet = PubKey 'Sign HBS2Basic type instance Output RpcRefLogGet = Maybe HashRef handleMethod pk = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @RefLogAPI debug $ "rpc2.reflogGet:" <+> pretty (AsBase58 pk) <+> pretty (hashObject @HbSync (RefLogKey @HBS2Basic pk)) @@ -39,23 +68,23 @@ instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefLogGet let sto = rpcStorage co liftIO (getRef sto (RefLogKey @HBS2Basic pk)) <&> fmap HashRef -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefLogFetch where +instance (RefLogContext m) => HandleMethod m RpcRefLogFetch where type instance Input RpcRefLogFetch = PubKey 'Sign HBS2Basic type instance Output RpcRefLogFetch = () handleMethod pk = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @RefLogAPI debug $ "rpc2.reflogFetch:" <+> pretty (AsBase58 pk) liftIO $ withPeerM (rpcPeerEnv co) $ do broadCastMessage (RefLogRequest @L4Proto pk) -instance (MonadIO m, HasRpcContext RPC2Context m) => HandleMethod m RpcRefLogPost where +instance (RefLogContext m) => HandleMethod m RpcRefLogPost where type instance Input RpcRefLogPost = RefLogUpdate L4Proto type instance Output RpcRefLogPost = () handleMethod msg = do - co <- getRpcContext @RPC2Context + co <- getRpcContext @RefLogAPI let pk = view refLogId msg debug $ "rpc2.reflogPost:" <+> pretty (AsBase58 pk) diff --git a/hbs2-peer/app/RPC2/Service/Storage/Unix.hs b/hbs2-peer/app/RPC2/Service/Storage/Unix.hs deleted file mode 100644 index 8393bebf..00000000 --- a/hbs2-peer/app/RPC2/Service/Storage/Unix.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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/Service/Unix.hs b/hbs2-peer/app/RPC2/Service/Unix.hs deleted file mode 100644 index 4a2b5c05..00000000 --- a/hbs2-peer/app/RPC2/Service/Unix.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module RPC2.Service.Unix - ( module RPC2.Service.Unix - , module HBS2.Net.Proto.Service - ) 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.System.Logger.Simple - -import RPC2.API - -import Data.Config.Suckless.Syntax -import Data.Config.Suckless.KeyValue - -import Data.Text qualified as Text -import Control.Monad.Reader -import UnliftIO -import Data.ByteString.Lazy (ByteString) -import Codec.Serialise - -instance HasProtocol UNIX (ServiceProto RPC2 UNIX) where - type instance ProtocolId (ServiceProto RPC2 UNIX) = 0xDA2374610000 - type instance Encoded UNIX = ByteString - decode = either (const Nothing) Just . deserialiseOrFail - encode = serialise - -instance Monad m => HasRpcContext RPC2Context (ReaderT RPC2Context m) where - getRpcContext = ask - --- FIXME: fix-this-ugly-shit -instance (Monad m, HasRpcContext RPC2Context m) => HasRpcContext RPC2Context (ResponseM UNIX (ReaderT MessagingUnix m)) where - getRpcContext = lift $ lift getRpcContext - -instance MonadUnliftIO m => (HasDeferred UNIX (ServiceProto RPC2 UNIX) (ReaderT RPC2Context m)) where - deferred _ m = void $ async m - -instance (MonadUnliftIO m) => - HasDeferred UNIX (ServiceProto RPC2 UNIX) (ResponseM UNIX m) where - deferred _ m = do - -- FIXME: this-might-be-ok-for-rpc - -- никаких конвейров и прочих модных - -- штук, которые реализованы в PeerM - -- можно прикрутить какой-то глоальный - -- пул процессов? - -- О! Конвейр, буде он понадобится, - -- можно запихнуть прямо в MessagingUnix - void $ async m - -instance Monad m => HasConf (ReaderT RPC2Context m) where - getConf = asks rpcConfig - -sodef :: FilePath -sodef = "/tmp/hbs2-rpc2.socket" - -getSocketName :: HasConf m => m FilePath -getSocketName = do - syn <- getConf - - let soname = lastDef sodef [ Text.unpack n - | ListVal @C (Key "rpc2" [SymbolVal "unix", LitStrVal n]) <- syn - ] - pure soname - -runService :: ( HasConf m - , MonadUnliftIO m - , HasRpcContext RPC2Context m - , HasDeferred UNIX (ServiceProto RPC2 UNIX) m - ) => m () -runService = do - - soname <- getSocketName - - notice $ "RPC2 Service started" <+> pretty soname - - server <- newMessagingUnixOpts [MUFork] True 1.0 soname - m1 <- async $ runMessagingUnix server - link m1 - - flip runReaderT server do - runProto @UNIX - [ makeResponse (makeServer @RPC2) - ] - - diff --git a/hbs2-peer/app/RPC2/Storage.hs b/hbs2-peer/app/RPC2/Storage.hs deleted file mode 100644 index d6a241e8..00000000 --- a/hbs2-peer/app/RPC2/Storage.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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 3fa8f4f5..cceb6461 100644 --- a/hbs2-peer/app/RPC2/Types.hs +++ b/hbs2-peer/app/RPC2/Types.hs @@ -1,31 +1,8 @@ +{-# Language UndecidableInstances #-} module RPC2.Types - ( module RPC2.Types - , module HBS2.Peer.RPC.Class + ( module HBS2.Peer.RPC.Internal.Types ) 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(..)) -import PeerConfig - -import Data.ByteString ( ByteString ) - -data RPC2Context = - RPC2Context - { rpcConfig :: [Syntax C] - , rpcPokeAnswer :: String - , rpcPeerEnv :: PeerEnv L4Proto - , rpcDownloadEnv :: DownloadEnv L4Proto - , rpcLocalMultiCast :: Peer L4Proto - , rpcStorage :: AnyStorage - , rpcDoRefChanHeadPost :: HashRef -> IO () - , rpcDoRefChanPropose :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO () - , rpcDoRefChanNotify :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO () - } - +-- FIXME: ASAP-to-remove-file +import HBS2.Peer.RPC.Internal.Types diff --git a/hbs2-peer/app/RPC2/Unix.hs b/hbs2-peer/app/RPC2/Unix.hs deleted file mode 100644 index 9aef4e37..00000000 --- a/hbs2-peer/app/RPC2/Unix.hs +++ /dev/null @@ -1,48 +0,0 @@ -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 3db8ee29..58832efe 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -137,7 +137,9 @@ library HBS2.Peer.RPC.API.Storage HBS2.Peer.RPC.Client.Unix HBS2.Peer.RPC.Internal.Storage - HBS2.Peer.RPC.Internal.Service.Storage.Unix + HBS2.Peer.RPC.Internal.Types + + other-modules: executable hbs2-peer import: shared-properties @@ -162,11 +164,8 @@ executable hbs2-peer , Fetch , Log , RPC2 - , RPC2.Client.Unix - , RPC2.Service.Unix - , RPC2.Service.Storage.Unix - , RPC2.API - , RPC2.Types + , RPC2.Peer.API + , RPC2.Peer , RPC2.Poke , RPC2.Announce , RPC2.Fetch @@ -177,7 +176,6 @@ executable hbs2-peer , RPC2.Ping , RPC2.RefLog , RPC2.RefChan - , RPC2.Storage , PeerTypes , PeerConfig , RefLog diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs index 0da4c5da..bc00d3d2 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/Storage.hs @@ -1,5 +1,15 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module HBS2.Peer.RPC.API.Storage where +import HBS2.Actors.Peer +import HBS2.Net.Proto.Service +import HBS2.Net.Messaging.Unix +import HBS2.Peer.RPC.Internal.Types + +import Control.Monad.Reader +import Data.ByteString.Lazy (ByteString) +import Codec.Serialise + data RpcStorageHasBlock data RpcStorageGetBlock data RpcStorageEnqueueBlock @@ -19,3 +29,17 @@ type StorageAPI = '[ RpcStorageHasBlock , RpcStorageDelRef ] +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 + + +instance (Monad m) + => HasRpcContext StorageAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where + getRpcContext = lift ask + +instance Monad m => HasStorage (ReaderT RPC2Context m) where + getStorage = asks rpcStorage + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Class.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Class.hs index d7ab268c..a8eb52bb 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Class.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Class.hs @@ -1,6 +1,10 @@ +{-# Language AllowAmbiguousTypes #-} module HBS2.Peer.RPC.Class where -class HasRpcContext a m where - getRpcContext :: m a +import Data.Kind + +class HasRpcContext (api :: [Type]) ctx m where + -- type family RpcContext api :: Type + getRpcContext :: m ctx -- (RpcContext api) diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs index 78fc08d5..43c4c5b0 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs @@ -4,10 +4,9 @@ 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.Peer.RPC.API.Storage() import HBS2.System.Logger.Simple 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 deleted file mode 100644 index 0b93d46e..00000000 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Service/Storage/Unix.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# 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 index 227c0193..5b6d9b88 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Storage.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} module HBS2.Peer.RPC.Internal.Storage ( module HBS2.Peer.RPC.API.Storage , module HBS2.Peer.RPC.Class @@ -6,8 +7,8 @@ module HBS2.Peer.RPC.Internal.Storage where -import HBS2.Actors.Peer.Types import HBS2.Prelude.Plated +import HBS2.Actors.Peer.Types import HBS2.Data.Types.Refs (HashRef(..),RefAlias(..)) import HBS2.Storage import HBS2.Peer.RPC.Class @@ -15,76 +16,76 @@ import HBS2.Peer.RPC.API.Storage import HBS2.Net.Proto.Service +import HBS2.Peer.RPC.Internal.Types + import Data.Functor import Data.ByteString.Lazy ( ByteString ) -import Control.Monad.Reader +-- type StorageContext m = (MonadIO m, HasStorage m) +type StorageContext m = (MonadIO m, HasStorage m) -instance Monad m => HasRpcContext AnyStorage (ReaderT AnyStorage m) where - getRpcContext = ask - -instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageHasBlock where +instance (StorageContext m) => HandleMethod m RpcStorageHasBlock where type instance Input RpcStorageHasBlock = HashRef type instance Output RpcStorageHasBlock = Maybe Integer handleMethod href = do - sto <- getRpcContext @AnyStorage + sto <- getStorage liftIO $ hasBlock sto (fromHashRef href) -instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageGetBlock where +instance (StorageContext m) => HandleMethod m RpcStorageGetBlock where type instance Input RpcStorageGetBlock = HashRef type instance Output RpcStorageGetBlock = Maybe ByteString handleMethod href = do - sto <- getRpcContext @AnyStorage + sto <- getStorage liftIO $ getBlock sto (fromHashRef href) -instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageEnqueueBlock where +instance (StorageContext m) => HandleMethod m RpcStorageEnqueueBlock where type instance Input RpcStorageEnqueueBlock = ByteString type instance Output RpcStorageEnqueueBlock = Maybe HashRef handleMethod lbs = do - sto <- getRpcContext @AnyStorage + sto <- getStorage liftIO $ enqueueBlock sto lbs <&> fmap HashRef -instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStoragePutBlock where +instance (StorageContext m) => HandleMethod m RpcStoragePutBlock where type instance Input RpcStoragePutBlock = ByteString type instance Output RpcStoragePutBlock = Maybe HashRef handleMethod lbs = do - sto <- getRpcContext @AnyStorage + sto <- getStorage liftIO $ putBlock sto lbs <&> fmap HashRef -instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageGetChunk where +instance (StorageContext 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 + sto <- getStorage liftIO $ getChunk sto (fromHashRef h) o s -instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageGetRef where +instance (StorageContext m) => HandleMethod m RpcStorageGetRef where type instance Input RpcStorageGetRef = RefAlias type instance Output RpcStorageGetRef = Maybe HashRef handleMethod ref = do - sto <- getRpcContext @AnyStorage + sto <- getStorage liftIO $ getRef sto ref <&> fmap HashRef -instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageUpdateRef where +instance (StorageContext m) => HandleMethod m RpcStorageUpdateRef where type instance Input RpcStorageUpdateRef = (RefAlias, HashRef) type instance Output RpcStorageUpdateRef = () handleMethod (ref, val) = do - sto <- getRpcContext @AnyStorage + sto <- getStorage liftIO $ updateRef sto ref (fromHashRef val) -instance (MonadIO m, HasRpcContext AnyStorage m) => HandleMethod m RpcStorageDelRef where +instance (StorageContext m) => HandleMethod m RpcStorageDelRef where type instance Input RpcStorageDelRef = RefAlias type instance Output RpcStorageDelRef = () handleMethod ref = do - sto <- getRpcContext @AnyStorage + sto <- getStorage liftIO $ delRef sto ref diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs new file mode 100644 index 00000000..2cb8321e --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs @@ -0,0 +1,47 @@ +{-# Language UndecidableInstances #-} +module HBS2.Peer.RPC.Internal.Types + ( module HBS2.Peer.RPC.Internal.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.Net.Messaging.Unix +import HBS2.Net.Proto.Service +import HBS2.Peer.RPC.Class + +import Data.Config.Suckless.Syntax +import Data.Config.Suckless.Parse + +import Data.Kind +import Control.Monad.Reader +import Data.ByteString ( ByteString ) +import UnliftIO + +data RPC2Context = + RPC2Context + { rpcConfig :: [Syntax MegaParsec] + , rpcMessaging :: MessagingUnix + , rpcPokeAnswer :: String + , rpcPeerEnv :: PeerEnv L4Proto + , rpcLocalMultiCast :: Peer L4Proto + , rpcStorage :: AnyStorage + , rpcDoFetch :: HashRef -> IO () + , rpcDoRefChanHeadPost :: HashRef -> IO () + , rpcDoRefChanPropose :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO () + , rpcDoRefChanNotify :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO () + } + +instance (Monad m, Messaging MessagingUnix UNIX (Encoded UNIX)) => HasFabriq UNIX (ReaderT RPC2Context m) where + getFabriq = asks (Fabriq . rpcMessaging) + +instance Monad m => HasOwnPeer UNIX (ReaderT RPC2Context m) where + ownPeer = asks ( msgUnixSelf . rpcMessaging ) + +instance (MonadUnliftIO m, HasProtocol UNIX (ServiceProto (api :: [Type]) UNIX)) + => HasDeferred UNIX (ServiceProto api UNIX) m where + deferred _ m = void $ async m + + diff --git a/hbs2-tests/test/StorageServiceTest.hs b/hbs2-tests/test/StorageServiceTest.hs index af5d7c35..b6fcbab6 100644 --- a/hbs2-tests/test/StorageServiceTest.hs +++ b/hbs2-tests/test/StorageServiceTest.hs @@ -1,33 +1,45 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} 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.Storage.Simple (simpleStorageWorker,simpleStorageInit) import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.Class 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 Data.Kind import System.FilePath import UnliftIO import Prettyprinter -import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy qualified as LBS import Data.Maybe +import Codec.Serialise import Test.Tasty.HUnit +instance HasFabriq UNIX (ReaderT (AnyStorage, MessagingUnix) IO) where + getFabriq = asks (Fabriq . snd) + +instance HasOwnPeer UNIX (ReaderT (AnyStorage, MessagingUnix) IO) where + ownPeer = asks ( msgUnixSelf . snd) + +instance Monad m => HasStorage (ReaderT (AnyStorage, MessagingUnix) m) where + getStorage = asks fst + + main :: IO () main = do @@ -52,7 +64,7 @@ main = do debug $ "written" <+> pretty h1 - let rk1 = SomeRefKey ("SOMEREFKEY1" :: ByteString) + let rk1 = SomeRefKey ("SOMEREFKEY1" :: LBS.ByteString) updateRef sto rk1 h1