diff --git a/.gitignore b/.gitignore index dae64e30..b2a40f47 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ dist-newstyle hbs2.prof .fixme/state.db result +# VS Code +settings.json \ No newline at end of file diff --git a/docs/todo/qblf.txt b/docs/todo/qblf.txt new file mode 100644 index 00000000..0cd74633 --- /dev/null +++ b/docs/todo/qblf.txt @@ -0,0 +1,30 @@ +TODO: qblf-ephemeral-transactions + для реализации QBLF (aka Quorum Based Log Folding) + и вообще любого "онлайн" консенсуса нам нужны + "эфемерные" транзакции, то есть такие, которые + доставляются участникам, но не пишутся в рефлог. + + Свойства. Это просто подписанный BLOB безопасного + для UDP размера, парсинг его остаётся на совести + получателя. + + То есть если там приедет ссылка на merkle дерево, + оно не будет доступно сразу же, придется ему + сначала сделать FETCH. + + Эти транзакции должны доставляться подписчикам, + т.е hbs2-peer обязуется уведомить о них, + следовательно, сразу же нужна ручка для уведомления. + + +TODO: qblf-transaction-hook + Нотификации о приходе транзакций. Для начала HTTP. + + В настройке должен указываться рефлог, и ручка для обратного + вызова. + + В уведомлении должно быть тело транзации в бинарном виде, + рефлог, ключ и адрес пира. + + + diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index f6006b00..704de207 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -2,28 +2,28 @@ module HttpWorker where import HBS2.Prelude import HBS2.Actors.Peer -import HBS2.Net.Proto.PeerMeta import HBS2.Storage import HBS2.Data.Types.Refs import HBS2.Merkle (AnnMetaData) import HBS2.Net.Proto.Types - -import HBS2.System.Logger.Simple +import HBS2.Net.Proto.RefLog +import HBS2.Events import PeerTypes import PeerConfig +import RefLog ( doRefLogBroadCast ) import Data.Functor -import Data.Maybe -import Data.Text qualified as Text -import Data.Text.Encoding qualified as TE import Data.ByteString.Lazy qualified as LBS import Network.HTTP.Types.Status import Network.Wai.Middleware.RequestLogger import Text.InterpolatedString.Perl6 (qc) import Web.Scotty - - +import Codec.Serialise (deserialiseOrFail) +import Data.Function ((&)) +import Data.Aeson (object, (.=)) +import Control.Monad.Reader +import Lens.Micro.Platform (view) -- TODO: introduce-http-of-off-feature @@ -32,13 +32,15 @@ httpWorker :: forall e s m . ( MyPeer e , HasStorage m , IsRefPubKey s , s ~ Encryption e - ) - => PeerConfig -> AnnMetaData -> DownloadEnv e -> m () + , m ~ PeerM e IO + , e ~ L4Proto + ) => PeerConfig -> AnnMetaData -> DownloadEnv e -> m () httpWorker conf pmeta e = do sto <- getStorage let port' = cfgValue @PeerHttpPortKey conf <&> fromIntegral + penv <- ask maybe1 port' none $ \port -> liftIO do @@ -71,6 +73,22 @@ httpWorker conf pmeta e = do va <- liftIO $ getRef sto (RefLogKey @s ref) maybe1 va (status status404) $ \val -> do text [qc|{pretty val}|] + + post "/reflog" do + bs <- LBS.take 4194304 <$> body + let msg' = + deserialiseOrFail @(RefLogUpdate L4Proto) bs + & either (const Nothing) Just + case msg' of + Nothing -> do + status status400 + json $ object ["error" .= "unable to parse RefLogUpdate message"] + Just msg -> do + let pubk = view refLogId msg + liftIO $ withPeerM penv $ do + emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, msg)) + doRefLogBroadCast msg + status status200 get "/metadata" do raw $ serialise $ pmeta diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 0710bdef..73ad9b14 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -19,6 +19,7 @@ common warnings common common-deps build-depends: base, hbs2-core, hbs2-storage-simple + , aeson , async , bytestring , cache diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index ffb49a7c..6f10f04a 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/hbs2-tests/hbs2-tests.cabal @@ -595,3 +595,55 @@ executable topsort-commits -- , vector -- , fast-logger + +executable create-raw-tx + import: shared-properties + import: common-deps + default-language: Haskell2010 + + ghc-options: + -- -prof + -- -fprof-auto + + other-modules: + + -- other-extensions: + + -- type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: TestRawTx.hs + + build-depends: + base, hbs2-core + -- , async + -- , attoparsec + , bytestring + -- , cache + -- , clock + -- , containers + -- , interpolatedstring-perl6 + -- , data-default + -- , data-textual + -- , directory + -- , hashable + , http-conduit + , http-types + , optparse-applicative + -- , microlens-platform + -- , mtl + -- , mwc-random + -- , network + -- , network-ip + , prettyprinter + -- , random + -- , safe + , serialise + -- , stm + -- , streaming + -- , saltine + , text + -- , typed-process + -- , transformers + -- , uniplate + -- , vector + -- , fast-logger \ No newline at end of file diff --git a/hbs2-tests/test/TestRawTx.hs b/hbs2-tests/test/TestRawTx.hs new file mode 100644 index 00000000..68cb0263 --- /dev/null +++ b/hbs2-tests/test/TestRawTx.hs @@ -0,0 +1,72 @@ +module Main where + +import Codec.Serialise (serialise) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy.Char8 qualified as LBS +import HBS2.Base58 (fromBase58) +import HBS2.Net.Auth.Credentials +import HBS2.Net.Proto hiding (request) +import HBS2.Net.Proto.Definition () +import HBS2.Net.Proto.RefLog (makeRefLogUpdate) +import HBS2.OrDie +import HBS2.Prelude +import Lens.Micro.Platform +import Network.HTTP.Simple +import Network.HTTP.Types +import Options.Applicative + +data Options = Options + { credentialsFile :: FilePath, + tx :: String + } + +parseOptions :: Parser Options +parseOptions = + Options + <$> strOption + ( long "keyring" + <> short 'k' + <> help "reflog keyring" + <> metavar "FILE" + ) + <*> strOption + ( long "transaction" + <> help "transaction in Base58 format" + <> short 't' + <> metavar "TRANSACTION" + ) + +main :: IO () +main = do + options <- + execParser $ + info + (parseOptions <**> helper) + ( fullDesc + <> progDesc + "Program that takes keyfile and some base58 encoded message, \ + \creates signed transaction and posts it to the reflog." + <> header "Raw tx test" + ) + krData <- BS.readFile $ credentialsFile options + creds <- pure (parseCredentials (AsCredFile krData)) `orDie` "bad keyring file" + let pubk = view peerSignPk creds + let privk = view peerSignSk creds + bs <- pure (fromBase58 $ BS8.pack $ tx options) `orDie` "transaction is not in Base58 format" + msg <- makeRefLogUpdate @L4Proto pubk privk bs <&> serialise + + req <- parseRequest "http://localhost:5001/reflog" + + let request = + setRequestMethod "POST" $ + setRequestHeader "Content-Type" ["application/octet-stream"] $ + setRequestBodyLBS msg req + + resp <- httpLBS request + + case statusCode (getResponseStatus resp) of + 200 -> do + let r = LBS.unpack $ getResponseBody resp + print r + s -> print $ "error: status " <> show s