wip

flake.nix

@@ -110,6 +110,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
             pkgs.icu72
             pkgs.openssl
             weeder
+            pkgs.html-tidy
           ])
           ++
           [ pkgs.pkg-config

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 :: Monad m => PluginMethod -> [(HashVal, Text, Text, Word64)] -> m ByteString
-renderEntries (Get p _) args items = pure $ renderBS do
+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

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  = maybe path List.singleton $ HM.lookup "METHOD" args
-
-    let cmd  = path
 
     case cmd of
-      ("debug":_)        -> listEnv args
+      ("debug":_)        -> listEnv req
-      ("list-entries":_) -> listEntries args
+      ("list-entries":_) -> listEntries req
       ("repo" : _)       -> renderRepo req
-      ("/":_)            -> listEntries args
+      ("/":_)            -> listEntries req
-      []                 -> listEntries args
+      []                 -> listEntries req
       _                  -> pure Nothing
 
     where
-      listEnv args = do
+      listEnv (Method _ a) = do
-        pure $ Just $ A.encodePretty args
+        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
+          case HM.lookup "OUTPUT" a of
-            Just "html" -> formatHtml args items
+            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
+      formatHtml items = do
-        renderEntries req args items <&> Just
+        renderEntries req items <&> Just
 
 
 -- Some "deferred" implementation for our monad

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

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
+      let pluginPath =
-                                         ("/" : "browser" : plugin : _ ) -> Just [("plugin", LT.pack plugin)]
+            function $ \r ->
-                                         _                               -> Nothing
+               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
 

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)
+