hbs2-browser plugin basically works

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs

@@ -11,6 +11,7 @@ import Lucid.Html5 hiding (for_)
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Word
+import Data.HashMap.Strict qualified as HM
 import Data.ByteString.Lazy
 import Text.Pandoc
 import Text.Pandoc.Error (handleError)
@@ -29,18 +30,27 @@ renderMarkdown markdown = case markdownToHtml markdown of
 
 
 renderEntries :: Monad m => HashMap Text Text -> [(HashVal, Text, Text, Word64)] -> m ByteString
-renderEntries _ items = pure $ renderBS do
+renderEntries args items = pure $ renderBS do
-  doctypehtml_ do
+  wrapped do
-    head_ mempty do
+    for_ items $ \(h,n,b,t) -> do
-      meta_ [charset_ "utf-8"]
+      div_ [class_ "resource-box"] do
 
-    body_ mempty do
+        let name = if Text.length n > 2 then toHtml n else toHtml (show $ pretty h)
-        for_ items $ \(h,n,b,t) -> do
-          div_ do
 
-            when ( Text.length n > 2) do
+        h3_ [class_ "repo-name"] name
-              h3_ [class_ "repo-name"] (toHtml (show $ pretty n))
+
-              div_ [class_ "repo-reference"] (toHtml (show $ pretty h))
+        div_ [class_ "repo-brief"] do
-              div_ [class_ "repo-brief"] do
+          renderMarkdown b
-                renderMarkdown b
+
+        div_ [class_ "repo-reference"] $ a_ [] (toHtml (show $ pretty h))
+
+  where
+
+    wrapped f | not (HM.member "HTML_WRAPPED" args) = div_ f
+              | otherwise = do
+      doctypehtml_ do
+        head_ mempty do
+          meta_ [charset_ "utf-8"]
+
+        body_ mempty f
 

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE PolyKinds #-}
@@ -195,6 +196,8 @@ instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery whe
   handleMethod args' = do
     env <- getOracleEnv
 
+    debug $ green "PLUGIN: HANDLE METHOD!"
+
     let args = HM.fromList args'
 
     case HM.lookup "METHOD" args of
@@ -260,8 +263,11 @@ runPipe :: forall m  . MonadUnliftIO m
         => Oracle m ()
 
 runPipe = do
+
+  setLogging @DEBUG  (logPrefix "" . toStderr)
+
   chan <- asks _refchanId
-  debug "run pipe"
+  debug $ green "RUN PIPE!!!"
 
   liftIO $ void $ installHandler sigPIPE Ignore Nothing
 

hbs2-peer/app/Browser/Root.hs

@@ -89,7 +89,7 @@ rootPage content  = do
 browserRootPage :: Monad m => [Syntax c] -> HtmlT m ()
 browserRootPage syn = rootPage do
 
-  let bro = mconcat [ [b] | ListVal [ SymbolVal "browser", b ] <- syn ]
+  let bro = mconcat [ b | ListVal (SymbolVal "browser": b ) <- syn ]
 
   let channels = [ mchan | ListVal (SymbolVal "channel" : mchan) <- bro ]
 

hbs2-peer/app/HttpWorker.hs

@@ -96,7 +96,7 @@ runPlugin pks (self:args) handles = do
   let cmd = proc self args
               & setStdin createPipe
               & setStdout createPipe
-              & setStderr closed
+              -- & setStderr closed
 
   forever do
     flip runContT pure do
@@ -111,12 +111,18 @@ runPlugin pks (self:args) handles = do
 
       void $ ContT $ withAsync $ runMessagingPipe client
 
+      debug $ red "RUNNING PLUGIN!"
+
       caller <- makeServiceCaller @BrowserPluginAPI @PIPE (localPeer client)
 
+      void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClient caller) client
+
       ContT $ bracket (atomically $ modifyTVar handles (HM.insert pks caller))
                       (const $ atomically $ modifyTVar handles (HM.delete pks))
 
-      liftIO $ runReaderT (runServiceClient caller) client
+
+
+
       void $ waitExitCode p
 
 
@@ -172,7 +178,7 @@ httpWorker (PeerConfig syn) pmeta e = do
 
   sto <- getStorage
   let port' = runReader (cfgValue @PeerHttpPortKey) syn  <&>  fromIntegral
-  let bro   = runReader (cfgValue @PeerBrowser) syn == FeatureOn
+  let bro   = runReader (cfgValue @PeerBrowserEnable) syn == FeatureOn
   penv <- ask
 
   void $ flip runContT pure do
@@ -314,17 +320,17 @@ httpWorker (PeerConfig syn) pmeta e = do
         get "/browser" do
           renderTextT (browserRootPage syn) >>= html
 
-        -- get "/browser/channel/:refchan" $ void $ flip runContT pure do
+        get "/browser/channel/:refchan" $ void $ flip runContT pure do
 
-        --   chan <- lift (param @String "refchan")
+          chan <- lift (param @String "refchan")
-        --            <&> fromStringMay
+                   <&> fromStringMay
-        --            >>= orElse (status status404)
+                   >>= orElse (status status404)
 
-        --   plugin <- readTVarIO handles <&> HM.lookup chan
+          plugin <- readTVarIO handles <&> HM.lookup chan
-        --              >>= orElse (status status404)
+                     >>= orElse (status status404)
 
-        --   let env = mempty
+          let env = mempty
-        --   lift $ renderTextT (channelPage plugin env) >>= html
+          lift $ renderTextT (channelPage plugin env) >>= html
 
 
       put "/" do

hbs2-peer/app/PeerConfig.hs

@@ -38,7 +38,7 @@ data PeerHttpPortKey
 data PeerTcpProbeWaitKey
 data PeerUseHttpDownload
 data PeerBrainsDBPath
-data PeerBrowser
+data PeerBrowserEnable
 
 instance Monad m => HasConf (ReaderT PeerConfig m) where
   getConf = asks (\(PeerConfig syn) -> syn)
@@ -66,8 +66,8 @@ data PeerKnownPeersFile
 instance Monad m => HasCfgKey PeerKnownPeersFile (Set String) m where
   key = "known-peers-file"
 
-instance Monad m => HasCfgKey PeerBrowser a m where
+instance Monad m => HasCfgKey PeerBrowserEnable a m where
-  key = "browser"
+  key = "browser-enable"
 
 instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a b m) => HasCfgValue a FeatureSwitch m where
   cfgValue = lastDef FeatureOff . val <$> getConf