{-# 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 :: PartialCommand -> String
show PartialCommand
x = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ (PartialCommand
x Id
"")
{-# NOINLINE idref #-}
idref :: IORef Int
idref :: IORef Int
idref = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Int
1
data Command = Command {
Command -> Text
method :: Text
, Command -> Maybe Id
reqFilter :: Maybe Value
, Command -> Id
params :: Value
, Command -> Id
____id :: Value
} deriving (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show)
instance ToJSON Command where
toJSON :: Command -> Id
toJSON (Command Text
m Maybe Id
Nothing Id
p Id
i) =
[Pair] -> Id
object [ Key
"jsonrpc" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"2.0" :: Text)
, Key
"id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Id
i
, Key
"method" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
m
, Key
"params" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Id
toJSON Id
p
]
toJSON (Command Text
m (Just Id
f) Id
p Id
i) =
[Pair] -> Id
object [ Key
"jsonrpc" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"2.0" :: Text)
, Key
"id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Id
i
, Key
"filter" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Id
toJSON Id
f
, Key
"method" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
m
, Key
"params" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Id
toJSON Id
p
]
lightningCli :: (MonadReader Plug m, MonadIO m) =>
PartialCommand -> m (Maybe (Res Value))
lightningCli :: forall (m :: * -> *).
(MonadReader Plug m, MonadIO m) =>
PartialCommand -> m (Maybe (Res Id))
lightningCli PartialCommand
v = do
(Plug Handle
h Handle
_ Init
_) <- forall r (m :: * -> *). MonadReader r m => m r
ask
Int
i <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Int
idref forall a b. (a -> b) -> a -> b
$ (\Int
x -> (Int
x,Int
x))forall b c a. (b -> c) -> (a -> b) -> a -> c
.(forall a. Num a => a -> a -> a
+Int
1)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
L.hPutStr Handle
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ PartialCommand
v (forall a. ToJSON a => a -> Id
toJSON Int
i)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (n :: * -> *) a.
(Monad n, FromJSON a) =>
ConduitT ByteString (ParseResult a) n ()
inConduit forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(Just (Correct Res Id
x)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Res Id
x
Maybe (ParseResult (Res Id))
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
lightningCliDebug :: (MonadReader Plug m, MonadIO m) =>
(String -> IO ()) -> PartialCommand -> m (Maybe (Res Value))
lightningCliDebug :: forall (m :: * -> *).
(MonadReader Plug m, MonadIO m) =>
(String -> IO ()) -> PartialCommand -> m (Maybe (Res Id))
lightningCliDebug String -> IO ()
logger PartialCommand
v = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
logger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ PartialCommand
v
Maybe (Res Id)
res <- forall (m :: * -> *).
(MonadReader Plug m, MonadIO m) =>
PartialCommand -> m (Maybe (Res Id))
lightningCli PartialCommand
v
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
logger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Maybe (Res Id)
res
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Res Id)
res