Plugin.hs

{-# 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