clplug 0.4.0.0 → 1.0.0.0
raw patch · 19 files changed
+931/−937 lines, 19 filesdep +attoparsec-aesondep +stmdep ~aesondep ~attoparsecdep ~base
Dependencies added: attoparsec-aeson, stm
Dependency ranges changed: aeson, attoparsec, base, bytestring, conduit, mtl, network, text
Files
- CHANGELOG.md +5/−1
- README.md +11/−31
- clplug.cabal +62/−69
- src/Control/Client.hs +0/−84
- src/Control/Internal/Conduit.hs +0/−103
- src/Control/Plugin.hs +0/−139
- src/Data/Lightning.hs +0/−14
- src/Data/Lightning/Generic.hs +0/−21
- src/Data/Lightning/Hooks.hs +0/−219
- src/Data/Lightning/Manifest.hs +0/−56
- src/Data/Lightning/Notifications.hs +0/−188
- src/Data/Lightning/Util.hs +0/−12
- src/Plugin/Client.hs +101/−0
- src/Plugin/Connect.hs +152/−0
- src/Plugin/Generic.hs +23/−0
- src/Plugin/Hooks.hs +218/−0
- src/Plugin/Internal/Conduit.hs +116/−0
- src/Plugin/Manifest.hs +56/−0
- src/Plugin/Notifications.hs +187/−0
CHANGELOG.md view
@@ -8,4 +8,8 @@ ## Unreleased -## 0.1.0.0 - YYYY-MM-DD+## 1.0.0.0 - 2024-05-25+- I see now I probably shouldn't have put this on hackage.+- This version simplifies the UI prefering Value over defining values that may be changed by core lightning.+- (Major Bug Fix) Previous versions had incomplete parsing that led to leaking threads on unexpected data. +- lightningCli is now an overloaded class so simpler interface is allowed i.e. (lightningCli "getinfo") or lightningCli ("listpeers", fromList ["<peerid>"])
README.md view
@@ -3,22 +3,14 @@ Create [Core Lightning](https://lightning.readthedocs.io/PLUGINS.html) plugins in haskell. -To get started import the Library by adding it to your projects stack.yaml: +Use `plugin` to create an executable that can be installed as a plugin! + ```-extra-deps:-- clplug-0.4.0.0+main = plugin manifest start app ```-Once the library is imported there are two main imports. -- Data.Lightning is all of the data types for the manifest, the notification and the hooks. -- Control.Plugin contains the monadic context and interface to your node. -The steps to create a plugin are: --- A [manifest](https://lightning.readthedocs.io/PLUGINS.html#the-getmanifest-method) defines the interface your plugin will have with core lightning. -+A [manifest](https://lightning.readthedocs.io/PLUGINS.html#the-getmanifest-method) defines the interface with core lightning. It is just a Value but Plugin.Manifest has helper types to easily define it. ```-import Data.Aeson-import Data.Lightning manifest = object [ "dynamic" .= True , "subscriptions" .= ([] :: [Text] )@@ -32,35 +24,23 @@ ] ``` -- A start function that returns the initial state.-+start runs on startup and defines the initial state. ```-import Control.Plugin -import Control.Client start = do - (rpcHandle, Init options config) <- ask- Just response <- lightningCli (Command "getinfo" filter params)+ _ <- lightningCli ("getinfo" :: Text) _ <- liftIO . forkIO $ < service > return < state > ``` -- An app function runs every time data comes in from the plugin. You define handlers that processes the data. If an id is present that means that core lightning is expecting a response and default node operation or the operation of other plugins may be pending your response. Use release to allow default to continue, reject to abort default behavior, and respond to send a custom response which in the case of custom rpcmethods will pass through back to the user. -+app handler function allows you to monitor status (through notification), add rpc commands, or augment normal operation (through hooks). ```-app :: (Maybe Id, Method, Params) -> PluginMonad a b-app (Just i, "method", params) = - if contition +app (Req (Just i) "method" params) = + if <condition> then release i else reject i ``` -- Finally use the plugin function to create an executable that can be installed as a plugin! --```-main :: IO ()-main = plugin manifest start app--```+Remember any output to stdout will break the connection. -##### tipjar: bc1q5xx9mathvsl0unfwa3jlph379n46vu9cletshr+##### tipjar: bc1q5xx9mathvsl0unfwa3jlph379n46vu9cletshr | lno1pgz8getnwstzzqehd9zs2y36z2504hv42g7ucg6cnzknhq9qde9x8j3xlmtgm5x30s
clplug.cabal view
@@ -1,76 +1,69 @@-cabal-version: 1.12-name: clplug-version: 0.4.0.0-license: BSD3-license-file: LICENSE-copyright: 2023-maintainer: taylorsingletonfookes@live.com-author: Taylor Singleton-Fookes-homepage: https://github.com/AutonomousOrganization/clplug#readme-bug-reports: https://github.com/AutonomousOrganization/clplug/issues-synopsis: Create Core Lightning Plugins-description:- Library to create plugins to extend the functionality of Core Lightning daemon.+cabal-version: 1.12 -category: bitcoin, lightning, plugin-build-type: Simple+-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name: clplug+version: 1.0.0.0+synopsis: Easily add functionality to your lightning node+description: For more information see the documentation about plugins from the core lightning project https://docs.corelightning.org/docs/plugins+category: bitcoin, lightning, plugin+author: autonomousorganization+maintainer: autonomousorganization+copyright: 2024+license: MIT+license-file: LICENSE+build-type: Simple extra-source-files: README.md CHANGELOG.md -source-repository head- type: git- location: https://github.com/AutonomousOrganization/clplug- library- exposed-modules:- Control.Client- Control.Internal.Conduit- Control.Plugin- Data.Lightning- Data.Lightning.Generic- Data.Lightning.Hooks- Data.Lightning.Manifest- Data.Lightning.Notifications- Data.Lightning.Util-- hs-source-dirs: src- other-modules: Paths_clplug- default-language: Haskell2010- ghc-options:- -Wall -Wcompat -Widentities -Wincomplete-record-updates- -Wincomplete-uni-patterns -Wmissing-export-lists- -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints-- build-depends:- aeson <2.1,- attoparsec <0.15,- base >=4.7 && <5,- bytestring <0.12,- conduit <1.4,- mtl <2.3,- network <3.2,- text <1.3--test-suite blitz-test- type: exitcode-stdio-1.0- main-is: Spec.hs- hs-source-dirs: test- other-modules: Paths_clplug- default-language: Haskell2010- ghc-options:- -Wall -Wcompat -Widentities -Wincomplete-record-updates- -Wincomplete-uni-patterns -Wmissing-export-lists- -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints- -threaded -rtsopts -with-rtsopts=-N+ exposed-modules:+ Plugin.Client+ Plugin.Connect+ Plugin.Generic+ Plugin.Hooks+ Plugin.Internal.Conduit+ Plugin.Manifest+ Plugin.Notifications+ other-modules:+ Paths_clplug+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ aeson >=2.2.1 && <2.3+ , attoparsec >=0.14.4 && <0.15+ , attoparsec-aeson >=2.2.0 && <2.3+ , base >=4.19 && <5+ , bytestring >=0.12.1 && <0.13+ , conduit >=1.3.5 && <1.4+ , mtl >=2.3.1 && <2.4+ , network >=3.1.4 && <3.2+ , stm >=2.5.2 && <2.6+ , text >=2.1.1 && <2.2+ default-language: GHC2021 - build-depends:- aeson <2.1,- attoparsec <0.15,- base >=4.7 && <5,- bytestring <0.12,- clplug,- conduit <1.4,- mtl <2.3,- network <3.2,- text <1.3+test-suite clplug-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_clplug+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ aeson >=2.2.1 && <2.3+ , attoparsec >=0.14.4 && <0.15+ , attoparsec-aeson >=2.2.0 && <2.3+ , base >=4.19 && <5+ , bytestring >=0.12.1 && <0.13+ , clplug+ , conduit >=1.3.5 && <1.4+ , mtl >=2.3.1 && <2.4+ , network >=3.1.4 && <3.2+ , stm >=2.5.2 && <2.6+ , text >=2.1.1 && <2.2+ default-language: GHC2021
− src/Control/Client.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE- LambdaCase- , OverloadedStrings- , DeriveGeneric- , DeriveAnyClass- , GeneralizedNewtypeDeriving- , FlexibleContexts- , DuplicateRecordFields- , TypeSynonymInstances- , FlexibleInstances- #-}--module Control.Client (- lightningCli,- lightningCliDebug,- Command(..),- PartialCommand, - Res(..)- ) - where --import Control.Plugin-import Control.Internal.Conduit-import Data.Lightning -import Data.ByteString.Lazy as L -import System.IO.Unsafe-import Data.IORef-import Control.Monad.Reader-import Data.Conduit hiding (connect) -import Data.Conduit.Combinators hiding (stdout, stderr, stdin) -import Data.Aeson-import Data.Text--type PartialCommand = Id -> Command -instance Show PartialCommand where - show x = show $ (x "") ---{-# NOINLINE idref #-} -idref :: IORef Int-idref = unsafePerformIO $ newIORef 1---- | commands to core lightning are defined by the set of plugins and version of core lightning so this is generic and you should refer to lightning-cli help <command> for the details of the command you are interested in. A filter object is used to specify the data you desire returned (i.e. {"id":True}) and params are the named fields of the command. -data Command = Command { - method :: Text- , reqFilter :: Maybe Value- , params :: Value - , ____id :: Value - } deriving (Show) -instance ToJSON Command where - toJSON (Command m Nothing p i) = - object [ "jsonrpc" .= ("2.0" :: Text)- , "id" .= i- , "method" .= m - , "params" .= toJSON p- ]- toJSON (Command m (Just f) p i) = - object [ "jsonrpc" .= ("2.0" :: Text)- , "id" .= i- , "filter" .= toJSON f- , "method" .= m - , "params" .= toJSON p- ]---- | interface with lightning-rpc. -lightningCli :: (MonadReader Plug m, MonadIO m) => - PartialCommand -> m (Maybe (Res Value))-lightningCli v = do - (Plug h _ _) <- ask- i <- liftIO $ atomicModifyIORef idref $ (\x -> (x,x)).(+1)- liftIO $ L.hPutStr h . encode $ v (toJSON i) - liftIO $ runConduit $ sourceHandle h .| inConduit .| await >>= \case - (Just (Correct x)) -> pure $ Just x- _ -> pure Nothing ---- | log wrapper for easier debugging during development.-lightningCliDebug :: (MonadReader Plug m, MonadIO m) => - (String -> IO ()) -> PartialCommand -> m (Maybe (Res Value))-lightningCliDebug logger v = do - liftIO . logger . show $ v- res <- lightningCli v - liftIO . logger . show $ res - pure res -
− src/Control/Internal/Conduit.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE- LambdaCase- , FlexibleInstances - , FlexibleContexts- , DeriveGeneric - , OverloadedStrings - #-}-module Control.Internal.Conduit (- inConduit, - ParseResult(..), - Res(..), - Req(..) - ) where --import GHC.Generics-import Data.Text (Text)-import Control.Applicative ((<|>))-import Control.Monad.State.Lazy-import Data.Aeson.Types hiding ( parse )-import Data.Aeson -import qualified Data.ByteString as S-import Data.Conduit -import Data.Attoparsec.ByteString ---- | Decode from bytestring into a JSON object. Simplified from hackage package: json-rpc -inConduit :: (Monad n) => (FromJSON a) => ConduitT S.ByteString (ParseResult a) n ()-inConduit = evalStateT l Nothing- where - l = lift await >>= maybe (lift mempty) (r >=> h)- r i = get >>= \case- Nothing -> pure $ parse json' i- Just k -> pure $ k i - h = \case- Fail{} -> lift (yield ParseErr) - Partial i -> put (Just i) >> l- Done _ v -> lift $ yield $ fin $ parseMaybe parseJSON v - fin = \case- Nothing -> InvalidReq- Just c -> Correct c--data ParseResult x = - Correct !x |- InvalidReq | - ParseErr - deriving (Show, Generic) -instance ToJSON a => ToJSON (ParseResult a) where - toJSON = genericToJSON defaultOptions -instance FromJSON a => FromJSON (ParseResult a) -data Req x = Req { - getMethod :: Text,- getParams :: x,- getReqId :: Maybe Value }- deriving (Show) - -data Res a =- Res { getResBody :: a,- getResId :: Value }- | ErrRes {- errMsg :: Text,- errId :: Maybe Value }- deriving (Show, Generic)--instance FromJSON (Req Value) where- parseJSON (Object v) = do- version <- v .: "jsonrpc"- guard (version == ("2.0" :: Text))- Req <$> v .: "method"- <*> (v .:? "params") .!= emptyArray- <*> v .:? "id"- parseJSON _ = mempty--instance FromJSON a => FromJSON (Res a) where- parseJSON (Object v) = do- version <- v .: "jsonrpc"- guard (version == ("2.0" :: Text))- fromResult <|> fromError- where- fromResult = Res <$> (v .: "result" >>= parseJSON)- <*> v .: "id"- fromError = do- err <- v .: "error"- ErrRes <$> err .: "message"- <*> v .: "id"- parseJSON (Array a) = mempty- parseJSON _ = mempty--instance ToJSON a => ToJSON (Req a) where- toJSON (Req m ps i) =- object [ "jsonrpc" .= ("2.0" :: Text)- , "method" .= m- , "params" .= toJSON ps- , "id" .= i ]--instance ToJSON (Res Value) where- toJSON (Res x i) = object [ - "jsonrpc" .= ("2.0" :: Text),- "result" .= x,- "id" .= i ]- toJSON (ErrRes msg i) = object [ - "jsonrpc" .= ("2.0" :: Text),- "error" .= object ["message" .= msg],- "id" .= i ]-
− src/Control/Plugin.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE - LambdaCase- , OverloadedStrings - , BlockArguments- , RecordWildCards- , DuplicateRecordFields- , DeriveAnyClass- , FlexibleContexts- #-}--module Control.Plugin (- plugin, - release, - reject,- respond, - PluginApp, - PluginMonad,- InitMonad,- PluginReq, - Plug(..)- ) where --import Data.Lightning-import Control.Internal.Conduit-import Control.Exception-import Data.Conduit-import Data.Conduit.Combinators (sourceHandle, sinkHandle) -import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.Aeson -import Data.Text (Text, unpack) -import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.State -import Control.Monad.Reader-import Control.Concurrent hiding (yield) -import Network.Socket as N-import System.IO---- | Function called on every event subscribed to in the manifest.-type PluginApp a = PluginReq -> PluginMonad a ()-type PluginReq = (Maybe Id, Method, Params)---- | Function called on initialization, returned value is the initial state.-type InitMonad a = ReaderT Plug IO a---- | Plugin stack contains ReaderT (ask - rpc handle & config), stateT (get/put - polymorphic state) -type PluginMonad a = ReaderT Plug (StateT a IO)---- | Handles to lightning-rpc file and stdout plugin & configuration object. -data Plug = Plug {- rpc :: Handle- , out :: Handle- , conf :: Init- }--data StartErr = ExpectManifest | ExpectInit deriving (Show, Exception) ---- | Create main executable that can be installed as core lightning plugin. --- 1st arg is the manifest that configures the interface, 2nd arg is a function--- with Plug reader that returns initial state, and 3rd arg is a function--- that is called each time data is received. -plugin :: Value -> InitMonad s -> PluginApp s -> IO ()-plugin manifest start app = do - liftIO $ mapM_ (`hSetBuffering` LineBuffering) [stdin,stdout] - runOnce $ await >>= \case - (Just (Right (Just i, "getmanifest", _))) -> yield $ Res manifest i - _ -> throw ExpectManifest- runOnce $ await >>= \case - (Just (Right (Just i, "init", v))) -> case fromJSON v of - Success xi@(Init{..}) -> do - h <- liftIO $ getrpc $ getRpcPath configuration- let plug = (Plug h stdout xi) - s' <- liftIO $ runStartup plug start- _ <- liftIO.forkIO $ runPlugin plug s' app - yield . Res (object ["result" .= ("continue" :: Text)]) $ i - where- _ -> throw ExpectInit - _ -> throw ExpectInit - threadDelay maxBound--runStartup :: Plug -> InitMonad a -> IO a -runStartup re = (`runReaderT` re) --runPlugin :: Plug -> s -> PluginApp s -> IO () -runPlugin re st = (`evalStateT` st) . (`runReaderT` re) . forever . runConduit . runner- where- runner app = sourceHandle stdin .| inConduit .| entry .| appInsert app--runOnce :: ConduitT (Either (Res Value) PluginReq) (Res Value) IO () -> IO () -runOnce = runConduit.runner- where - runner d = sourceHandle stdin .| inConduit .| entry .| d .| exit .| sinkHandle stdout--entry :: (Monad n) => ConduitT (ParseResult (Req Value)) (Either (Res Value) PluginReq) n () -entry = await >>= maybe mempty (\case - Correct v -> yield $ Right (getReqId v, getMethod v, getParams v) - InvalidReq -> yield $ Left $ ErrRes ("Request Error"::Text) Nothing - ParseErr -> yield $ Left $ ErrRes ("Parser Err"::Text) Nothing )--appInsert :: PluginApp a -> ConduitT (Either (Res Value) PluginReq) Void (PluginMonad a) () -appInsert app = await >>= maybe mempty \case - Left failed -> do- Plug _ out _ <- ask- liftIO $ runRes out failed - Right req -> lift (app req) >> pure () --runRes :: Handle -> Res Value -> IO ()-runRes o r = runConduit $ (yield r) .| exit .| sinkHandle o--exit :: (Monad n) => ConduitT (Res Value) S.ByteString n () -exit = await >>= maybe mempty (yield. L.toStrict . encode) --getrpc :: Text -> IO Handle-getrpc d = do - soc <- socket AF_UNIX Stream 0- N.connect soc $ SockAddrUnix $ unpack d- socketToHandle soc ReadWriteMode---- | Helper function to allow node to continue default behaviour. -release :: Id -> PluginMonad a ()-release i = do - Plug _ out _ <- ask- liftIO $ runRes out $ Res (object ["result" .= ("continue" :: Text)]) i---- | Helper function to prevent node default behaviour. -reject :: Id -> PluginMonad a ()-reject i = do - Plug _ out _ <- ask- liftIO $ runRes out $ Res (object ["result" .= ("reject" :: Text)]) i---- | Respond with arbitrary Value, custom rpc hooks will pass back through to terminal.-respond :: Value -> Id -> PluginMonad a ()-respond v i = do - Plug _ out _ <- ask- liftIO $ runRes out $ Res v i --getRpcPath :: InitConfig -> Text-getRpcPath conf = lightning5dir conf <> "/" <> rpc5file conf
− src/Data/Lightning.hs
@@ -1,14 +0,0 @@-{-# LANGUAGE - DuplicateRecordFields-#-} -module Data.Lightning (- module Data.Lightning.Util- , module Data.Lightning.Notifications- , module Data.Lightning.Hooks- , module Data.Lightning.Manifest - ) where--import Data.Lightning.Util-import Data.Lightning.Notifications-import Data.Lightning.Hooks-import Data.Lightning.Manifest
− src/Data/Lightning/Generic.hs
@@ -1,21 +0,0 @@--{-# LANGUAGE FlexibleContexts #-}--module Data.Lightning.Generic (defaultParse, singleField) where --import GHC.Generics-import Data.Aeson.Types --defaultParse :: (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a-defaultParse = genericParseJSON def- where - def = defaultOptions{- fieldLabelModifier = dropWhile (=='_') . map hyphen - , omitNothingFields = True- } - hyphen '5' = '-'- hyphen o = o--singleField :: (Generic a, GFromJSON Zero (Rep a)) => Key -> Value -> Parser a -singleField k1 (Object v) = v .: k1 >>= defaultParse -singleField _ _ = parseFail "Object is expected"
− src/Data/Lightning/Hooks.hs
@@ -1,219 +0,0 @@-{-# LANGUAGE- OverloadedStrings- , DeriveGeneric- , DuplicateRecordFields- -#-}--module Data.Lightning.Hooks where --import Data.Lightning.Manifest-import Data.Lightning.Generic-import Data.Lightning.Util -import GHC.Generics-import Data.Aeson.Types -import Data.Text (Text) --data Init = Init {- options :: Object - , configuration :: InitConfig- } deriving (Show, Generic) -instance FromJSON Init--data InitConfig = InitConfig {- lightning5dir :: Text - , rpc5file :: Text - , startup :: Bool - , network :: Text - , feature_set :: Features - , proxy :: Maybe Addr - , torv35enabled :: Maybe Bool - , always_use_proxy :: Maybe Bool - } deriving (Show, Generic) -instance FromJSON InitConfig where- parseJSON = defaultParse--data Addr = Addr {- _type :: Text- , address :: Text- , port :: Int- } deriving (Show, Generic)-instance FromJSON Addr where- parseJSON = defaultParse--data PeerConnected = PeerConnected {- _id :: Text - , direction :: Text - , addr :: Text - , features :: Text- } deriving Generic-instance FromJSON PeerConnected where - parseJSON = singleField "peer" --data CommitmentRevocation = CommitmentRevocation {- commitment_txid :: Text - , penalty_tx :: Text - , channel_id :: Text - , commitnum :: Int - } deriving Generic-instance FromJSON CommitmentRevocation--data DbWrite = DbWrite {- data_version :: Int- , writes :: [Text]- } deriving Generic -instance FromJSON DbWrite--data InvoicePayment = InvoicePayment {- label :: Text - , preimage :: Text - , msat :: Text- , extratlvs :: Value- } deriving Generic -instance FromJSON InvoicePayment where - parseJSON = singleField "payment"--data OpenChannel = OpenChannel {- _id :: Text - , funding_msat :: Msat - , push_msat :: Msat - , dust_limit_msat :: Msat - , max_htlc_value_in_flight_msat :: Msat- , channel_reserve_msat :: Msat - , htlc_minimum_msat :: Msat - , feerate_per_kw :: Int- , to_self_delay :: Int - , max_accepted_htlcs :: Int - , channel_flags :: Int- } deriving Generic-instance FromJSON OpenChannel where - parseJSON = singleField "openchannel" --data OpenChannel2 = OpenChannel2 {- _id :: Text - , channel_id :: Text- , their_funding_msat :: Msat- , dust_limit_msat :: Msat - , max_htlc_value_in_flight_msat :: Msat- , htlc_minimum_msat :: Msat - , funding_feerate_per_kw :: Int- , commitment_feerate_per_kw :: Int- , feerate_our_max :: Int- , feerate_our_min :: Int - , to_self_delay :: Int - , max_accepted_htlcs :: Int - , channel_flags :: Int- , locktime :: Int - , channel_max_msat :: Msat- , requested_lease_msat :: Msat- , lease_blockheight_start :: Int - , node_blockheight :: Int- } deriving Generic-instance FromJSON OpenChannel2 where - parseJSON = singleField "openchannel2" --data OpenChannel2Changed = OpenChannel2Changed {- channel_id :: Text - , psbt :: Text- } deriving Generic-instance FromJSON OpenChannel2Changed where - parseJSON = singleField "openchannel2_changed"--data OpenChannel2Sign = OpenChannel2Sign {- channel_id :: Text - , psbt :: Text- } deriving Generic-instance FromJSON OpenChannel2Sign where - parseJSON = singleField "openchannel2_sign"--data RbfChannel = RbfChannel {- _id :: Text - , channel_id :: Text - , their_last_funding_msat :: Msat- , their_funding_msat :: Msat- , our_last_funding_msat :: Msat- , funding_feerate_per_kw :: Int - , feerate_our_max :: Int - , feerate_our_min :: Int - , channel_max_msat :: Msat - , locktime :: Int - , requested_lease_msat :: Msat- } deriving Generic-instance FromJSON RbfChannel where - parseJSON = singleField "rbf_channel"---data HtlcAccepted = HtlcAccepted {- onion :: HtlcOnion- , htlc :: Htlc- , forward_to :: Text- } deriving Generic-instance FromJSON HtlcAccepted---data HtlcOnion = HtlcOnion {- payload :: Text - , short_channel_id :: Text- , forward_msat :: Msat - , outgoing_cltv_value :: Msat - , shared_secret :: Text - , next_ontion :: Text- } deriving Generic-instance FromJSON HtlcOnion--data Htlc = Htlc {- short_channel_id :: Text- , _id :: Int - , amount_msat :: Msat - , cltv_expiry :: Int - , cltv_expiry_relative :: Int - , payment_hash :: Text - } deriving Generic-instance FromJSON Htlc where - parseJSON = defaultParse--data RpcCommand = RpcCommand {- _id :: Int - , method :: Text - , params :: Value- } deriving Generic-instance FromJSON RpcCommand where - parseJSON = singleField "rpc_command"--data CustomMsg = CustomMsg {- peer_id :: Text - , payload :: Text- } deriving Generic-instance FromJSON CustomMsg--data OnionMessageRecv = OnionMessageRecv {- reply_first_node :: Text - , reply_blinding :: Text - , reply_path :: [MsgHop] - , invoice_request :: Text - , invoice :: Text - , invoice_error :: Text- , unknown_fields :: Value- } deriving Generic-instance FromJSON OnionMessageRecv--data OnionMessageRecvSecret = OnionMessageRecvSecret {- pathsecret :: Text- , reply_first_node :: Text - , reply_blinding :: Text - , reply_path :: [MsgHop] - , invoice_request :: Text - , invoice :: Text - , invoice_error :: Text- , unknown_fields :: Value- } deriving Generic-instance FromJSON OnionMessageRecvSecret--data MsgHop = MsgHop {- _id :: Text - , encrypted_recipient_data :: Text - , blinding :: Text - } deriving Generic-instance FromJSON MsgHop where - parseJSON = defaultParse-
− src/Data/Lightning/Manifest.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE - DeriveGeneric- , DuplicateRecordFields-#-}--module Data.Lightning.Manifest where --import GHC.Generics-import Data.Lightning.Generic-import Data.Aeson-import Data.Text (Text) --type Manifest = Value --data Option = Option {- name :: Text - , _type :: Text- , _default :: Text - , description :: Text- , deprecated :: Bool- } deriving Generic -instance ToJSON Option where - toJSON = genericToJSON defaultOptions{fieldLabelModifier = dropWhile (=='_')}--data RpcMethod = RpcMethod {- name :: Text- , usage :: Text- , description :: Text- , long_description :: Maybe Text - , deprecated :: Bool- } deriving Generic -instance ToJSON RpcMethod where - toJSON = genericToJSON defaultOptions{omitNothingFields = True}- -data Hook = Hook { - name :: Text - , before :: Maybe Value- } deriving Generic -instance ToJSON Hook where - toJSON = genericToJSON defaultOptions{omitNothingFields = True}--data Notification = Notification { - __method :: Text- } deriving Generic-instance ToJSON Notification where - toJSON = genericToJSON defaultOptions{fieldLabelModifier = dropWhile (=='_')}--data Features = Features {- __init :: String- , node :: String - , channel :: String - , invoice :: String - } deriving (Generic, Show)-instance ToJSON Features -instance FromJSON Features where - parseJSON = defaultParse
− src/Data/Lightning/Notifications.hs
@@ -1,188 +0,0 @@-{-# LANGUAGE - OverloadedStrings- , DeriveGeneric- , DuplicateRecordFields- , FlexibleContexts -#-}--module Data.Lightning.Notifications where --import Data.Lightning.Generic -import Data.Lightning.Util -import GHC.Generics-import Data.Aeson.Types -import Data.Text (Text) --data ChannelOpened = ChannelOpened {- ___id :: Text - , funding_msat :: Int- , funding_txid :: Text- , channel_ready :: Bool- } deriving Generic-instance FromJSON ChannelOpened where - parseJSON = singleField "channel_opened"--data ChannelOpenFailed = ChannelOpenFailed {- channel_id :: Text- } deriving Generic-instance FromJSON ChannelOpenFailed where - parseJSON = singleField "channel_open_failed"--data ChannelStateChanged = ChannelStateChanged {- peer_id :: Text- , channel_id :: Text- , short_channel_id :: Text- , timestamp :: Text- , old_state :: Text- , new_state :: Text- , cause :: Text- , message :: Text- } deriving Generic-instance FromJSON ChannelStateChanged where - parseJSON = singleField "channel_state_changed"--data Connect = Connect {- _id :: Text- , direction :: Text- , address :: Text - } deriving Generic -instance FromJSON Connect where- parseJSON = defaultParse--data Disconnect = Disconnect {- _id :: Text- } deriving Generic-instance FromJSON Disconnect where- parseJSON = defaultParse--data InvoiceCreation = InvoiceCreation {- label :: Text- , preimage :: Text- , amount_msat :: Msat- } deriving Generic-instance FromJSON InvoiceCreation where- parseJSON = singleField "invoice_creation"--data Warning = Warning {- level :: Text- , time :: Text- , source :: Text- , log :: Text- } deriving Generic -instance FromJSON Warning where- parseJSON = singleField "warning"--data ForwardEvent = ForwardEvent {- payment_hash :: Text- , in_channel :: Text- , out_channel :: Text- , in_msat :: Msat- , out_msat :: Msat- , fee_msat :: Msat- , status :: Text - , failcode :: Maybe Int- , failreason :: Maybe Text- , received_time :: Double - , resolved_time :: Maybe Double - } deriving Generic-instance FromJSON ForwardEvent where - parseJSON = singleField "forward_event"--data SendPaySuccess = SendPaySuccess {- _id :: Int - , payment_hash :: Text- , destination :: Text- , amount_msat :: Msat- , amount_sent_msat :: Msat- , created_at :: Int- , status :: Text- , payment_preimage :: Text- } deriving Generic -instance FromJSON SendPaySuccess where - parseJSON = singleField "sendpay_success"--data SendPayFailure = SendPayFailure {- code :: Int - , message :: Text- , _data :: FailData- } deriving Generic -instance FromJSON SendPayFailure where - parseJSON = singleField "sendpay_failure"--data FailData = FailData {- _id :: Int- , payment_hash :: Text - , destination :: Text - , amount_msat :: Msat- , amount_sent_msat :: Msat- , created_at :: Int - , status :: Text - , erring_index :: Int - , failcode :: Int - , failcodename :: Text - , erring_node :: Text- , erring_channel :: Text - , erring_direction :: Int - } deriving Generic-instance FromJSON FailData where- parseJSON = defaultParse--data CoinMovement = CoinMovement {- version :: Int - , node_id :: Text - , __type :: Text - , account_id :: Text- , originating_account :: Maybe Text - , txid :: Maybe Text - , utxo_txid :: Maybe Text- , vout :: Maybe Int - , part_id :: Maybe Int - , payment_hash :: Maybe Text - , credit_msat :: Maybe Int- , debit_msat :: Maybe Int- , output_msat :: Maybe Int- , output_count :: Maybe Int - , fees_msat :: Maybe Int- , tags :: [Text]- , blockheight :: Maybe Int - , timestamp :: Int - , coin_type :: Text - } deriving (Show, Generic)-instance FromJSON CoinMovement where - parseJSON = singleField "coin_movement" --data BalanceSnapshot = BalanceSnapshot { - balance_snapshots :: [Snapshot]- } deriving (Generic, Show) -instance FromJSON BalanceSnapshot --data Snapshot = Snapshot {- node_id :: Text- , blockheight :: Int - , timestamp :: Int - , accounts :: Saccount - } deriving (Show, Generic)-instance FromJSON Snapshot --data Saccount = Saccount {- account_id :: Text - , balance :: Text - , coin_type :: Text- } deriving (Show, Generic) -instance FromJSON Saccount --data BlockAdded = BlockAdded {- hash :: Text- , height :: Int- } deriving Generic -instance FromJSON BlockAdded where - parseJSON = singleField "block"--data OpenChannelPeerSigs = OpenChannelPeerSigs {- channel_id :: Text- , signed_psbt :: Text- } deriving Generic -instance FromJSON OpenChannelPeerSigs where - parseJSON = singleField "openchannel_peer_sigs"--
− src/Data/Lightning/Util.hs
@@ -1,12 +0,0 @@-module Data.Lightning.Util where --import Data.Aeson-import Data.Text (Text) --type Sat = Int -type Msat = Int-type Params = Value-type Id = Value-type Method = Text---- ...
+ src/Plugin/Client.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE+ LambdaCase+ , OverloadedStrings+ , DeriveGeneric+ , DeriveAnyClass+ , GeneralizedNewtypeDeriving+ , FlexibleContexts+ , DuplicateRecordFields+ , TypeSynonymInstances+ , FlexibleInstances+ #-}++module Plugin.Client (+ lightningCli,+ lightningCliDebug,+ Command(..),+ PartialCommand, + Res(..), + Cli+ ) + where ++import Plugin.Connect+import Plugin.Internal.Conduit+import Data.ByteString.Lazy as L +import System.IO.Unsafe+import Data.IORef+import Control.Monad.Reader+import Data.Conduit hiding (connect) +import Data.Conduit.Combinators hiding (stdout, stderr, stdin) +import Data.Aeson+import Data.Text+import Data.Maybe+import Control.Concurrent.STM.TVar+import Control.Monad.STM+++-- | Use with a text object for method only, a tuple for method and params, or a partialCommand (no ID) to specify a filter of the response. +class Cli a where + lightningCli :: (MonadReader Plug m, MonadIO m) => + a -> m (Maybe Res)++instance Cli Text where + lightningCli m = lightningCli_ (Command m Nothing Nothing)++instance Cli (Text, Value) where + lightningCli (m, p) = lightningCli_ (Command m (Just p) Nothing)++instance Cli PartialCommand where + lightningCli = lightningCli_++-- | Withhold the ID for use with lightningCli +type PartialCommand = Int -> Command +instance Show PartialCommand where + show x = show . x $ -1 + +data Command = Command { + method :: Text+ , params :: Maybe Value + , reqFilter :: Maybe Value+ , ____id :: Int + } deriving (Show) ++instance ToJSON Command where + toJSON (Command m p Nothing i) = + object [ "jsonrpc" .= ("2.0" :: Text)+ , "id" .= i+ , "method" .= m + , "params" .= fromMaybe (object []) p+ ]+ toJSON (Command m p (Just f) i) = + object [ "jsonrpc" .= ("2.0" :: Text)+ , "id" .= i+ , "filter" .= f+ , "method" .= m + , "params" .= fromMaybe (object []) p+ ]+++lightningCli_ :: (MonadReader Plug m, MonadIO m) => + PartialCommand -> m (Maybe Res)+lightningCli_ v = do + Plug h _ _ tv <- ask+ i <- liftIO . atomically $ stateTVar tv (\s -> (s, s + 1))+ liftIO $ L.hPutStr h . encode $ v i + liftIO $ runConduit $ sourceHandle h .| inConduit .| await >>= \case + (Just (Correct x)) -> pure $ Just x+ _ -> pure Nothing ++-- | provide a log function (that doesn't hit stdin/out) for debugging+lightningCliDebug :: (MonadReader Plug m, MonadIO m, Cli c, Show c) => + (String -> IO ()) -> c -> m (Maybe Res)+lightningCliDebug logger v = do + log' v+ res <- lightningCli v + log' res + pure res + where + log' :: (Show a, MonadIO m) => a -> m () + log' = liftIO . logger . show+
+ src/Plugin/Connect.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE + LambdaCase+ , OverloadedStrings + , BlockArguments+ , RecordWildCards+ , DuplicateRecordFields+ , DeriveAnyClass+ , FlexibleContexts+ #-}++module Plugin.Connect (+ plugin, + release, + reject,+ respond, + notify,+ Notify(..),+ PluginApp, + PluginMonad,+ InitMonad,+ Req(..), + Plug(..), + Init(..)+ ) where ++import Plugin.Internal.Conduit+import Plugin.Hooks+import Control.Exception+import Data.Conduit+import Data.Conduit.Combinators (sourceHandle, sinkHandle) +import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Aeson +import Data.Text (Text, unpack) +import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.State +import Control.Monad.Reader+import Control.Concurrent hiding (yield) +import Network.Socket as N+import System.IO+import Control.Concurrent.STM.TVar++type PluginApp a = Req -> PluginMonad a ()+type InitMonad a = ReaderT Plug IO a+type PluginMonad a = ReaderT Plug (StateT a IO)++-- | Handles to lightning-rpc and plugin, configuration object and global id. +data Plug = Plug {+ rpc :: Handle+ , out :: Handle+ , conf :: Init+ , plugId :: TVar Int+ }++data StartErr = ExpectManifest | ExpectInit deriving (Show, Exception) ++-- | Create executable that can be installed as core lightning plugin. +-- 1st arg is the manifest that configures the interface, 2nd arg is a function+-- that runs on startup and initializes/defines app state, and 3rd arg is a function+-- that is called each time data is received. +plugin :: Value -> InitMonad s -> PluginApp s -> IO ()+plugin manifest start app = do + liftIO $ mapM_ (`hSetBuffering` LineBuffering) [stdin,stdout] + runOnce $ await >>= \case + (Just (Right (Req (Just i) "getmanifest" _))) -> yield $ Res manifest i + _ -> throw ExpectManifest+ runOnce $ await >>= \case + (Just (Right (Req (Just i) "init" v))) -> case fromJSON v of + Success xi@(Init{..}) -> do + h <- liftIO $ getrpc $ getRpcPath configuration+ tv <- liftIO $ newTVarIO 1+ let plug = Plug h stdout xi tv + s' <- liftIO $ runReaderT start plug+ _ <- liftIO . forkIO $ runPlugin plug s' app + yield . Res (object ["result" .= ("continue" :: Text)]) $ i + _ -> throw ExpectInit + _ -> throw ExpectInit + threadDelay maxBound++-- | allow node to continue default behaviour +release :: Int -> PluginMonad a ()+release i = do + o <- asks out+ liftIO . runRes o $ Res (object ["result" .= ("continue" :: Text)]) i++-- | prevent node default behaviour +reject :: Int -> PluginMonad a ()+reject i = do + o <- asks out+ liftIO . runRes o $ Res (object ["result" .= ("reject" :: Text)]) i++-- | Respond with arbitrary Value, custom rpc hooks will pass through+respond :: Value -> Int -> PluginMonad a ()+respond v i = do + o <- asks out+ liftIO $ runRes o $ Res v i ++-- | Produce a notification that can be subscribed to by other plugins. +notify :: (MonadReader Plug m, MonadIO m) => Notify -> m ()+notify n = do + h <- asks out+ liftIO $ runRes h n++runPlugin :: Plug -> s -> PluginApp s -> IO () +runPlugin re st = (`evalStateT` st) . (`runReaderT` re) . runConduit . runner+ where+ runner app = sourceHandle stdin .| inConduit .| entry .| appInsert app+ appInsert :: PluginApp a -> ConduitT (Either Res Req) Void (PluginMonad a) () + appInsert app = awaitForever \case + Left failed -> do+ out <- asks out+ liftIO $ runRes out failed + Right req -> void (lift (app req))++runOnce :: ConduitT (Either Res Req) Res IO () -> IO () +runOnce = runConduit.runner+ where + runner d = sourceHandle stdin .| inConduit .| entry .| d .| exit .| sinkHandle stdout+ +runRes :: (ToJSON v) => Handle -> v -> IO ()+runRes o r = runConduit $ yield r .| exit .| sinkHandle o++entry :: (Monad n) => ConduitT (ParseResult (Req)) (Either Res Req) n () +entry = awaitForever (\case + Correct v -> yield . Right $ v -- Req (getReqId v) (getMethod v), getParams v) + InvalidReq -> yield $ Left $ ErrRes ("Request Error"::Text) 0 Nothing 0 --Nothing + ParseErr -> yield $ Left $ ErrRes ("Request Error"::Text) 0 Nothing 0 --Nothing + )+ +exit :: (Monad n, ToJSON v) => ConduitT v S.ByteString n () +exit = await >>= maybe mempty (yield. L.toStrict . encode) ++data Notify = Notify {+ method :: Text+ , params :: Value+ } deriving (Show) +instance ToJSON Notify where+ toJSON (Notify m p) = + object [ "jsonrpc" .= ("2.0" :: Text)+ , "method" .= m+ , "params" .= p+ ] ++getrpc :: Text -> IO Handle+getrpc d = do + soc <- socket AF_UNIX Stream 0+ N.connect soc $ SockAddrUnix $ unpack d+ socketToHandle soc ReadWriteMode++getRpcPath :: InitConfig -> Text+getRpcPath conf = lightning5dir conf <> "/" <> rpc5file conf
+ src/Plugin/Generic.hs view
@@ -0,0 +1,23 @@++{-# LANGUAGE FlexibleContexts #-}++module Plugin.Generic (defaultParse, singleField) where ++import GHC.Generics+import Data.Aeson.Types ++-- | helper for typical aeson instances+defaultParse :: (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a+defaultParse = genericParseJSON def+ where + def = defaultOptions{+ fieldLabelModifier = dropWhile (=='_') . map hyphen + , omitNothingFields = True+ } + hyphen '5' = '-'+ hyphen o = o++-- | many responses from node are objects under a single key, helper for this case+singleField :: (Generic a, GFromJSON Zero (Rep a)) => Key -> Value -> Parser a +singleField k1 (Object v) = v .: k1 >>= defaultParse +singleField _ _ = parseFail "Object is expected"
+ src/Plugin/Hooks.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE+ OverloadedStrings+ , DeriveGeneric+ , DuplicateRecordFields+ +#-}++module Plugin.Hooks where ++import Plugin.Manifest+import Plugin.Generic+import GHC.Generics+import Data.Aeson.Types +import Data.Text (Text) ++data Init = Init {+ options :: Object + , configuration :: InitConfig+ } deriving (Show, Generic) +instance FromJSON Init++data InitConfig = InitConfig {+ lightning5dir :: Text + , rpc5file :: Text + , startup :: Bool + , network :: Text + , feature_set :: Features + , proxy :: Maybe Addr + , torv35enabled :: Maybe Bool + , always_use_proxy :: Maybe Bool + } deriving (Show, Generic) +instance FromJSON InitConfig where+ parseJSON = defaultParse++data Addr = Addr {+ _type :: Text+ , address :: Text+ , port :: Int+ } deriving (Show, Generic)+instance FromJSON Addr where+ parseJSON = defaultParse++data PeerConnected = PeerConnected {+ _id :: Text + , direction :: Text + , addr :: Text + , features :: Text+ } deriving Generic+instance FromJSON PeerConnected where + parseJSON = singleField "peer" ++data CommitmentRevocation = CommitmentRevocation {+ commitment_txid :: Text + , penalty_tx :: Text + , channel_id :: Text + , commitnum :: Int + } deriving Generic+instance FromJSON CommitmentRevocation++data DbWrite = DbWrite {+ data_version :: Int+ , writes :: [Text]+ } deriving Generic +instance FromJSON DbWrite++data InvoicePayment = InvoicePayment {+ label :: Text + , preimage :: Text + , msat :: Text+ , extratlvs :: Value+ } deriving Generic +instance FromJSON InvoicePayment where + parseJSON = singleField "payment"++data OpenChannel = OpenChannel {+ _id :: Text + , funding_msat :: Int + , push_msat :: Int + , dust_limit_msat :: Int + , max_htlc_value_in_flight_msat :: Int+ , channel_reserve_msat :: Int + , htlc_minimum_msat :: Int + , feerate_per_kw :: Int+ , to_self_delay :: Int + , max_accepted_htlcs :: Int + , channel_flags :: Int+ } deriving Generic+instance FromJSON OpenChannel where + parseJSON = singleField "openchannel" ++data OpenChannel2 = OpenChannel2 {+ _id :: Text + , channel_id :: Text+ , their_funding_msat :: Int+ , dust_limit_msat :: Int + , max_htlc_value_in_flight_msat :: Int+ , htlc_minimum_msat :: Int + , funding_feerate_per_kw :: Int+ , commitment_feerate_per_kw :: Int+ , feerate_our_max :: Int+ , feerate_our_min :: Int + , to_self_delay :: Int + , max_accepted_htlcs :: Int + , channel_flags :: Int+ , locktime :: Int + , channel_max_msat :: Int+ , requested_lease_msat :: Int+ , lease_blockheight_start :: Int + , node_blockheight :: Int+ } deriving Generic+instance FromJSON OpenChannel2 where + parseJSON = singleField "openchannel2" ++data OpenChannel2Changed = OpenChannel2Changed {+ channel_id :: Text + , psbt :: Text+ } deriving Generic+instance FromJSON OpenChannel2Changed where + parseJSON = singleField "openchannel2_changed"++data OpenChannel2Sign = OpenChannel2Sign {+ channel_id :: Text + , psbt :: Text+ } deriving Generic+instance FromJSON OpenChannel2Sign where + parseJSON = singleField "openchannel2_sign"++data RbfChannel = RbfChannel {+ _id :: Text + , channel_id :: Text + , their_last_funding_msat :: Int+ , their_funding_msat :: Int+ , our_last_funding_msat :: Int+ , funding_feerate_per_kw :: Int + , feerate_our_max :: Int + , feerate_our_min :: Int + , channel_max_msat :: Int + , locktime :: Int + , requested_lease_msat :: Int+ } deriving Generic+instance FromJSON RbfChannel where + parseJSON = singleField "rbf_channel"+++data HtlcAccepted = HtlcAccepted {+ onion :: HtlcOnion+ , htlc :: Htlc+ , forward_to :: Text+ } deriving Generic+instance FromJSON HtlcAccepted+++data HtlcOnion = HtlcOnion {+ payload :: Text + , short_channel_id :: Text+ , forward_msat :: Int + , outgoing_cltv_value :: Int + , shared_secret :: Text + , next_ontion :: Text+ } deriving Generic+instance FromJSON HtlcOnion++data Htlc = Htlc {+ short_channel_id :: Text+ , _id :: Int + , amount_msat :: Int + , cltv_expiry :: Int + , cltv_expiry_relative :: Int + , payment_hash :: Text + } deriving Generic+instance FromJSON Htlc where + parseJSON = defaultParse++data RpcCommand = RpcCommand {+ _id :: Int + , method :: Text + , params :: Value+ } deriving Generic+instance FromJSON RpcCommand where + parseJSON = singleField "rpc_command"++data CustomMsg = CustomMsg {+ peer_id :: Text + , payload :: Text+ } deriving Generic+instance FromJSON CustomMsg++data OnionMessageRecv = OnionMessageRecv {+ reply_first_node :: Text + , reply_blinding :: Text + , reply_path :: [MsgHop] + , invoice_request :: Text + , invoice :: Text + , invoice_error :: Text+ , unknown_fields :: Value+ } deriving Generic+instance FromJSON OnionMessageRecv++data OnionMessageRecvSecret = OnionMessageRecvSecret {+ pathsecret :: Text+ , reply_first_node :: Text + , reply_blinding :: Text + , reply_path :: [MsgHop] + , invoice_request :: Text + , invoice :: Text + , invoice_error :: Text+ , unknown_fields :: Value+ } deriving Generic+instance FromJSON OnionMessageRecvSecret++data MsgHop = MsgHop {+ _id :: Text + , encrypted_recipient_data :: Text + , blinding :: Text + } deriving Generic+instance FromJSON MsgHop where + parseJSON = defaultParse+
+ src/Plugin/Internal/Conduit.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE+ LambdaCase+ , FlexibleInstances + , FlexibleContexts+ , DeriveGeneric + , OverloadedStrings + #-}+ +module Plugin.Internal.Conduit (+ inConduit, + ParseResult(..), + Res(..), + Req(..) + ) where ++import GHC.Generics+import Data.Text (Text)+import Control.Applicative ((<|>))+import Control.Monad.State.Lazy+import Data.Aeson.Types hiding ( parse )+import Data.Aeson +import Data.Aeson.Parser (json')+import Data.Conduit+import Data.ByteString (ByteString)+import Data.Attoparsec.ByteString as A+import Control.Monad++-- | Decode from bytestring into a JSON object. inspired by package json-rpc +inConduit :: (Monad n, FromJSON a) => + ConduitT ByteString (ParseResult a) n ()+inConduit = evalStateT (l) Nothing + where + l = lift await >>= maybe (error "non") p+ p = r >=> h+ r i = get >>= \case+ Nothing -> pure $ parse json' i + Just k -> pure $ k i + h = \case+ Fail{} -> lift (yield ParseErr) >> put Nothing >> l+ Partial i -> put (Just i) >> l+ Done rest v -> do + lift . yield . maybe InvalidReq Correct $ parseMaybe parseJSON v + if rest == "\n\n" then put Nothing >> l else p rest+ +data ParseResult x = + Correct !x |+ InvalidReq | + ParseErr + deriving (Show, Generic) +instance ToJSON a => ToJSON (ParseResult a) where + toJSON = genericToJSON defaultOptions +instance FromJSON a => FromJSON (ParseResult a) ++data Req = Req { + reqId :: Maybe Int,+ reqMethod :: Text,+ reqParams :: Value+ } deriving (Show) + +data Res =+ Res { resBody :: Value,+ resId :: Int }+ | ErrRes {+ errMsg :: Text,+ errCode :: Int,+ errData :: Maybe Value,+ errId :: Int }+ deriving (Show, Generic)++instance FromJSON Req where+ parseJSON (Object v) = do+ version <- v .: "jsonrpc"+ guard (version == ("2.0" :: Text))+ Req <$> v .:? "id"+ <*> v .: "method"+ <*> (v .:? "params") .!= emptyArray+ parseJSON _ = mempty++instance FromJSON Res where+ parseJSON (Object v) = do+ version <- v .: "jsonrpc"+ guard (version == ("2.0" :: Text))+ fromResult <|> fromError+ where+ fromResult = Res <$> v .: "result" + <*> v .: "id"+ fromError = do+ err <- v .: "error"+ ErrRes <$> err .: "message"+ <*> err .: "code"+ <*> err .:? "data"+ <*> v .: "id"+ parseJSON (Array _) = mempty+ parseJSON _ = mempty++instance ToJSON (Req) where+ toJSON (Req i m ps ) =+ object [ "jsonrpc" .= ("2.0" :: Text)+ , "method" .= m+ , "params" .= ps+ , "id" .= i ]++instance ToJSON Res where+ toJSON (Res x i) = object [ + "jsonrpc" .= ("2.0" :: Text),+ "result" .= x,+ "id" .= i ]++ toJSON (ErrRes msg c d i) = object [ + "jsonrpc" .= ("2.0" :: Text),+ "error" .= object ["message" .= msg, + "code" .= c,+ "data" .= d + ],+ "id" .= i ]+
+ src/Plugin/Manifest.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE + DeriveGeneric+ , DuplicateRecordFields+#-}++module Plugin.Manifest where ++import GHC.Generics+import Plugin.Generic+import Data.Aeson+import Data.Text (Text) ++type Manifest = Value ++data Option = Option {+ name :: Text + , _type :: Text+ , _default :: Text + , description :: Text+ , deprecated :: Bool+ } deriving Generic +instance ToJSON Option where + toJSON = genericToJSON defaultOptions{fieldLabelModifier = dropWhile (=='_')}++data RpcMethod = RpcMethod {+ name :: Text+ , usage :: Text+ , description :: Text+ , long_description :: Maybe Text + , deprecated :: Bool+ } deriving Generic +instance ToJSON RpcMethod where + toJSON = genericToJSON defaultOptions{omitNothingFields = True}+ +data Hook = Hook { + name :: Text + , before :: Maybe Value+ } deriving Generic +instance ToJSON Hook where + toJSON = genericToJSON defaultOptions{omitNothingFields = True}++data Notification = Notification { + __method :: Text+ } deriving Generic+instance ToJSON Notification where + toJSON = genericToJSON defaultOptions{fieldLabelModifier = dropWhile (=='_')}++data Features = Features {+ __init :: Text+ , node :: Text + , channel :: Text + , invoice :: Text + } deriving (Generic, Show)+instance ToJSON Features +instance FromJSON Features where + parseJSON = defaultParse
+ src/Plugin/Notifications.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE + OverloadedStrings+ , DeriveGeneric+ , DuplicateRecordFields+ , FlexibleContexts +#-}++module Plugin.Notifications where ++import Plugin.Generic +import GHC.Generics+import Data.Aeson.Types +import Data.Text (Text) ++data ChannelOpened = ChannelOpened {+ ___id :: Text + , funding_msat :: Int+ , funding_txid :: Text+ , channel_ready :: Bool+ } deriving Generic+instance FromJSON ChannelOpened where + parseJSON = singleField "channel_opened"++data ChannelOpenFailed = ChannelOpenFailed {+ channel_id :: Text+ } deriving Generic+instance FromJSON ChannelOpenFailed where + parseJSON = singleField "channel_open_failed"++data ChannelStateChanged = ChannelStateChanged {+ peer_id :: Text+ , channel_id :: Text+ , short_channel_id :: Text+ , timestamp :: Text+ , old_state :: Text+ , new_state :: Text+ , cause :: Text+ , message :: Text+ } deriving Generic+instance FromJSON ChannelStateChanged where + parseJSON = singleField "channel_state_changed"++data Connect = Connect {+ _id :: Text+ , direction :: Text+ , address :: Text + } deriving Generic +instance FromJSON Connect where+ parseJSON = defaultParse++data Disconnect = Disconnect {+ _id :: Text+ } deriving Generic+instance FromJSON Disconnect where+ parseJSON = defaultParse++data InvoiceCreation = InvoiceCreation {+ label :: Text+ , preimage :: Text+ , amount_msat :: Int+ } deriving Generic+instance FromJSON InvoiceCreation where+ parseJSON = singleField "invoice_creation"++data Warning = Warning {+ level :: Text+ , time :: Text+ , source :: Text+ , log :: Text+ } deriving Generic +instance FromJSON Warning where+ parseJSON = singleField "warning"++data ForwardEvent = ForwardEvent {+ payment_hash :: Text+ , in_channel :: Text+ , out_channel :: Text+ , in_msat :: Int+ , out_msat :: Int+ , fee_msat :: Int+ , status :: Text + , failcode :: Maybe Int+ , failreason :: Maybe Text+ , received_time :: Double + , resolved_time :: Maybe Double + } deriving Generic+instance FromJSON ForwardEvent where + parseJSON = singleField "forward_event"++data SendPaySuccess = SendPaySuccess {+ _id :: Int + , payment_hash :: Text+ , destination :: Text+ , amount_msat :: Int+ , amount_sent_msat :: Int+ , created_at :: Int+ , status :: Text+ , payment_preimage :: Text+ } deriving Generic +instance FromJSON SendPaySuccess where + parseJSON = singleField "sendpay_success"++data SendPayFailure = SendPayFailure {+ code :: Int + , message :: Text+ , _data :: FailData+ } deriving Generic +instance FromJSON SendPayFailure where + parseJSON = singleField "sendpay_failure"++data FailData = FailData {+ _id :: Int+ , payment_hash :: Text + , destination :: Text + , amount_msat :: Int+ , amount_sent_msat :: Int+ , created_at :: Int + , status :: Text + , erring_index :: Int + , failcode :: Int + , failcodename :: Text + , erring_node :: Text+ , erring_channel :: Text + , erring_direction :: Int + } deriving Generic+instance FromJSON FailData where+ parseJSON = defaultParse++data CoinMovement = CoinMovement {+ version :: Int + , node_id :: Text + , __type :: Text + , account_id :: Text+ , originating_account :: Maybe Text + , txid :: Maybe Text + , utxo_txid :: Maybe Text+ , vout :: Maybe Int + , part_id :: Maybe Int + , payment_hash :: Maybe Text + , credit_msat :: Maybe Int+ , debit_msat :: Maybe Int+ , output_msat :: Maybe Int+ , output_count :: Maybe Int + , fees_msat :: Maybe Int+ , tags :: [Text]+ , blockheight :: Maybe Int + , timestamp :: Int + , coin_type :: Text + } deriving (Show, Generic)+instance FromJSON CoinMovement where + parseJSON = singleField "coin_movement" ++data BalanceSnapshot = BalanceSnapshot { + balance_snapshots :: [Snapshot]+ } deriving (Generic, Show) +instance FromJSON BalanceSnapshot ++data Snapshot = Snapshot {+ node_id :: Text+ , blockheight :: Int + , timestamp :: Int + , accounts :: Saccount + } deriving (Show, Generic)+instance FromJSON Snapshot ++data Saccount = Saccount {+ account_id :: Text + , balance :: Text + , coin_type :: Text+ } deriving (Show, Generic) +instance FromJSON Saccount ++data BlockAdded = BlockAdded {+ hash :: Text+ , height :: Int+ } deriving Generic +instance FromJSON BlockAdded where + parseJSON = singleField "block"++data OpenChannelPeerSigs = OpenChannelPeerSigs {+ channel_id :: Text+ , signed_psbt :: Text+ } deriving Generic +instance FromJSON OpenChannelPeerSigs where + parseJSON = singleField "openchannel_peer_sigs"++