{-# LANGUAGE 
      LambdaCase
    , OverloadedStrings 
    , BlockArguments
    , RecordWildCards
    , DuplicateRecordFields
    , DeriveAnyClass
    #-}

module Control.Plugin (
    plugin, 
    release, 
    reject,
    respond, 
    PluginApp, 
    PluginMonad,
    InitMonad,
    PluginReq, 
    PlugInfo
    ) 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 PlugInfo IO a

-- | Plugin stack contains ReaderT (ask - rpc handle & config), stateT (get/put - polymorphic state) and conduitT (yield - data exchange to core lightning.)
type PluginMonad a b = ConduitT 
    (Either (Res Value) PluginReq) 
    (Res Value) 
    (ReaderT PlugInfo (StateT a IO))
    b

-- | Handle connected to lightning-rpc file (use with Control.Client) & configuration object.  
type PlugInfo = (Handle, 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) 

-- | Create main executable that can be installed as core lightning plugin. 
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, Method
"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, Method
"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
$ Method -> IO Handle
getrpc forall a b. (a -> b) -> a -> b
$ InitConfig -> Method
getRpcPath InitConfig
configuration
                s
s' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. PlugInfo -> InitMonad a -> IO a
runStartup (Handle
h, Init
xi) 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. PlugInfo -> s -> PluginApp s -> IO ()
runPlugin (Handle
h, Init
xi) s
s' PluginApp s
app 
                forall (m :: * -> *) i.
Monad m =>
Value -> ConduitT i (Res Value) m ()
release Value
i
            Result Init
_ -> forall a e. Exception e => e -> a
throw StartErr
ExpectInit 
            where getRpcPath :: InitConfig -> Method
getRpcPath InitConfig
conf = InitConfig -> Method
lightning5dir InitConfig
conf forall a. Semigroup a => a -> a -> a
<> Method
"/" forall a. Semigroup a => a -> a -> a
<> InitConfig -> Method
rpc5file InitConfig
conf
        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 :: PlugInfo -> InitMonad a -> IO a 
runStartup :: forall a. PlugInfo -> InitMonad a -> IO a
runStartup PlugInfo
re = (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` PlugInfo
re)  

runPlugin :: PlugInfo -> s -> PluginApp s -> IO () 
runPlugin :: forall s. PlugInfo -> s -> PluginApp s -> IO ()
runPlugin PlugInfo
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` PlugInfo
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} {c}.
PluginApp a -> ConduitT a c (ReaderT PlugInfo (StateT a IO)) ()
runner
    where
    runner :: PluginApp a -> ConduitT a c (ReaderT PlugInfo (StateT a IO)) ()
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 -> PluginMonad a ()
appInsert PluginApp a
app 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 

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 -> Method
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. Method -> Maybe Value -> Res a
ErrRes (Method
"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. Method -> Maybe Value -> Res a
ErrRes (Method
"Parser Err"::Text) forall a. Maybe a
Nothing )

appInsert :: PluginApp a -> PluginMonad a ()
appInsert :: forall a. PluginApp a -> 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
er -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Res Value
er  
    Right PluginReq
pr -> PluginApp a
app PluginReq
pr 

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 :: Method -> IO Handle
getrpc Method
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
$ Method -> String
unpack Method
d
    Socket -> IOMode -> IO Handle
socketToHandle Socket
soc IOMode
ReadWriteMode

-- | Helper function to allow node to continue default behaviour. 
release :: Monad m => Id -> ConduitT i (Res Value) m () 
release :: forall (m :: * -> *) i.
Monad m =>
Value -> ConduitT i (Res Value) m ()
release = 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
.= (Method
"continue" :: Text)])

-- | Helper function to prevent node default behaviour. 
reject :: Monad m => Id -> ConduitT i (Res Value) m ()  
reject :: forall (m :: * -> *) i.
Monad m =>
Value -> ConduitT i (Res Value) m ()
reject = 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
.= (Method
"reject" :: Text)])

-- | Respond with arbitrary Value, custom rpc hooks will pass back through to terminal.
respond :: Value -> Id -> PluginMonad a ()
respond :: forall a. Value -> Value -> PluginMonad a ()
respond = (forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Value -> Res a
Res