modular-rpc-api

1. Making the API modular
2. Running all via single socket, including storage

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

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]

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
 
 

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
 

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

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
 

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

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

hbs2-peer/app/RPC2/API.hs

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

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)
 

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 = ()

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
 
 
 

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

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

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
+

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
 
 
-

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
 
 

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

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
 

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

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)
 

hbs2-peer/app/RPC2/Service/Storage/Unix.hs

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

hbs2-peer/app/RPC2/Service/Unix.hs

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

hbs2-peer/app/RPC2/Storage.hs

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

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
 

hbs2-peer/app/RPC2/Unix.hs

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

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

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
+

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)
 
 

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
 

hbs2-peer/lib/HBS2/Peer/RPC/Internal/Service/Storage/Unix.hs

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

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
 
 

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

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