{-# 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
type PluginApp a = PluginReq -> PluginMonad a ()
type PluginReq = (Maybe Id, Method, Params)
type InitMonad a = ReaderT Plug IO a
type PluginMonad a = ReaderT Plug (StateT a IO)
data Plug = Plug {
Plug -> Handle
rpc :: Handle
, Plug -> Handle
out :: Handle
, Plug -> Init
conf :: Init
}
data StartErr = ExpectManifest | ExpectInit deriving (Int -> StartErr -> ShowS
[StartErr] -> ShowS
StartErr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StartErr] -> ShowS
$cshowList :: [StartErr] -> ShowS
show :: StartErr -> String
$cshow :: StartErr -> String
showsPrec :: Int -> StartErr -> ShowS
$cshowsPrec :: Int -> StartErr -> ShowS
Show, Show StartErr
Typeable StartErr
SomeException -> Maybe StartErr
StartErr -> String
StartErr -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: StartErr -> String
$cdisplayException :: StartErr -> String
fromException :: SomeException -> Maybe StartErr
$cfromException :: SomeException -> Maybe StartErr
toException :: StartErr -> SomeException
$ctoException :: StartErr -> SomeException
Exception)
plugin :: Value -> InitMonad s -> PluginApp s -> IO ()
plugin :: forall s. Value -> InitMonad s -> PluginApp s -> IO ()
plugin Value
manifest InitMonad s
start PluginApp s
app = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> BufferMode -> IO ()
`hSetBuffering` BufferMode
LineBuffering) [Handle
stdin,Handle
stdout]
ConduitT (Either (Res Value) PluginReq) (Res Value) IO () -> IO ()
runOnce forall a b. (a -> b) -> a -> b
$ 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 (Right (Just Value
i, Text
"getmanifest", Value
_))) -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ forall a. a -> Value -> Res a
Res Value
manifest Value
i
Maybe (Either (Res Value) PluginReq)
_ -> forall a e. Exception e => e -> a
throw StartErr
ExpectManifest
ConduitT (Either (Res Value) PluginReq) (Res Value) IO () -> IO ()
runOnce forall a b. (a -> b) -> a -> b
$ 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 (Right (Just Value
i, Text
"init", Value
v))) -> case forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
Success xi :: Init
xi@(Init{Object
InitConfig
$sel:configuration:Init :: Init -> InitConfig
$sel:options:Init :: Init -> Object
configuration :: InitConfig
options :: Object
..}) -> do
Handle
h <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO Handle
getrpc forall a b. (a -> b) -> a -> b
$ InitConfig -> Text
getRpcPath InitConfig
configuration
let plug :: Plug
plug = (Handle -> Handle -> Init -> Plug
Plug Handle
h Handle
stdout Init
xi)
s
s' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Plug -> InitMonad a -> IO a
runStartup Plug
plug InitMonad s
start
ThreadId
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall b c a. (b -> c) -> (a -> b) -> a -> c
.IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall s. Plug -> s -> PluginApp s -> IO ()
runPlugin Plug
plug s
s' PluginApp s
app
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Value -> Res a
Res ([Pair] -> Value
object [Key
"result" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"continue" :: Text)]) forall a b. (a -> b) -> a -> b
$ Value
i
where
Result Init
_ -> forall a e. Exception e => e -> a
throw StartErr
ExpectInit
Maybe (Either (Res Value) PluginReq)
_ -> forall a e. Exception e => e -> a
throw StartErr
ExpectInit
Int -> IO ()
threadDelay forall a. Bounded a => a
maxBound
runStartup :: Plug -> InitMonad a -> IO a
runStartup :: forall a. Plug -> InitMonad a -> IO a
runStartup Plug
re = (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Plug
re)
runPlugin :: Plug -> s -> PluginApp s -> IO ()
runPlugin :: forall s. Plug -> s -> PluginApp s -> IO ()
runPlugin Plug
re s
st = (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` s
st) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Plug
re) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}. PluginApp a -> ConduitT a Void (PluginMonad a) ()
runner
where
runner :: PluginApp a -> ConduitT a Void (PluginMonad a) ()
runner PluginApp a
app = forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
stdin 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 (n :: * -> *).
Monad n =>
ConduitT
(ParseResult (Req Value)) (Either (Res Value) PluginReq) n ()
entry forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall a.
PluginApp a
-> ConduitT (Either (Res Value) PluginReq) Void (PluginMonad a) ()
appInsert PluginApp a
app
runOnce :: ConduitT (Either (Res Value) PluginReq) (Res Value) IO () -> IO ()
runOnce :: ConduitT (Either (Res Value) PluginReq) (Res Value) IO () -> IO ()
runOnce = forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduitforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall {m :: * -> *} {a} {c}.
MonadIO m =>
ConduitT (Either (Res Value) PluginReq) (Res Value) m ()
-> ConduitT a c m ()
runner
where
runner :: ConduitT (Either (Res Value) PluginReq) (Res Value) m ()
-> ConduitT a c m ()
runner ConduitT (Either (Res Value) PluginReq) (Res Value) m ()
d = forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
stdin 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 (n :: * -> *).
Monad n =>
ConduitT
(ParseResult (Req Value)) (Either (Res Value) PluginReq) n ()
entry forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT (Either (Res Value) PluginReq) (Res Value) m ()
d forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (n :: * -> *).
Monad n =>
ConduitT (Res Value) ByteString n ()
exit forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
stdout
entry :: (Monad n) => ConduitT (ParseResult (Req Value)) (Either (Res Value) PluginReq) n ()
entry :: forall (n :: * -> *).
Monad n =>
ConduitT
(ParseResult (Req Value)) (Either (Res Value) PluginReq) n ()
entry = 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
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (\case
Correct Req Value
v -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall x. Req x -> Maybe Value
getReqId Req Value
v, forall x. Req x -> Text
getMethod Req Value
v, forall x. Req x -> x
getParams Req Value
v)
ParseResult (Req Value)
InvalidReq -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Text -> Maybe Value -> Res a
ErrRes (Text
"Request Error"::Text) forall a. Maybe a
Nothing
ParseResult (Req Value)
ParseErr -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Text -> Maybe Value -> Res a
ErrRes (Text
"Parser Err"::Text) forall a. Maybe a
Nothing )
appInsert :: PluginApp a -> ConduitT (Either (Res Value) PluginReq) Void (PluginMonad a) ()
appInsert :: forall a.
PluginApp a
-> ConduitT (Either (Res Value) PluginReq) Void (PluginMonad a) ()
appInsert PluginApp a
app = 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
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty \case
Left Res Value
failed -> do
Plug Handle
_ Handle
out Init
_ <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Res Value -> IO ()
runRes Handle
out Res Value
failed
Right PluginReq
req -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PluginApp a
app PluginReq
req) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
runRes :: Handle -> Res Value -> IO ()
runRes :: Handle -> Res Value -> IO ()
runRes Handle
o Res Value
r = forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Res Value
r) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (n :: * -> *).
Monad n =>
ConduitT (Res Value) ByteString n ()
exit forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
o
exit :: (Monad n) => ConduitT (Res Value) S.ByteString n ()
exit :: forall (n :: * -> *).
Monad n =>
ConduitT (Res Value) ByteString n ()
exit = 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
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yieldforall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode)
getrpc :: Text -> IO Handle
getrpc :: Text -> IO Handle
getrpc Text
d = do
Socket
soc <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
0
Socket -> SockAddr -> IO ()
N.connect Socket
soc forall a b. (a -> b) -> a -> b
$ String -> SockAddr
SockAddrUnix forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
d
Socket -> IOMode -> IO Handle
socketToHandle Socket
soc IOMode
ReadWriteMode
release :: Id -> PluginMonad a ()
release :: forall a. Value -> PluginMonad a ()
release Value
i = do
Plug Handle
_ Handle
out Init
_ <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Res Value -> IO ()
runRes Handle
out forall a b. (a -> b) -> a -> b
$ forall a. a -> Value -> Res a
Res ([Pair] -> Value
object [Key
"result" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"continue" :: Text)]) Value
i
reject :: Id -> PluginMonad a ()
reject :: forall a. Value -> PluginMonad a ()
reject Value
i = do
Plug Handle
_ Handle
out Init
_ <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Res Value -> IO ()
runRes Handle
out forall a b. (a -> b) -> a -> b
$ forall a. a -> Value -> Res a
Res ([Pair] -> Value
object [Key
"result" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"reject" :: Text)]) Value
i
respond :: Value -> Id -> PluginMonad a ()
respond :: forall a. Value -> Value -> PluginMonad a ()
respond Value
v Value
i = do
Plug Handle
_ Handle
out Init
_ <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Res Value -> IO ()
runRes Handle
out forall a b. (a -> b) -> a -> b
$ forall a. a -> Value -> Res a
Res Value
v Value
i
getRpcPath :: InitConfig -> Text
getRpcPath :: InitConfig -> Text
getRpcPath InitConfig
conf = InitConfig -> Text
lightning5dir InitConfig
conf forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> InitConfig -> Text
rpc5file InitConfig
conf