From e07bdf1d4d78ab1b14c135fbe8bdc4138885ddd9 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 29 Mar 2024 11:36:21 +0300 Subject: [PATCH] hbs2-browser plugin basically works --- .../lib/HBS2/Git/Oracle/Html.hs | 34 ++++++++++++------- .../lib/HBS2/Git/Oracle/Run.hs | 8 ++++- hbs2-peer/app/Browser/Root.hs | 2 +- hbs2-peer/app/HttpWorker.hs | 28 +++++++++------ hbs2-peer/app/PeerConfig.hs | 6 ++-- 5 files changed, 50 insertions(+), 28 deletions(-) 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 401a3988..a8756589 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 @@ -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 - doctypehtml_ do - head_ mempty do - meta_ [charset_ "utf-8"] +renderEntries args items = pure $ renderBS do + wrapped do + for_ items $ \(h,n,b,t) -> do + div_ [class_ "resource-box"] do - body_ mempty do - for_ items $ \(h,n,b,t) -> do - div_ do + let name = if Text.length n > 2 then toHtml n else toHtml (show $ pretty h) - when ( Text.length n > 2) do - h3_ [class_ "repo-name"] (toHtml (show $ pretty n)) - div_ [class_ "repo-reference"] (toHtml (show $ pretty h)) - div_ [class_ "repo-brief"] do - renderMarkdown b + h3_ [class_ "repo-name"] name + + div_ [class_ "repo-brief"] do + 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 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 e19299e1..af059092 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 @@ -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 diff --git a/hbs2-peer/app/Browser/Root.hs b/hbs2-peer/app/Browser/Root.hs index dfb974fc..0c854451 100644 --- a/hbs2-peer/app/Browser/Root.hs +++ b/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 ] diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index ad9467e4..d1bcab3f 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/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") - -- <&> fromStringMay - -- >>= orElse (status status404) + chan <- lift (param @String "refchan") + <&> fromStringMay + >>= orElse (status status404) - -- plugin <- readTVarIO handles <&> HM.lookup chan - -- >>= orElse (status status404) + plugin <- readTVarIO handles <&> HM.lookup chan + >>= orElse (status status404) - -- let env = mempty - -- lift $ renderTextT (channelPage plugin env) >>= html + let env = mempty + lift $ renderTextT (channelPage plugin env) >>= html put "/" do diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs index 90cdeb52..16fdf3fb 100644 --- a/hbs2-peer/app/PeerConfig.hs +++ b/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 - key = "browser" +instance Monad m => HasCfgKey PeerBrowserEnable a m where + key = "browser-enable" instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a b m) => HasCfgValue a FeatureSwitch m where cfgValue = lastDef FeatureOff . val <$> getConf