wip

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)

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
 

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 "/"
+           <&> fmap splitDirectories
-           <&> Text.pack
+           <&> 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

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
+pluginPage api method' = do
-  let env = HM.toList $ HM.fromList env' <> HM.fromList [("METHOD","list-entries"),("OUTPUT","html")]
 
-  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
 

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
+            lift $ renderTextT (pluginPage plugin req) >>= html
-
-            env <- lift makeHttpEnv
-
-            lift $ renderTextT (pluginPage plugin env) >>= 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)

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
 

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

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