From 21dc952eb27cfbe45945f650ae9ec63f98143ba4 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 2 Apr 2024 11:43:39 +0300 Subject: [PATCH] wip --- hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs | 1 - .../lib/HBS2/Git/Oracle/Html.hs | 7 ++- .../lib/HBS2/Git/Oracle/Run.hs | 15 +++-- hbs2-peer/app/Browser/Root.hs | 13 ++-- hbs2-peer/app/HttpWorker.hs | 62 +++++-------------- hbs2-peer/hbs2-peer.cabal | 2 + hbs2-peer/lib/HBS2/Peer/HTTP/Root.hs | 9 +++ .../lib/HBS2/Peer/Proto/BrowserPlugin.hs | 8 ++- 8 files changed, 55 insertions(+), 62 deletions(-) create mode 100644 hbs2-peer/lib/HBS2/Peer/HTTP/Root.hs diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs b/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs index 036adb6b..78c579b1 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs @@ -90,7 +90,6 @@ 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/Html.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs index db7b3866..e0693933 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs @@ -3,6 +3,8 @@ module HBS2.Git.Oracle.Html where import HBS2.Git.Oracle.Prelude import HBS2.Git.Oracle.State +import HBS2.Peer.HTTP.Root + import Data.HashMap.Strict (HashMap) import Lucid hiding (for_) @@ -64,13 +66,14 @@ renderEntries args items = pure $ renderBS do let s = if Text.length n > 2 then n else "unnamed" let refpart = Text.take 8 $ Text.pack $ show $ pretty h - let ref = Text.pack $ show $ pretty h + let sref = show $ pretty h + let ref = Text.pack sref div_ [class_ "repo-list-item"] do div_ [class_ "repo-info"] do h2_ [class_ "xclip", onClickCopy ref] $ toHtml (s <> "-" <> refpart) - p_ $ a_ [href_ ""] (toHtml (show $ pretty h)) + p_ $ a_ [href_ (path ["repo", sref])] (toHtml ref) renderMarkdown b 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 68cbf491..d444acf1 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 @@ -21,6 +21,7 @@ import HBS2.KeyMan.Keys.Direct import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.Tx +import HBS2.Peer.HTTP.Root import HBS2.Peer.Proto.BrowserPlugin import DBPipe.SQLite @@ -47,6 +48,7 @@ import Text.InterpolatedString.Perl6 (qc) import System.Environment (getProgName, getArgs) import System.Environment import System.Posix.Signals +import System.FilePath import Data.Word import System.Exit @@ -161,8 +163,9 @@ runDump pks = do <&> fmap (over _1 Text.pack . over _2 Text.pack) path <- liftIO (lookupEnv "PATH_INFO") - <&> fromMaybe "/" - <&> Text.pack + <&> fmap splitDirectories + <&> fromMaybe mempty + <&> fmap Text.pack let cmd = proc self ["pipe", "-r", show (pretty (AsBase58 pks))] & setStdin createPipe @@ -182,7 +185,7 @@ runDump pks = do void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClient caller) client - wtf <- callService @RpcChannelQuery caller (Get (Just path) env) + wtf <- callService @RpcChannelQuery caller (Get path env) >>= orThrowUser "can't query rpc" r <- ContT $ maybe1 wtf (liftIO (hClose ssin >> exitFailure)) @@ -205,11 +208,13 @@ instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery whe let args = HM.fromList args' - case HM.lookup "METHOD" args <|> path of + let cmd = HM.lookup "METHOD" args <|> headMay path + + case cmd of Just "debug" -> listEnv args Just "list-entries" -> listEntries args Just "/" -> listEntries args - Just "" -> listEntries args + Nothing -> listEntries args _ -> pure Nothing where diff --git a/hbs2-peer/app/Browser/Root.hs b/hbs2-peer/app/Browser/Root.hs index d1d79aba..af14b912 100644 --- a/hbs2-peer/app/Browser/Root.hs +++ b/hbs2-peer/app/Browser/Root.hs @@ -9,9 +9,6 @@ import HBS2.Base58 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 @@ -25,6 +22,7 @@ import Data.ByteString.Lazy.Char8 qualified as LBS import System.FilePath import Control.Monad import Control.Monad.Trans.Maybe +import Lens.Micro.Platform import Text.HTML.TagSoup @@ -351,14 +349,13 @@ browserRootPage syn = rootPage do pluginPage :: MonadIO m => ServiceCaller BrowserPluginAPI PIPE - -> [(Text,Text)] + -> PluginMethod -> HtmlT m () -pluginPage api env' = do - let env = HM.toList $ HM.fromList env' <> HM.fromList [("METHOD","list-entries"),("OUTPUT","html")] +pluginPage api method' = do - let plGet = Get Nothing [("OUTPUT", "html")] + let method = method' & over getArgs ( ("OUTPUT", "html") : ) - r <- liftIO (callRpcWaitMay @RpcChannelQuery (TimeoutSec 1) api plGet) + r <- liftIO (callRpcWaitMay @RpcChannelQuery (TimeoutSec 1) api method) <&> join <&> fromMaybe mempty diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 90f15344..c7c69a93 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -47,12 +47,14 @@ import Control.Monad.Trans.Maybe import Data.Function import Data.Aeson (object, (.=)) import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Char8 qualified as BS8 import Data.Either import Data.HashMap.Strict qualified as HM import Data.HashMap.Strict (HashMap) import Data.Maybe import Data.List qualified as List import Data.Text qualified as Text +import Data.Text.Lazy qualified as LT import Data.Text.Encoding qualified as Text import Lens.Micro.Platform (view) import Streaming.Prelude qualified as S @@ -279,15 +281,27 @@ httpWorker (PeerConfig syn) pmeta e = do middleware (static cssDir) + + let pluginPath = function $ \r -> case splitDirectories (BS8.unpack (rawPathInfo r)) of + ("/" : "browser" : plugin : _ ) -> Just [("plugin", LT.pack plugin)] + _ -> Nothing + when bro do get "/browser" do renderTextT (browserRootPage syn) >>= html - get "/browser/:plugin" $ do + get pluginPath do + + req <- Scotty.request + + debug $ red "BROWSER" <+> viaShow (splitDirectories (BS8.unpack (rawPathInfo req))) + url <- param @Text "plugin" alias <- readTVarIO aliases <&> HM.lookup url + -- args <- param @String "1" + void $ flip runContT pure do chan <- maybe (fromStringMay $ Text.unpack url) pure alias @@ -296,13 +310,9 @@ httpWorker (PeerConfig syn) pmeta e = do plugin <- readTVarIO handles <&> HM.lookup chan >>= orElse (status status404) - envv <- liftIO getEnvironment + let req = Get mempty mempty - debug $ red "ENV" <+> pretty envv - - env <- lift makeHttpEnv - - lift $ renderTextT (pluginPage plugin env) >>= html + lift $ renderTextT (pluginPage plugin req) >>= html put "/" do @@ -326,44 +336,6 @@ httpWorker (PeerConfig syn) pmeta e = do -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/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 7a8792cf..5bd76706 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -177,6 +177,8 @@ library HBS2.Peer.RPC.Internal.Types HBS2.Peer.CLI.Detect + HBS2.Peer.HTTP.Root + other-modules: -- HBS2.System.Logger.Simple diff --git a/hbs2-peer/lib/HBS2/Peer/HTTP/Root.hs b/hbs2-peer/lib/HBS2/Peer/HTTP/Root.hs new file mode 100644 index 00000000..046e7f99 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/HTTP/Root.hs @@ -0,0 +1,9 @@ +module HBS2.Peer.HTTP.Root where + +import HBS2.Prelude.Plated + +import System.FilePath +import Data.Text qualified as Text + +path :: [String] -> Text +path = Text.pack . joinPath diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs b/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs index 0757104c..1f344599 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs @@ -1,3 +1,4 @@ +{-# Language TemplateHaskell #-} module HBS2.Peer.Proto.BrowserPlugin ( module HBS2.Peer.Proto.BrowserPlugin , module HBS2.Net.Proto.Service @@ -10,6 +11,7 @@ import HBS2.Net.Proto.Service import Data.ByteString.Lazy (ByteString) import Codec.Serialise +import Lens.Micro.Platform data RpcChannelQuery @@ -17,9 +19,13 @@ data RpcChannelQuery type BrowserPluginAPI = '[ RpcChannelQuery ] data PluginMethod = - Get (Maybe Text) [(Text,Text)] + Get { _getPath :: [Text] + , _getArgs :: [(Text,Text)] + } deriving stock Generic +makeLenses 'Get + instance Serialise PluginMethod -- API endpoint definition