wip

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)

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

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
 -- </svg>
 
 
+{- 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

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)

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