merged PR 41MJ5i2NdR hbs2-peer-raw-tx-api

Squashed commit of the following:

commit d3fcc52a294adef00de6fa9a0581e37c95bc96ef
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Fri Jul 7 18:47:10 2023 +0300

    API handler for posting raw txs

commit 1fce9bceeefbabdc665e60a823a98d91151dbda6
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Tue Jul 4 18:14:53 2023 +0300

    fixme

.fixme/log

@@ -0,0 +1,3 @@
+
+(fixme-set "assigned" "voidlizard" "41MJ5i2NdR")
+(fixme-set "workflow" "test" "41MJ5i2NdR")

.gitignore

@@ -3,3 +3,5 @@ dist-newstyle
 hbs2.prof
 .fixme/state.db
 result
+# VS Code
+settings.json

hbs2-peer/app/HttpWorker.hs

@@ -2,27 +2,27 @@ 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.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
 
@@ -31,12 +31,15 @@ httpWorker :: forall e s m . ( MyPeer e
                              , HasStorage m
                              , IsRefPubKey s
                              , s ~ Encryption e
+                             , m ~ PeerM e IO
+                             , e ~ L4Proto
                              ) => PeerConfig -> DownloadEnv e -> m ()
 
 httpWorker conf e = do
 
   sto <- getStorage
   let port' = cfgValue @PeerHttpPortKey conf  <&>  fromIntegral
+  penv <- ask
 
   maybe1 port' none $ \port -> liftIO do
 
@@ -70,6 +73,22 @@ httpWorker conf e = do
             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 $ mkPeerMeta conf
 

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

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

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