From 5d056b0be0b762dc5bf78b87c195d6951ffb5221 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Wed, 3 Apr 2024 05:10:29 +0300 Subject: [PATCH] wip --- flake.nix | 1 + .../lib/HBS2/Git/Oracle/Html.hs | 8 ++-- .../lib/HBS2/Git/Oracle/Run.hs | 36 ++++++++------- hbs2-peer/app/Browser/Root.hs | 2 +- hbs2-peer/app/HttpWorker.hs | 17 ++++--- .../lib/HBS2/Peer/Proto/BrowserPlugin.hs | 45 +++++++++++++++++-- 6 files changed, 80 insertions(+), 29 deletions(-) diff --git a/flake.nix b/flake.nix index 40ab8c30..f7b40e1a 100644 --- a/flake.nix +++ b/flake.nix @@ -110,6 +110,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: pkgs.icu72 pkgs.openssl weeder + pkgs.html-tidy ]) ++ [ pkgs.pkg-config 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 a7772f98..a9a6d5a8 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 @@ -15,6 +15,7 @@ import Lucid.Html5 hiding (for_) import Data.Text (Text) import Data.Text qualified as Text import Data.Word +import Data.List qualified as List import Data.HashMap.Strict qualified as HM import Data.ByteString.Lazy import Text.Pandoc @@ -49,10 +50,11 @@ onClickCopy :: Text -> Attribute onClickCopy s = hyper_ [qc|on click writeText('{s}') into the navigator's clipboard add .clicked to me wait 2s remove .clicked from me|] -renderEntries :: Monad m => PluginMethod -> HashMap Text Text -> [(HashVal, Text, Text, Word64)] -> m ByteString -renderEntries (Get p _) args items = pure $ renderBS do +renderEntries :: Monad m => PluginMethod -> [(HashVal, Text, Text, Word64)] -> m ByteString +renderEntries (Method _ kw) items = pure $ renderBS do - let hrefBase = fmap Text.unpack p & Prelude.takeWhile (/= "repo") + -- TODO: ugly + let hrefBase = HM.lookup "URL_PREFIX" kw & List.singleton . maybe "/" Text.unpack wrapped do main_ do 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 f3c898c8..db06fbd9 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 @@ -157,6 +157,10 @@ runDump :: forall m . MonadUnliftIO m -> m () runDump pks = do + + let kw = ["OUTPUT", "METHOD", "URL_PREFIX", "RAW_PATH_INFO"] + <> [ [qc|_{i}|] | i <- [0..9] ] + self <- liftIO getProgName env <- liftIO getEnvironment @@ -185,7 +189,7 @@ runDump pks = do void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClient caller) client - wtf <- callService @RpcChannelQuery caller (Get path env) + wtf <- callService @RpcChannelQuery caller (createPluginMethod path env & filterKW kw) >>= orThrowUser "can't query rpc" r <- ContT $ maybe1 wtf (liftIO (hClose ssin >> exitFailure)) @@ -201,28 +205,26 @@ class HasOracleEnv m where -- API handler instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery where - handleMethod req@(Get path args') = do + handleMethod req@(Method path args) = do env <- getOracleEnv - debug $ green "PLUGIN: HANDLE METHOD!" + debug $ green "PLUGIN: HANDLE METHOD!" <+> viaShow req - let args = HM.fromList args' - - let cmd = path + let cmd = maybe path List.singleton $ HM.lookup "METHOD" args case cmd of - ("debug":_) -> listEnv args - ("list-entries":_) -> listEntries args + ("debug":_) -> listEnv req + ("list-entries":_) -> listEntries req ("repo" : _) -> renderRepo req - ("/":_) -> listEntries args - [] -> listEntries args + ("/":_) -> listEntries req + [] -> listEntries req _ -> pure Nothing where - listEnv args = do - pure $ Just $ A.encodePretty args + listEnv (Method _ a) = do + pure $ Just $ A.encodePretty a - listEntries args = do + listEntries (Method _ a) = do env <- getOracleEnv withOracleEnv env do items <- withState $ select_ @_ @(HashVal, Text, Text, Word64) [qc| @@ -245,8 +247,8 @@ instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery whe |] - case HM.lookup "OUTPUT" args of - Just "html" -> formatHtml args items + case HM.lookup "OUTPUT" a of + Just "html" -> formatHtml items Just "json" -> formatJson items _ -> formatJson items @@ -261,8 +263,8 @@ instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery whe pure $ Just $ A.encodePretty root - formatHtml args items = do - renderEntries req args items <&> Just + formatHtml items = do + renderEntries req items <&> Just -- Some "deferred" implementation for our monad diff --git a/hbs2-peer/app/Browser/Root.hs b/hbs2-peer/app/Browser/Root.hs index af14b912..2682bd42 100644 --- a/hbs2-peer/app/Browser/Root.hs +++ b/hbs2-peer/app/Browser/Root.hs @@ -353,7 +353,7 @@ pluginPage :: MonadIO m -> HtmlT m () pluginPage api method' = do - let method = method' & over getArgs ( ("OUTPUT", "html") : ) + let method = method' & over getArgs ( HM.singleton "OUTPUT" "html" <> ) r <- liftIO (callRpcWaitMay @RpcChannelQuery (TimeoutSec 1) api method) <&> join diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 3422aa3d..419c9205 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -282,9 +282,11 @@ 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 + let pluginPath = + function $ \r -> + case splitDirectories (BS8.unpack (rawPathInfo r)) of + ("/" : "browser" : plugin : _ ) -> Just [("plugin", LT.pack plugin)] + _ -> Nothing when bro do @@ -302,7 +304,6 @@ httpWorker (PeerConfig syn) pmeta e = do url <- param @Text "plugin" alias <- readTVarIO aliases <&> HM.lookup url - -- args <- param @String "1" void $ flip runContT pure do @@ -313,8 +314,14 @@ httpWorker (PeerConfig syn) pmeta e = do >>= orElse (status status404) let pp = splitDirectories rawPath + let norm = fromMaybe pp $ List.stripPrefix ["/","browser",Text.unpack url] pp - let q = Get (Text.pack <$> norm) (("RAW_PATH_INFO", fromString rawPath) : mempty) + + let opts = [ ("RAW_PATH_INFO", fromString rawPath) + , ("URL_PREFIX", "/browser" <> "/" <> url) + ] + + let q = createPluginMethod (Text.pack <$> norm) opts debug $ red "CALL PLUGIN" <+> viaShow q diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs b/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs index 5fd4698b..82ea068b 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs @@ -1,15 +1,28 @@ {-# Language TemplateHaskell #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language PatternSynonyms #-} module HBS2.Peer.Proto.BrowserPlugin - ( module HBS2.Peer.Proto.BrowserPlugin - , module HBS2.Net.Proto.Service + ( module HBS2.Net.Proto.Service , PIPE + , getPath + , getArgs + , RpcChannelQuery + , BrowserPluginAPI + , PluginMethod + , CreatePluginMethod(..) + , filterKW + , pattern Method ) where import HBS2.Prelude.Plated import HBS2.Net.Messaging.Pipe import HBS2.Net.Proto.Service +import Data.Kind +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM import Data.ByteString.Lazy (ByteString) +import Data.Text qualified as Text import Codec.Serialise import Lens.Micro.Platform @@ -18,9 +31,13 @@ data RpcChannelQuery -- API definition type BrowserPluginAPI = '[ RpcChannelQuery ] +pattern Method :: [Text] -> HashMap Text Text -> PluginMethod +pattern Method p a = Get p a +{-# COMPLETE Method #-} + data PluginMethod = Get { _getPath :: [Text] - , _getArgs :: [(Text,Text)] + , _getArgs :: HashMap Text Text } deriving stock (Show,Generic) @@ -40,3 +57,25 @@ instance HasProtocol PIPE (ServiceProto BrowserPluginAPI PIPE) where decode = either (const Nothing) Just . deserialiseOrFail encode = serialise + +class CreatePluginMethod a where + type family Dict a :: Type + createPluginMethod :: [a] -> Dict a -> PluginMethod + + +filterKW :: [Text] -> PluginMethod -> PluginMethod +filterKW kw = over getArgs (HM.filterWithKey filt) + where + filt k _ = k `elem` kw + +instance CreatePluginMethod String where + type instance Dict String = [(String,String)] + createPluginMethod path dict = + Get (fmap Text.pack path) + (HM.fromList (fmap (over _1 Text.pack . over _2 Text.pack) dict)) + +instance CreatePluginMethod Text where + type instance Dict Text = [(Text,Text)] + createPluginMethod path dict = + Get path (HM.fromList dict) +