cherrypicked BrowserPlugin.hs

hbs2-peer/hbs2-peer.cabal

@@ -161,6 +161,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

hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs

@@ -0,0 +1,81 @@
+{-# Language TemplateHaskell #-}
+{-# Language AllowAmbiguousTypes #-}
+{-# Language PatternSynonyms #-}
+module HBS2.Peer.Proto.BrowserPlugin
+  ( module HBS2.Net.Proto.Service
+  , PIPE
+  , getPath
+  , getArgs
+  , RpcChannelQuery
+  , BrowserPluginAPI
+  , PluginMethod
+  , CreatePluginMethod(..)
+  , filterKW
+  , pattern Method
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.Net.Messaging.Pipe
+import HBS2.Net.Proto.Service
+
+import Data.Kind
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.ByteString.Lazy (ByteString)
+import Data.Text qualified as Text
+import Codec.Serialise
+import Lens.Micro.Platform
+
+data RpcChannelQuery
+
+-- API definition
+type BrowserPluginAPI = '[ RpcChannelQuery ]
+
+pattern Method :: [Text] -> HashMap Text Text -> PluginMethod
+pattern Method p a = Get p a
+{-# COMPLETE Method #-}
+
+data PluginMethod =
+    Get { _getPath :: [Text]
+        , _getArgs :: HashMap Text Text
+        }
+    deriving stock (Show,Generic)
+
+makeLenses 'Get
+
+instance Serialise PluginMethod
+
+-- API endpoint definition
+type instance Input RpcChannelQuery = PluginMethod
+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
+
+
+class CreatePluginMethod a where
+ type family Dict a :: Type
+ createPluginMethod :: [a] -> Dict a -> PluginMethod
+
+
+filterKW :: [Text] -> PluginMethod -> PluginMethod
+filterKW kw = over getArgs (HM.filterWithKey filt)
+  where
+    filt k _ = k `elem` kw
+
+instance CreatePluginMethod String where
+  type instance Dict String = [(String,String)]
+  createPluginMethod path dict =
+    Get (fmap Text.pack path)
+        (HM.fromList (fmap (over _1 Text.pack . over _2 Text.pack) dict))
+
+instance CreatePluginMethod Text where
+  type instance Dict Text = [(Text,Text)]
+  createPluginMethod path dict =
+    Get path (HM.fromList dict)
+