From ef0334b4a2d2bc260f3ff46a027844381d8bca56 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 2 Apr 2024 09:48:19 +0300 Subject: [PATCH] wip --- hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs | 1 + .../lib/HBS2/Git/Oracle/Run.hs | 20 +++--- hbs2-peer/app/Browser/Root.hs | 18 ++++-- hbs2-peer/app/HttpWorker.hs | 61 ++++++++++++++++--- .../lib/HBS2/Peer/Proto/BrowserPlugin.hs | 10 ++- 5 files changed, 88 insertions(+), 22 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs b/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs index 78c579b1..036adb6b 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs @@ -90,6 +90,7 @@ runMessagingPipe bus = liftIO do done <- hIsEOF who unless done do r <- try @_ @SomeException do + debug $ "GET SHIT!" frame <- LBS.hGet who 4 <&> word32 . LBS.toStrict piece <- LBS.hGet who (fromIntegral frame) atomically (writeTQueue (inQ bus) piece) diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs index 01e95add..68cbf491 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs @@ -30,6 +30,7 @@ import Data.ByteString.Lazy (ByteString) import Data.Maybe import Lens.Micro.Platform hiding ( (.=) ) +import Control.Applicative import Data.Aeson as Aeson import Data.Aeson.Encode.Pretty qualified as A import Streaming.Prelude qualified as S @@ -159,11 +160,15 @@ runDump pks = do env <- liftIO getEnvironment <&> fmap (over _1 Text.pack . over _2 Text.pack) + path <- liftIO (lookupEnv "PATH_INFO") + <&> fromMaybe "/" + <&> Text.pack + let cmd = proc self ["pipe", "-r", show (pretty (AsBase58 pks))] & setStdin createPipe & setStdout createPipe - flip runContT pure do + flip runContT (const $ liftIO exitSuccess) do p <- ContT $ withProcessWait cmd @@ -177,10 +182,10 @@ runDump pks = do void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClient caller) client - wtf <- callService @RpcChannelQuery caller env + wtf <- callService @RpcChannelQuery caller (Get (Just path) env) >>= orThrowUser "can't query rpc" - r <- ContT $ maybe1 wtf (pure ()) + r <- ContT $ maybe1 wtf (liftIO (hClose ssin >> exitFailure)) hClose ssin @@ -193,18 +198,19 @@ class HasOracleEnv m where -- API handler instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery where - handleMethod args' = do + handleMethod (Get path args') = do env <- getOracleEnv debug $ green "PLUGIN: HANDLE METHOD!" let args = HM.fromList args' - case HM.lookup "METHOD" args of + case HM.lookup "METHOD" args <|> path of Just "debug" -> listEnv args Just "list-entries" -> listEntries args - Nothing -> listEntries args - _ -> pure mempty + Just "/" -> listEntries args + Just "" -> listEntries args + _ -> pure Nothing where listEnv args = do diff --git a/hbs2-peer/app/Browser/Root.hs b/hbs2-peer/app/Browser/Root.hs index 996873e1..d1d79aba 100644 --- a/hbs2-peer/app/Browser/Root.hs +++ b/hbs2-peer/app/Browser/Root.hs @@ -1,7 +1,7 @@ module Browser.Root ( module Lucid , browserRootPage - , channelPage + , pluginPage ) where import HBS2.Prelude.Plated @@ -10,6 +10,8 @@ import HBS2.Net.Proto.Types import HBS2.Peer.Proto.RefChan import HBS2.Peer.Proto.BrowserPlugin import HBS2.Net.Messaging.Pipe +import HBS2.System.Logger.Simple.ANSI +import HBS2.Misc.PrettyStuff import Data.Config.Suckless.Syntax @@ -299,6 +301,8 @@ rootPage content = do -- +{- HLINT ignore "Functor law" -} + browserRootPage :: Monad m => [Syntax c] -> HtmlT m () browserRootPage syn = rootPage do @@ -345,19 +349,23 @@ browserRootPage syn = rootPage do p_ (toHtml s) -channelPage :: MonadIO m +pluginPage :: MonadIO m => ServiceCaller BrowserPluginAPI PIPE -> [(Text,Text)] -> HtmlT m () -channelPage api env' = do +pluginPage api env' = do let env = HM.toList $ HM.fromList env' <> HM.fromList [("METHOD","list-entries"),("OUTPUT","html")] - r <- liftIO (callRpcWaitMay @RpcChannelQuery (TimeoutSec 1) api env) + let plGet = Get Nothing [("OUTPUT", "html")] + + r <- liftIO (callRpcWaitMay @RpcChannelQuery (TimeoutSec 1) api plGet) <&> join <&> fromMaybe mempty let str = LBS.unpack r + let stripped = extractBodyHtml str + rootPage $ do div_ [class_ "container main"] $ do @@ -366,7 +374,7 @@ channelPage api env' = do div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить" main_ do - toHtmlRaw (extractBodyHtml str) + toHtmlRaw stripped where extractBodyHtml :: String -> String diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 0688a580..90f15344 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -12,11 +12,11 @@ import HBS2.Data.Detect import HBS2.Data.Types.Refs import HBS2.Merkle import HBS2.Net.Messaging.Pipe -import HBS2.Peer.Proto -import HBS2.Peer.Proto.BrowserPlugin +import HBS2.Peer.Proto hiding (Request) +import HBS2.Peer.Proto.BrowserPlugin hiding (Request) import HBS2.Peer.Proto.LWWRef import HBS2.Peer.Browser.Assets -import HBS2.Net.Auth.Schema +import HBS2.Net.Auth.Schema (HBS2Basic) import HBS2.Data.Types.SignedBox import HBS2.Events import HBS2.Storage.Operations.ByteString @@ -34,14 +34,13 @@ import Data.ByteString.Lazy qualified as LBS import Network.HTTP.Types.Status import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.StaticEmbedded -import Web.Scotty +import Network.Wai +import Web.Scotty as Scotty import Data.ByteString.Builder (byteString, Builder) import Codec.Serialise (deserialiseOrFail) -import Control.Concurrent import Control.Monad.Except -import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.Trans.Cont import Control.Monad.Trans.Maybe @@ -54,11 +53,13 @@ import Data.HashMap.Strict (HashMap) import Data.Maybe import Data.List qualified as List import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text import Lens.Micro.Platform (view) import Streaming.Prelude qualified as S import System.FilePath import Text.InterpolatedString.Perl6 (qc) import System.Process.Typed +import System.Environment import UnliftIO hiding (orElse) @@ -295,8 +296,13 @@ httpWorker (PeerConfig syn) pmeta e = do plugin <- readTVarIO handles <&> HM.lookup chan >>= orElse (status status404) - let env = mempty - lift $ renderTextT (channelPage plugin env) >>= html + envv <- liftIO getEnvironment + + debug $ red "ENV" <+> pretty envv + + env <- lift makeHttpEnv + + lift $ renderTextT (pluginPage plugin env) >>= html put "/" do @@ -319,6 +325,45 @@ httpWorker (PeerConfig syn) pmeta e = do forever $ pause @'Seconds 600 + +class ToPluginArg a where + pluginArgs :: Text -> a -> [(Text,Text)] + +instance ToPluginArg Text where + pluginArgs n s = [(n,s)] + + +makeHttpEnv :: ActionM [(Text,Text)] +makeHttpEnv = do + req <- Scotty.request + pure mempty + + -- pure $ pluginArgs "REQUEST_METHOD" (requestMethod req) + -- <> + -- pluginArgs "PATH_INFO" (pathInfo req) + + where + part s bs = [ (s, Text.decodeUtf8 bs) ] + + +-- { requestMethod = rmethod +-- , rawPathInfo = B.pack pinfo +-- , pathInfo = H.decodePathSegments $ B.pack pinfo +-- , rawQueryString = B.pack qstring +-- , queryString = H.parseQuery $ B.pack qstring +-- , requestHeaders = reqHeaders +-- , isSecure = isSecure' +-- , remoteHost = addr +-- , httpVersion = H.http11 -- FIXME +-- , vault = mempty +-- , requestBodyLength = KnownLength $ fromIntegral contentLength +-- , requestHeaderHost = lookup "host" reqHeaders +-- , requestHeaderRange = lookup hRange reqHeaders +-- #if MIN_VERSION_wai(3,2,0) +-- , requestHeaderReferer = lookup "referer" reqHeaders +-- , requestHeaderUserAgent = lookup "user-agent" reqHeaders + + getTreeHash :: AnyStorage -> HashRef -> ActionM () getTreeHash sto what' = void $ flip runContT pure do blob <- liftIO (getBlock sto what) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs b/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs index 11a58ebd..0757104c 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs @@ -4,10 +4,10 @@ module HBS2.Peer.Proto.BrowserPlugin , PIPE ) where +import HBS2.Prelude.Plated import HBS2.Net.Messaging.Pipe import HBS2.Net.Proto.Service -import Data.Text (Text) import Data.ByteString.Lazy (ByteString) import Codec.Serialise @@ -16,8 +16,14 @@ data RpcChannelQuery -- API definition type BrowserPluginAPI = '[ RpcChannelQuery ] +data PluginMethod = + Get (Maybe Text) [(Text,Text)] + deriving stock Generic + +instance Serialise PluginMethod + -- API endpoint definition -type instance Input RpcChannelQuery = [(Text,Text)] +type instance Input RpcChannelQuery = PluginMethod type instance Output RpcChannelQuery = Maybe ByteString