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 4933a055..e19299e1 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 @@ -20,11 +20,12 @@ import HBS2.KeyMan.Keys.Direct import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.Tx +import HBS2.Peer.Proto.BrowserPlugin + import DBPipe.SQLite import Data.ByteString.Lazy (ByteString) - import Data.Maybe import Lens.Micro.Platform hiding ( (.=) ) @@ -186,15 +187,6 @@ runDump pks = do void $ waitExitCode p -data RpcChannelQuery - --- API definition -type BrowserPluginAPI = '[ RpcChannelQuery ] - --- API endpoint definition -type instance Input RpcChannelQuery = [(Text,Text)] -type instance Output RpcChannelQuery = Maybe ByteString - class HasOracleEnv m where getOracleEnv :: m OracleEnv @@ -253,12 +245,6 @@ instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery whe formatHtml args items = do renderEntries args items <&> Just --- Codec for protocol -instance HasProtocol PIPE (ServiceProto BrowserPluginAPI PIPE) where - type instance ProtocolId (ServiceProto BrowserPluginAPI PIPE) = 0xDEADF00D123 - type instance Encoded PIPE = ByteString - decode = either (const Nothing) Just . deserialiseOrFail - encode = serialise -- Some "deferred" implementation for our monad -- note -- plain asyncs may cause to resource leak diff --git a/hbs2-peer/app/Browser/Root.hs b/hbs2-peer/app/Browser/Root.hs index 40bcef1c..bf2927c3 100644 --- a/hbs2-peer/app/Browser/Root.hs +++ b/hbs2-peer/app/Browser/Root.hs @@ -86,7 +86,7 @@ browserRootPage syn = rootPage do let bro = mconcat [ [b] | ListVal [ SymbolVal "browser", b ] <- syn ] - let channels = [ mchan | ListVal (SymbolVal "meta-channel" : mchan) <- bro ] + let channels = [ mchan | ListVal (SymbolVal "channel" : mchan) <- bro ] for_ channels $ \chan -> do diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 1089cfd3..37c9c5b8 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -1,15 +1,19 @@ +{-# LANGUAGE PatternSynonyms #-} {-# Language TypeOperators #-} module HttpWorker where import HBS2.Prelude.Plated import HBS2.OrDie +import HBS2.Base58 import HBS2.Hash import HBS2.Actors.Peer import HBS2.Storage 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.LWWRef import HBS2.Peer.Browser.Assets import HBS2.Net.Auth.Schema @@ -30,32 +34,33 @@ import Data.ByteString.Lazy qualified as LBS import Network.HTTP.Types.Status import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.StaticEmbedded -import Text.InterpolatedString.Perl6 (qc,qq,q) import Web.Scotty -import Data.Text.Lazy.IO qualified as TIO -import Data.Text.Lazy.Encoding qualified as Enc -import Text.Microstache.Compile -import Text.Microstache.Render - import Data.ByteString.Builder (byteString, Builder) -import Control.Concurrent -import Data.Either -import Data.HashMap.Strict qualified as HM 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 +import Data.Function import Data.Aeson (object, (.=)) import Data.ByteString.Lazy.Char8 qualified as LBS8 -import Control.Monad.Reader +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 Lens.Micro.Platform (view) +import Streaming.Prelude qualified as S import System.FilePath -import Control.Monad.Except -import Control.Monad.Trans.Cont +import Text.InterpolatedString.Perl6 (qc) +import System.Process.Typed --- import Lucid (renderTextT) --- import Lucid.Html5 hiding (for_) - -import UnliftIO (async) +import UnliftIO hiding (orElse) {- HLINT ignore "Functor law" -} @@ -70,6 +75,89 @@ extractMetadataHash what blob = orElse :: m r -> Maybe a -> ContT r m a orElse a mb = ContT $ maybe1 mb a + +data Plugin = + Plugin + { + } + +pattern Spawn :: forall {c}. [Syntax c] -> Syntax c +pattern Spawn args <- ListVal (SymbolVal "spawn" : args) + +runPlugin :: forall m . MonadUnliftIO m + => RefChanId L4Proto + -> [FilePath] + -> TVar (HashMap (RefChanId L4Proto) (ServiceCaller BrowserPluginAPI PIPE)) + -> m () + +runPlugin _ [] _ = pure () +runPlugin pks (self:args) handles = do + + let cmd = proc self args + & setStdin createPipe + & setStdout createPipe + & setStderr closed + + forever do + flip runContT pure do + + debug $ yellow "started channel plugin" <+> pretty (AsBase58 pks) <+> pretty self + + p <- ContT $ withProcessWait cmd + + let ssin = getStdin p + let sout = getStdout p + client <- newMessagingPipe (sout,ssin) + + void $ ContT $ withAsync $ runMessagingPipe client + + caller <- makeServiceCaller @BrowserPluginAPI @PIPE (localPeer 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 + + +findPlugins :: forall m . MonadIO m => [Syntax C] -> m [(RefChanId L4Proto, [FilePath])] +findPlugins syn = w $ S.toList_ $ do + + let chans = mconcat [ channels b | ListVal (SymbolVal "browser" : b) <- syn ] + + for_ chans $ \cha -> void $ runMaybeT do + + rchan <- toMPlus $ headMay $ + catMaybes [ fromStringMay @(RefChanId L4Proto) (Text.unpack x) + | ListVal [SymbolVal "refchan", LitStrVal x] <- cha + ] + + plug <- toMPlus $ headMay $ catMaybes $ + [ mkProcessArgs what + | ListVal [ SymbolVal "plugin", Spawn what ] <- cha + ] + + debug $ red "FOUND CHANNEL" <+> pretty (AsBase58 rchan) <+> parens (pretty plug) + + lift $ S.yield (rchan, plug) + + where + + w l = l >>= uniq + + uniq s = pure (List.nubBy ((==) `on` fst) s) + + mkProcessArgs ssyn = sequence $ + flip fmap ssyn \case + LitStrVal s -> Just (Text.unpack s) + SymbolVal (Id s) -> Just (Text.unpack s) + _ -> Nothing + + + channels bro = [ chan + | ListVal (SymbolVal "channel" : chan) <- bro + ] + httpWorker :: forall e s m . ( MyPeer e , MonadIO m , HasStorage m @@ -87,9 +175,18 @@ httpWorker (PeerConfig syn) pmeta e = do let bro = runReader (cfgValue @PeerBrowser) syn == FeatureOn penv <- ask - maybe1 port' none $ \port -> liftIO do + void $ flip runContT pure do - scotty port $ do + handles <- newTVarIO mempty + + plugins <- findPlugins syn + + for_ plugins $ \(r, args) -> do + void $ ContT $ withAsync (runPlugin r args handles) + + port <- ContT $ maybe1 port' none + + liftIO $ scotty port $ do middleware logStdout defaultHandler $ const do diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index bf5f84f8..8f3fe160 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -162,6 +162,7 @@ library HBS2.Peer.Proto.AnyRef HBS2.Peer.Proto.LWWRef HBS2.Peer.Proto.LWWRef.Internal + HBS2.Peer.Proto.BrowserPlugin HBS2.Peer.RPC.Class HBS2.Peer.RPC.API.Peer diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs b/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs new file mode 100644 index 00000000..da7cc2aa --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs @@ -0,0 +1,29 @@ +module HBS2.Peer.Proto.BrowserPlugin + ( module HBS2.Peer.Proto.BrowserPlugin + , PIPE + ) where + +import HBS2.Net.Messaging.Pipe +import HBS2.Net.Proto.Service + +import Data.Text (Text) +import Data.ByteString.Lazy (ByteString) +import Codec.Serialise + +data RpcChannelQuery + +-- API definition +type BrowserPluginAPI = '[ RpcChannelQuery ] + +-- API endpoint definition +type instance Input RpcChannelQuery = [(Text,Text)] +type instance Output RpcChannelQuery = Maybe ByteString + + +-- Codec for protocol +instance HasProtocol PIPE (ServiceProto BrowserPluginAPI PIPE) where + type instance ProtocolId (ServiceProto BrowserPluginAPI PIPE) = 3103959867 + type instance Encoded PIPE = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise +