clplug (empty) → 0.1.0.0
raw patch · 21 files changed
+1745/−0 lines, 21 filesdep +aesondep +attoparsecdep +basesetup-changed
Dependencies added: aeson, attoparsec, base, bytestring, clplug, conduit, containers, directory, fgl, fmt, format-numbers, lens, lens-aeson, mtl, network, text, time
Files
- CHANGELOG.md +11/−0
- LICENSE +19/−0
- README.md +82/−0
- Setup.hs +2/−0
- clplug.cabal +157/−0
- examples/movelog/Main.hs +84/−0
- examples/routes/Main.hs +149/−0
- examples/routes/Paths.hs +44/−0
- examples/routes/Route.hs +71/−0
- examples/routes/Search.hs +155/−0
- examples/wallet/Main.hs +119/−0
- src/Control/Client.hs +61/−0
- src/Control/Conduit.hs +104/−0
- src/Control/Plugin.hs +116/−0
- src/Data/Lightning.hs +14/−0
- src/Data/Lightning/Generic.hs +21/−0
- src/Data/Lightning/Hooks.hs +218/−0
- src/Data/Lightning/Manifest.hs +56/−0
- src/Data/Lightning/Notifications.hs +188/−0
- src/Data/Lightning/Util.hs +12/−0
- test/Spec.hs +62/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `clnplug`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright Taylor (ao) 2022-2023++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README.md view
@@ -0,0 +1,82 @@++## Core Lightning Plug++Core lightning is a daemon ([lightningd](https://lightning.readthedocs.io/PLUGINS.html)) that operates payment channels that allow you to send and receive bitcoin nearly instantly, with nearly zero fees with a high level of privacy. It does not compromise on any of the strengths of layer 1 bitcoin: no censorship, free speech, individual sovereignty, and impossible debasement. In fact it strengthens bitcoin because it encourages the operation of fully validating nodes, lightningd requires bitcoind. Clplug is a Haskell library that allows you to easily create extensions (called plugins) that extend or augment its functionality. ++To create a plugin you only need to define three arguments:+- `Manifest :: Value` - configuration of the interface with core lightning.+- `PluginInit :: PlugInfo -> IO a` - startup function that returns the starting state+- `PluginApp :: (Maybe Id, Method, Params) -> PluginMonad` - data handler function++The transformer stack contains: +- `ask` - a handle to lightning-rpc and environment info.+- `get/put` - polymorphic state+- `yield` - stdout to core lightning++Several examples are included that are intended to be useful for (d)evelopers and node (o)perators +- **movelog**+ - o - specify logfile= to create a log file with fees earned and other coin movements+ - d - a notification is subscribed, an option is added, and the state monad is used+- **wallet** + - o - show available totals and channel balances: `lightning-cli wallet`+ - d - a new rpc method is created+- **routes** + - o - generate routes: `lightning-cli route` + - d - network graph is loaded and several rpc parameters are used++Operators: the examples require option `allow-deprecated-apis=false`. To install a plugin you must: + - clone this repository+ - `stack build` + - move or symlink the created executable file into the lightning directory (by default: `.lightning/plugins`) + +The main exports from the Library are `Control.Plugin`, `Control.Client`, and `Data.Lightning`. An upload and link to hackage is pending. This is a basic usage example: +```haskell +{-# LANGUAGE + OverloadedStrings + , FlexibleContexts + , ViewPatterns+ , RecordWildCards+#-} ++module Main (main) where++-- from clplug+import Data.Lightning +import Control.Plugin +import Control.Conduit+--++import Data.Conduit +import Data.Aeson+import Data.Text++main = plugin manifest appState app++manifest :: Value +manifest = object [+ "dynamic" .= True+ , "subscriptions" .= (["channel_opened"] :: [Text] ) + , "options" .= ([]::[Option])+ , "rpcmethods" .= ([]) + , "hooks" .= ([]::[Hook])+ , "featurebits" .= object [ ]+ , "notifications" .= ([]::[Notification])+ ] ++app :: PluginApp () +app (Nothing, "channel_opened", fromJSON -> Success (ChannelOpened {..})) = do+ doublespend funding_txid + where doublespend _ = pure ()++appState = pure () +``` ++Useful areas of exploration and research are:+- fee optimization+- route selection+- economic rebalancing+- accidental channel closes++##### Donation bitcoin addr: bc1q5xx9mathvsl0unfwa3jlph379n46vu9cletshr++lightning only scales bitcoin if people run nodes
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ clplug.cabal view
@@ -0,0 +1,157 @@+cabal-version: 1.12+name: clplug+version: 0.1.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.++category: bitcoin, lightning, plugin+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.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++executable movelog+ main-is: Main.hs+ hs-source-dirs: examples/movelog+ 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++ build-depends:+ aeson <2.1,+ attoparsec <0.15,+ base >=4.7 && <5,+ bytestring <0.12,+ clplug,+ conduit <1.4,+ directory <1.4,+ fmt <0.7,+ format-numbers <0.2,+ mtl <2.3,+ network <3.2,+ text <1.3,+ time <1.12++executable routes+ main-is: Main.hs+ hs-source-dirs: examples/routes+ other-modules:+ Paths+ Route+ Search+ 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++ build-depends:+ aeson <2.1,+ attoparsec <0.15,+ base >=4.7 && <5,+ bytestring <0.12,+ clplug,+ conduit <1.4,+ containers <0.7,+ fgl <5.8,+ lens <5.2,+ lens-aeson <1.3,+ mtl <2.3,+ network <3.2,+ text <1.3++executable wallet+ main-is: Main.hs+ hs-source-dirs: examples/wallet+ 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++ build-depends:+ aeson <2.1,+ attoparsec <0.15,+ base >=4.7 && <5,+ bytestring <0.12,+ clplug,+ conduit <1.4,+ fmt <0.7,+ format-numbers <0.2,+ mtl <2.3,+ network <3.2,+ text <1.3++test-suite clnplug-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++ 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
+ examples/movelog/Main.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE + OverloadedStrings+ , RecordWildCards+ , DuplicateRecordFields+ , ViewPatterns+ , NamedFieldPuns+ , LambdaCase + , FlexibleContexts+ , DeriveAnyClass+#-}++module Main where++import Control.Plugin+import Data.Lightning +import Control.Monad.Reader+import Control.Monad.State+import Control.Exception+import Data.Aeson +import Data.Aeson.Types+import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import System.Directory +import Fmt +import Data.Text.Format.Numbers+import Data.Time.LocalTime+import Data.Time.Format++main :: IO ()+main = plugin manifest start app ++manifest = object [+ "dynamic" .= True+ , "subscriptions" .= (["coin_movement"] :: [Text] ) + , "options" .= ([+ Option "logfile" "string" "" "file path for logs" False+ ])+ , "rpcmethods" .= ([+ RpcMethod "catchcheck" "" "xd" Nothing False+ ]) + ] ++start :: PluginInit Msat+start _ = pure 0 ++data MoveError = MissingFile deriving (Show, Exception) ++app :: PluginApp Msat +app (Nothing, "coin_movement", fromJSON -> Success (CoinMovement{..})) = do + (Just filepath) <- asks getFile + fileExists <- liftIO $ doesFileExist filepath+ if not fileExists then throw MissingFile else pure () + case tags of + ["routed"] -> if hasVal debit_msat && hasVal fees_msat then do + total <- state (accumulate now) + liftIO $ movelog filepath total now + else pure () + where + now = fromJust fees_msat+ hasVal a = isJust a && ((> 0).fromJust) a+ accumulate n t = (x,x) where x = n + t+ otherMove -> liftIO $ T.appendFile filepath $ fmtLn . build $ otherMove+app (Just i, _, _) = release i+app _ = pure () ++movelog :: FilePath -> Msat -> Msat -> IO () +movelog path tots now = do+ timenow <- liftIO getTime+ liftIO . (T.appendFile path) . fmtLn $ mlog timenow+ where + mlog t = (build.(prettyI (Just ',')).(`div` 1000) $ tots) + +| " ~~ " + +| build t + +| " +"+ +| build now++ getTime = do + zone <- getZonedTime + pure $ formatTime defaultTimeLocale "%H:%M" zone + +getFile :: PlugInfo -> Maybe FilePath +getFile (_, Init opts _) = parseMaybe (.: "logfile") opts
+ examples/routes/Main.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE + DuplicateRecordFields+ , LambdaCase+ , DeriveGeneric+ , OverloadedStrings+ , BangPatterns+ , ViewPatterns+#-}+module Main where ++import Numeric +import Data.Graph.Inductive.Graph+import Data.Graph.Inductive.PatriciaTree+import Data.Char +import Control.Plugin+import Data.Lightning +import Control.Client+import Data.Aeson+import Data.Aeson.Lens+import Control.Lens hiding ((.=))+import Control.Monad.IO.Class+import GHC.Generics +import Data.Text (Text)+import Data.Lightning +import Data.Lightning.Generic +import Control.Client +import Control.Conduit+import Control.Monad.State+import Control.Monad.Reader +import Control.Applicative (liftA2) +import Data.List +import Data.Foldable +import Route +import Search ++type Gra = Gr () MyChan++main = plugin manifest start app++manifest = object [+ "dynamic" .= True+ , "options" .= ([] :: [Option])+ , "rpcmethods" .= [+ RpcMethod "route" "[n, m, a, l]" "l routes from n to m of a" Nothing False + , RpcMethod "network" "" "show metrics of loaded graph" Nothing False + ]+ ]++start :: PluginInit Gra+start (h, Init o c) = do+ Just (Res xd _) <- liftIO $ lightningCli h (Command "listnodes" nfilt noparams)+ Just (Res yd _) <- liftIO $ lightningCli h (Command "listchannels" cfilt noparams)+ case (fromJSON xd, fromJSON yd) :: (Result MyNodes, Result MyChans) of+ (Success nx, Success cx) -> pure $ mkGraph + (map toLNode (_nodes nx)) (map toLEdge' (channels cx)) + _ -> pure empty+ where toLNode ni = ((getNodeInt.nodeid) ni , ())+ toLEdge' c = (+ (getNodeInt.cSource) c+ , (getNodeInt.cDest) c+ , c+ )++app (Just i, "route", v) =+ let n = getNodeInt <$> v ^? nth 0 + m = getNodeInt <$> v ^? nth 1 + a = maybe 100000000 fromInteger $ v ^? nth 2 . _Integer+ l = maybe 1 fromInteger $ v ^? nth 3 . _Integer+ in do+ g <- get+ case valid g n m of+ Just (n', m') -> do + r <- pure . map (createRoute a . toList) $ evalChans g n' m' l+ respond (object ["routes" .= r ]) i + _ -> respond (object ["invalid nodid" .= True]) i + where ++app (Just i, "network", _) = do + g <- get+ respond (object [+ "nodes" .= order g+ , "edges" .= size g+ , "capacity" .= capacity g 0+ ]) i + where capacity g t + | isEmpty g = t + | True = case matchAny g of + (n, g') -> capacity g' $ t + (sum + . map _amount_msat+ . map snd + . lsuc' $ n )++app (Just i, _, _) = release i+app _ = pure () +++valid g n m = case (n , m) of + (Just n', Just m') -> if gelem n' g && gelem m' g+ then (Just (n', m'))+ else Nothing + _ -> Nothing+noparams = object [] +nfilt = object ["nodes" .= [nField]] +nField = object ["nodeid" .= True] ++data MyNodes = M {+ _nodes :: [MyNode] + } deriving Generic +instance FromJSON MyNodes where+ parseJSON = defaultParse+data MyNode = MyNode {+ nodeid :: Text+ } deriving Generic+instance FromJSON MyNode ++cfilt = object ["channels" .= [object [+ "source" .= True+ , "destination" .= True+ , "short_channel_id" .= True+ , "delay" .= True+ , "base_fee_millisatoshi" .= True + , "fee_per_millionth" .= True + , "amount_msat" .= True + ]]]++data MyChans = CC {+ channels :: [MyChan] + } deriving Generic+instance FromJSON MyChans+data MyChan = MyChan {+ _source :: Text+ , _destination :: Text+ , _short_channel_id :: Text+ , _delay :: Int+ , _base_fee_millisatoshi :: Msat+ , _fee_per_millionth :: Int + , _amount_msat :: Msat + } deriving Generic+instance FromJSON MyChan where + parseJSON = defaultParse+-- instance ToJSON MyChan+instance Channel MyChan where -- ? redundant?+ basefee = _base_fee_millisatoshi+ ppmrate = _fee_per_millionth+ cDelay = _delay + cDest = _destination+ cSource = _source+ shortid = _short_channel_id+
+ examples/routes/Paths.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE + DuplicateRecordFields, + LambdaCase, + DeriveGeneric, + OverloadedStrings+#-}+module Paths where ++--import Data.Lightning +--import GHC.Generics+--import Data.Aeson+--+--data PathInfo = P {+-- cost :: Fee+-- , neck :: Sat+-- } deriving (Generic, Show)+--instance ToJSON PathInfo +--instance Eq PathInfo where +-- (==) a b = (base.cost $ a) == (base.cost $ b) && (ppm.cost $ a) == (ppm.cost $ b)+--instance Ord PathInfo where +-- compare a b = compare (cost a) (cost b) +--+--data Fee = Fee {+-- base :: Int +-- , ppm :: Int +-- } deriving (Show, Generic, Eq) +--instance Ord Fee where +-- compare a b = compare (base a + ppm a) (base b + ppm b)+--instance ToJSON Fee+--+--info :: [Channel] -> PathInfo+--info = foldr pf (P (Fee 0 0) maxBound) +-- where +-- pf :: Channel -> PathInfo -> PathInfo +-- pf e c = P +-- (Fee ( (base.cost) c + base_fee_millisatoshi e )+-- (((ppm.cost) c) + fee_per_millionth e ) +-- )+-- (case htlc_maximum_msat e of +-- (Just x) -> minimum [(neck c), ((amount_msat::Channel->Msat) e), x]+-- otherwise -> min (neck c) ((amount_msat::Channel->Msat) e) +-- )+--+--
+ examples/routes/Route.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE + DuplicateRecordFields+ , OverloadedStrings+ , DeriveGeneric #-} ++module Route where ++import Data.Lightning +import Numeric (readHex) +import Data.Aeson+import GHC.Generics+import Data.Text (Text) +import Control.Applicative ++data Route = Route {+ __id :: Text + , channel :: Text + , direction :: Int+ , __amount_msat :: Msat + , __delay :: Int + , style :: Text+ } deriving (Show, Generic, Eq) +instance ToJSON Route where+ toJSON v = genericToJSON defaultOptions{fieldLabelModifier = dropWhile (=='_')} v ++class Channel c where+ basefee :: c -> Msat+ ppmrate :: c -> Int + cDelay :: c -> Int+ cDest :: c -> Text+ cSource :: c -> Text+ shortid :: c -> Text + +createRoute :: (Channel c) => Msat -> [c] -> [Route]+createRoute a c = foldr (addHop a) [] $ pairUp c+ where+ pairUp :: [c] -> [(c,c)]+ pairUp [] = []+ pairUp (a:[]) = [(a,a)]+ pairUp (a:b) = (a,head b) : pairUp b++ -- addHop :: Msat -> (Channel, Channel) -> [Route] -> [Route]+ addHop a (cp, c) r = Route+ (cDest cp)+ (shortid cp)+ (liftA2 getDirect cSource cDest cp)+ (getAmount a c r)+ (getDelay c r)+ "tlv"+ : r++ -- getDirect :: String -> String -> Int+ getDirect a b = if readHex (show a) < readHex (show b) then 0 else 1++ -- getDelay :: Channel -> [Route] -> Int+ getDelay e [] = 9+ getDelay e (r:_) = __delay r + cDelay e+ + getAmount :: (Channel c) => Msat -> c -> [Route] -> Msat+ getAmount a e [] = a+ getAmount a e r =+ let mil = 1000000 :: Integer+ b = basefee e+ p = ppmrate e+ num = (mil * toInteger nextAmount * toInteger p)+ denum = mil*mil+ ppmfee = fromInteger $ div num denum -- inaccurate?>+ nextAmount = maximum $ map __amount_msat r+ in sum [ nextAmount, b, ppmfee ]++
+ examples/routes/Search.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE+ LambdaCase, + DuplicateRecordFields, + TypeSynonymInstances, + FlexibleInstances+#-} +module Search (+ Search+ , Way+ , evalTo+ , evalRefs+ , evalChans+ , results'+ , results+ , search+ , hydrate+ , increment+ , chop+ , getNodeInt+ )where +import Numeric +import Data.Char+import System.IO +import Data.Lightning +import Data.Graph.Inductive.Graph+import Data.Graph.Inductive.PatriciaTree+import Control.Monad.Reader+import Control.Monad.State+import Control.Concurrent+import Control.Concurrent.Chan+import qualified Data.Sequence as Q+import Data.Sequence (Seq(..),(<|),(|>),(><)) +import Data.Foldable +import Route ++type Search b = Reader (Gr () b, Node, Node) -- from / to+type Way b = Q.Seq b +type Ref = Q.Seq Int +type Deref b = (Ref, Way b) +type Eebe b = Either (Deref b) (Way b)++evalTo :: Channel b => Gr () b -> Node -> Node -> Int -> [Ref]+evalTo = evalBy resLength++evalChans :: Channel b => Gr () b -> Node -> Node -> Int -> [Way b]+evalChans = evalBy results'+evalRefs :: Channel b => Gr () b -> Node -> Node -> Int -> [Ref]+evalRefs = evalBy results+evalBy s g n m l = (`runReader` (g, n, m)) . (`evalStateT` (Empty, [])) $ s l ++results' :: Channel b => Int -> StateT (Ref, [Way b]) (Search b) [Way b] +results' x = do + (r , c) <- get+ (w, r') <- lift $ search r+ put (increment.chop $ r', w : c) + if x > length c + then results' x + else return c++results :: Channel b => Int -> StateT (Ref, [Ref]) (Search b) [Ref] +results x = do + (r , c) <- get+ (_, r') <- lift $ search r+ put (increment.chop $ r', r' : c) + if x > length c + then results x + else return c+++resLength :: Channel b => Int -> StateT (Ref, [Ref]) (Search b) [Ref] +resLength j = do + (r, c) <- get+ (_, r') <- lift $ search r+ put (increment.chop $ r', r':c) + if j >= length r' + then resLength j+ else return c++search :: Channel b => Ref -> Search b (Way b, Ref) +search r = (hydrate r) >>= \case+ (Left x) -> do + search $ nextr r x+ (Right y) -> do+ (fin (r, y) ) >>= \case + Nothing -> search $ increment r+ (Just z) -> lift $ pure z ++fin :: Channel b => (Ref, Way b) -> Search b (Maybe (Way b, Ref)) +fin (r, w) = do + (g, n, v) <- ask + oo <- outgoing w + let {+ f = dropWhile (not.(== v).fst) oo;+ lo = length oo; + la = length f ;+ rr = lo - la + }+ case f of + [] -> pure Nothing + (x:_) -> pure $ Just ( w |> snd x, r |> rr) ++nextr :: Channel b => Ref -> Deref b -> Ref +nextr r (r', c) + | z == Q.length r = extend.increment.chop $ r+ | z == 0 = extendTo (Q.length r + 1) Empty+ | otherwise = extendTo (Q.length r) $ increment $ Q.take z r+ where z = Q.length c++hydrate :: Channel b => Ref -> (Search b) (Eebe b)+hydrate r = evalStateT h (r, Empty) + +h :: Channel b => StateT (Deref b) (Search b) (Eebe b)+h = get >>= \case + (Empty, c) -> return $ Right c+ dr@(y :<| t, c) -> do + (g, n, v) <- lift ask + oo <- lift $ outgoing c+ case oo !? y of + Nothing -> pure $ Left dr + Just (m, x) -> put (t, c |> x) >> h+ +outgoing :: Channel b => Way b -> Search b [(Node, b)] +outgoing Empty = do + (g, n, v) <- ask + pure $ lsuc g n+outgoing (c :|> d) = do + (g, n, v) <- ask+ pure $ lsuc g (toNode d) ++increment :: Ref -> Ref+increment Empty = Q.singleton 0+increment (r :|> x) = r |> (x + 1) +extend :: Ref -> Ref+extend r = r |> 0+chop :: Ref -> Ref+chop Empty = Empty +chop (r :|> _) = r+extendTo :: Int -> Ref -> Ref +extendTo x r+ | length r >= x = r + | otherwise = extendTo x $ extend r+ +toNode :: Channel c => c -> Node+toNode = getNodeInt.cDest +getNodeInt s = case readHex.filter isHexDigit $ show s of+ ([]) -> 0+ (x:_)-> fst x++(!?) :: (Foldable t, Eq b, Num b) => t a -> b -> Maybe a+(!?) = foldr voo (const Nothing)+ where + voo :: (Eq b, Num b) => a -> (b -> Maybe a) -> b -> Maybe a+ voo x r k + | k == 0 = Just x+ | otherwise = r $ k-1
+ examples/wallet/Main.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE+ OverloadedStrings + , DeriveGeneric + , DuplicateRecordFields+ , ViewPatterns #-}++module Main where ++import Data.Lightning +import Data.Lightning.Generic +import Control.Plugin +import Control.Client +import Control.Conduit +import Data.Aeson+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.IO.Class +import GHC.Generics +import Data.Text (Text)+import qualified Data.Text as T +import Fmt +import Data.Text.Format.Numbers +import Data.List +import Data.Maybe++main = plugin manifest start app ++manifest = object [+ "dynamic" .= True+ , "options" .= ([] :: [Option])+ , "rpcmethods" .= [+ RpcMethod "wallet" "" "print summary info" Nothing False + ]+ ]++start :: PluginInit ()+start _ = pure () ++app :: PluginApp () +app (Just i, "wallet", _) = do + (h, _) <- ask + Just (Res xd _) <- liftIO $ lightningCli h (Command "listfunds" fundFilter fundParams) + case fromJSON xd :: Result MyFundy of+ (Success x) -> respond (summarizeFunds x) i + _ -> release i ++summarizeFunds :: MyFundy -> Value+summarizeFunds myf = object [+ "withdraw" .= (prettyI (Just ',') . (`div` 1000) . outSum . outputs $ myf)+ , "pay" .= (prettyI (Just ',') (payable $ channels myf))+ , "invoice" .= (prettyI (Just ',') $ recable (channels myf))+ , "xchan" .= (map showChan $ sort $ channels myf)+ ]+ where outSum :: [Outy] -> Msat + outSum = sum . map __amount_msat . filter ((=="confirmed") . __status) + payable = sum . map our_amount_msat . filter ((=="CHANNELD_NORMAL") . _state)+ recable = sum . map recable' . filter ((=="CHANNELD_NORMAL")._state) + recable' a = _amount_msat a - our_amount_msat a+ showChan :: Chany -> Text+ showChan (Chany a o s n i) = "" + +| (build $ T.justifyLeft 13 ' ' <$> i ) + +| " |" + +| (build $ evalState xd (o, ""))+ +| "#"+ +| (build $ evalState xd (a-o, "")) + +| "| " + +| (build $ T.take 6 n)+ +| " "+ +| if s /= "CHANNELD_NORMAL" then build s else "" + + xd :: State (Msat, Text) Text + xd = do + (m, t) <- get + put (m - 1000000000, T.append t "-" ) + if m > 0 && T.length t < 11 then xd else pure t++fundFilter = object [+ "outputs" .= [outputFields]+ , "channels" .= [chanFields]+ ]+outputFields = object [+ "amount_msat" .= True+ , "status" .= True + ]+chanFields = object [+ "amount_msat" .= True+ , "our_amount_msat" .= True+ , "state" .= True+ , "peer_id" .= True+ , "short_channel_id" .= True+ ]++data MyFundy = MyFundy {+ outputs :: [Outy]+ , channels :: [Chany] + } deriving Generic +instance FromJSON MyFundy++data Outy = Outy {+ __amount_msat :: Msat + , __status :: Text + } deriving Generic +instance FromJSON Outy where + parseJSON = defaultParse++data Chany = Chany {+ _amount_msat :: Msat+ , our_amount_msat :: Msat + , _state :: Text+ , peer_id :: Text + , _short_channel_id :: Maybe Text + } deriving (Eq, Generic) +instance FromJSON Chany where + parseJSON = defaultParse+instance Ord Chany where + compare x y = compare (_short_channel_id x) (_short_channel_id y)++ +fundParams = object [ ]
+ src/Control/Client.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE+ LambdaCase+ , OverloadedStrings+ , DeriveGeneric+ , DeriveAnyClass+ , GeneralizedNewtypeDeriving+ #-}++module Control.Client (+ lightningCli,+ Command(..),+ PartialCommand+ ) + where ++import Control.Plugin+import Control.Conduit+import Data.Lightning +import Data.ByteString.Lazy as L +import System.IO+import System.IO.Unsafe+import Data.IORef+import Network.Socket +import Data.Conduit hiding (connect) +import Data.Conduit.Combinators hiding (stdout, stderr, stdin) +import Data.Aeson+import Data.Text++type Cln a = IO (Maybe (ParseResult (Res a)))+type PartialCommand = Id -> Command ++{-# NOINLINE idref #-} +idref :: IORef Int+idref = unsafePerformIO $ newIORef 1++data Command = Command { + method :: Text+ , reqFilter :: Value+ -- ^ filter specifies which data fields you want to be retured.+ , params :: Value + , ____id :: Value + } deriving (Show) ++instance ToJSON Command where + toJSON (Command m f p i) = + object [ "jsonrpc" .= ("2.0" :: Text)+ , "id" .= i+ , "filter" .= toJSON f+ , "method" .= m + , "params" .= toJSON p+ ]++-- | Function to interface with lightning-rpc commands. First argument is a Handle to rpcfile from the readerT, second is a Command withholding Id which will automatically increment. +lightningCli :: Handle -> PartialCommand -> IO (Maybe (Res Value))+lightningCli h v = do + i <- atomicModifyIORef idref $ (\x -> (x,x)).(+1)+ L.hPutStr h . encode $ v (toJSON i) + runConduit $ sourceHandle h .| inConduit .| await >>= \case + (Just (Correct x)) -> pure $ Just x+ _ -> pure Nothing +
+ src/Control/Conduit.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE+ LambdaCase+ , FlexibleInstances + , FlexibleContexts+ , DeriveGeneric + , OverloadedStrings + #-}++module Control.Conduit (+ inConduit, + ParseResult(..), + Res(..), + Req(..) + ) where ++import Data.Lightning +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 ++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 }+ | Derp {+ 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"+ Derp <$> 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 (Derp msg i) = object [ + "jsonrpc" .= ("2.0" :: Text),+ "error" .= object ["message" .= msg],+ "id" .= i ]+
+ src/Control/Plugin.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE + LambdaCase+ , OverloadedStrings + , BlockArguments+ , RecordWildCards+ , DuplicateRecordFields+ , DeriveAnyClass+ #-}++module Control.Plugin (+ plugin, + release, + respond, + PluginApp, + PluginMonad,+ PluginInit,+ PluginReq, + PlugInfo+ ) where ++import Data.Lightning+import Control.Conduit+import Control.Exception+import System.IO+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++-- | Function called on every event subscribed to in the manifest.+type PluginApp a = PluginReq -> PluginMonad a+type PluginReq = (Maybe Id, Method, Params)++-- | Plugin stack contains ReaderT (ask - rpc handle & config), stateT (get/put - polymorphic state) and conduitT (yield - data exchange to core lightning.)+type PluginMonad a = ConduitT + (Either (Res Value) PluginReq) + (Res Value) + (ReaderT PlugInfo (StateT a IO))+ () ++-- | Handle connected to lightning-rpc file (use with Control.Client) & configuration object. +type PlugInfo = (Handle, Init)++-- | Function called on initialization, returned value is the initial state.+type PluginInit a = PlugInfo -> IO a++data StartErr = ExpectManifest | ExpectInit deriving (Show, Exception) ++-- | Create main executable that can be installed as core lightning plugin. +plugin :: Value -> PluginInit 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+ s' <- liftIO $ start (h, xi)+ _ <- liftIO.forkIO $ runPlugin (h, xi) s' app + yield $ Res continue i+ _ -> throw ExpectInit + where getRpcPath conf = lightning5dir conf <> "/" <> rpc5file conf+ threadDelay maxBound++runPlugin :: PlugInfo -> s -> PluginApp s -> IO () +runPlugin re st = (`evalStateT` st) . (`runReaderT` re) . forever . runConduit . runner+ where + runner app = + sourceHandle stdin .| inConduit .| entry .| appInsert app .| exit .| sinkHandle stdout ++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 $ Derp ("Request Error"::Text) Nothing + ParseErr -> yield $ Left $ Derp ("Parser Err"::Text) Nothing )++appInsert :: PluginApp a -> PluginMonad a+appInsert app = await >>= maybe mempty \case + Left er -> yield er + Right pr -> app pr ++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. Hooks delay default node behaviour. +release :: Id -> PluginMonad a+release = yield . Res continue++-- | Respond with arbitrary Value, custom rpc hooks will pass back through to terminal.+respond :: Value -> Id -> PluginMonad a+respond = (yield .) . Res+++continue :: Value +continue = object ["result" .= ("continue" :: Text)]
+ src/Data/Lightning.hs view
@@ -0,0 +1,14 @@+{-# 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 view
@@ -0,0 +1,21 @@++{-# 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 view
@@ -0,0 +1,218 @@+{-# 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 + , amount_msat :: Msat+ } 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 view
@@ -0,0 +1,56 @@+{-# 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 view
@@ -0,0 +1,188 @@+{-# 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 :: SPFData+ } deriving Generic +instance FromJSON SendPayFailure where + parseJSON = singleField "sendpay_failure"++data SPFData = SPFData {+ _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 SPFData 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 view
@@ -0,0 +1,12 @@+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++-- ...
+ test/Spec.hs view
@@ -0,0 +1,62 @@++{-# LANGUAGE + OverloadedStrings + , FlexibleContexts +#-} ++module Tally (main) where+++import Data.Lightning +import Control.Conduit +import Control.Plugin +import Control.Client (getinfo) +import Data.Aeson+import Data.Text+import Data.Conduit +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Control.Monad.Trans.State.Lazy +import Control.Monad.Reader++-- plugin function to build core lightning plugin+main :: IO () +main = plugin manifest appState app++-- define plugin options: +manifest :: Value +manifest = object [+ "dynamic" .= True+ , "subscriptions" .= (["channel_opened"] :: [Text] ) + , "options" .= ([]::[Option])+ , "rpcmethods" .= ([ RpcMethod "firethemissiles" "" "" Nothing False ]::[RpcMethod]) + , "hooks" .= ([]::[Hook])+ , "featurebits" .= object [ ]+ , "notifications" .= ([]::[Notification])+ ] ++-- can pattern match on tuple of data from plugin+app :: PluginApp () +app (Nothing, "channel_opened", v) = do+ -- + -- -- state any type+ -- tea <- lift.lift $ get + -- -- reader Handle connected to cln-rpc+ -- rpc <- lift ask+ -- + -- liftIO $ getinfo rpc+ pure () ++-- if id then core lightning is expecting a response, use yield from conduit +app (Just i, "firethemissiles", v) = do+ -- if handling hook allow default behavior to continue: + yield $ Res (object ["result" .= ("continue" :: Text)]) i+++app _ = pure () +-- polymorphic +appState = () ++ ++