Connect.hs

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

module Plugin.Connect (
    plugin, 
    release, 
    reject,
    respond, 
    notify,
    Notify(..),
    PluginApp, 
    PluginMonad,
    InitMonad,
    Req(..), 
    Plug(..), 
    Init(..)
    ) where 

import Plugin.Internal.Conduit
import Plugin.Hooks
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
import Control.Concurrent.STM.TVar

type PluginApp a = Req -> PluginMonad a ()
type InitMonad a = ReaderT Plug IO a
type PluginMonad a = ReaderT Plug (StateT a IO)

-- | Handles to lightning-rpc and plugin, configuration object and global id.  
data Plug = Plug {
      rpc :: Handle
    , out :: Handle
    , conf :: Init
    , plugId :: TVar Int
    }

data StartErr = ExpectManifest | ExpectInit deriving (Show, Exception) 

-- | Create executable that can be installed as core lightning plugin. 
-- 1st arg is the manifest that configures the interface, 2nd arg is a function
-- that runs on startup and initializes/defines app 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 (Req (Just i) "getmanifest" _))) -> yield $ Res manifest i 
        _ -> throw ExpectManifest
    runOnce $ await >>= \case      
        (Just (Right (Req (Just i) "init" v))) -> case fromJSON v of 
            Success xi@(Init{..}) -> do 
                h  <- liftIO $ getrpc $ getRpcPath configuration
                tv <- liftIO $ newTVarIO 1
                let plug = Plug h stdout xi tv 
                s' <- liftIO $ runReaderT start plug
                _ <- liftIO . forkIO $ runPlugin plug s' app 
                yield . Res (object ["result" .= ("continue" :: Text)]) $ i 
            _ -> throw ExpectInit 
        _ -> throw ExpectInit 
    threadDelay maxBound

-- | allow node to continue default behaviour 
release :: Int -> PluginMonad a ()
release i = do 
    o <- asks out
    liftIO . runRes o $ Res (object ["result" .= ("continue" :: Text)]) i

-- | prevent node default behaviour 
reject :: Int -> PluginMonad a ()
reject i = do 
    o <- asks out
    liftIO . runRes o $ Res (object ["result" .= ("reject" :: Text)]) i

-- | Respond with arbitrary Value, custom rpc hooks will pass through
respond :: Value -> Int -> PluginMonad a ()
respond v i = do 
    o <- asks out
    liftIO $ runRes o $ Res v i 

-- | Produce a notification that can be subscribed to by other plugins. 
notify :: (MonadReader Plug m, MonadIO m) => Notify -> m ()
notify n = do 
    h <- asks out
    liftIO $ runRes h n

runPlugin :: Plug -> s -> PluginApp s -> IO () 
runPlugin re st = (`evalStateT` st) . (`runReaderT` re) . runConduit . runner
    where
    runner app = sourceHandle stdin .| inConduit .| entry .| appInsert app
    appInsert :: PluginApp a -> ConduitT (Either Res Req) Void (PluginMonad a) () 
    appInsert app = awaitForever \case  
        Left failed -> do
            out <- asks out
            liftIO $ runRes out failed 
        Right req -> void (lift (app req))

runOnce :: ConduitT (Either Res Req) Res IO () -> IO () 
runOnce = runConduit.runner
    where 
    runner d = sourceHandle stdin .| inConduit .| entry .| d .| exit .| sinkHandle stdout
    
runRes :: (ToJSON v) => Handle -> v -> IO ()
runRes o r = runConduit $ yield r .| exit .| sinkHandle o

entry :: (Monad n) => ConduitT (ParseResult (Req)) (Either Res Req) n () 
entry = awaitForever  (\case  
    Correct v -> yield . Right $ v -- Req (getReqId v) (getMethod v), getParams v) 
    InvalidReq -> yield $ Left $ ErrRes ("Request Error"::Text) 0 Nothing 0 --Nothing  
    ParseErr -> yield $ Left $ ErrRes ("Request Error"::Text) 0 Nothing 0 --Nothing  
    )
    
exit :: (Monad n, ToJSON v) => ConduitT v S.ByteString n () 
exit = await >>= maybe mempty (yield. L.toStrict . encode) 

data Notify = Notify {
      method :: Text
    , params :: Value
    } deriving (Show) 
instance ToJSON Notify where
    toJSON (Notify m p) = 
        object [ "jsonrpc" .= ("2.0" :: Text)
               , "method" .= m
               , "params" .= p
               ] 

getrpc :: Text -> IO Handle
getrpc d = do 
    soc <- socket AF_UNIX Stream 0
    N.connect soc $ SockAddrUnix $ unpack d
    socketToHandle soc ReadWriteMode

getRpcPath :: InitConfig -> Text
getRpcPath conf = lightning5dir conf <> "/" <> rpc5file conf