--
-- NOTE : requestBody is deprecated
-- but we need it.
--
{-# OPTIONS_GHC -Wno-deprecations #-}

module BtcLsp.Grpc.Server.LowLevel
  ( GSEnv (..),
    runServer,
    serverApp,
  )
where

import BtcLsp.Grpc.Data
import qualified BtcLsp.Grpc.Sig as Sig
import BtcLsp.Import.External
import Control.Concurrent (modifyMVar)
import Data.Aeson (withObject, (.:), (.:?))
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as BSL
import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE
import Network.GRPC.HTTP2.Encoding (gzip)
import Network.GRPC.Server
import Network.HTTP2.Server hiding (Request)
import Network.Wai
import Network.Wai.Handler.Warp as Warp
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettingsMemory)

data GSEnv = GSEnv
  { GSEnv -> Int
gsEnvPort :: Int,
    GSEnv -> Bool
gsEnvSigVerify :: Bool,
    GSEnv -> SigHeaderName
gsEnvSigHeaderName :: SigHeaderName,
    GSEnv -> Encryption
gsEnvEncryption :: Encryption,
    GSEnv -> Maybe (TlsData 'Server)
gsEnvTls :: Maybe (TlsData 'Server),
    GSEnv -> Text -> IO ()
gsEnvLogger :: Text -> IO (),
    GSEnv -> MsgToSign -> IO (Maybe LndSig)
gsEnvSigner :: Sig.MsgToSign -> IO (Maybe Sig.LndSig)
  }
  deriving stock ((forall x. GSEnv -> Rep GSEnv x)
-> (forall x. Rep GSEnv x -> GSEnv) -> Generic GSEnv
forall x. Rep GSEnv x -> GSEnv
forall x. GSEnv -> Rep GSEnv x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GSEnv x -> GSEnv
$cfrom :: forall x. GSEnv -> Rep GSEnv x
Generic)

instance FromJSON GSEnv where
  parseJSON :: Value -> Parser GSEnv
parseJSON =
    String -> (Object -> Parser GSEnv) -> Value -> Parser GSEnv
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject
      String
"GSEnv"
      ( \Object
x ->
          Int
-> Bool
-> SigHeaderName
-> Encryption
-> Maybe (TlsData 'Server)
-> (Text -> IO ())
-> (MsgToSign -> IO (Maybe LndSig))
-> GSEnv
GSEnv
            (Int
 -> Bool
 -> SigHeaderName
 -> Encryption
 -> Maybe (TlsData 'Server)
 -> (Text -> IO ())
 -> (MsgToSign -> IO (Maybe LndSig))
 -> GSEnv)
-> Parser Int
-> Parser
     (Bool
      -> SigHeaderName
      -> Encryption
      -> Maybe (TlsData 'Server)
      -> (Text -> IO ())
      -> (MsgToSign -> IO (Maybe LndSig))
      -> GSEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
x Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"port"
            Parser
  (Bool
   -> SigHeaderName
   -> Encryption
   -> Maybe (TlsData 'Server)
   -> (Text -> IO ())
   -> (MsgToSign -> IO (Maybe LndSig))
   -> GSEnv)
-> Parser Bool
-> Parser
     (SigHeaderName
      -> Encryption
      -> Maybe (TlsData 'Server)
      -> (Text -> IO ())
      -> (MsgToSign -> IO (Maybe LndSig))
      -> GSEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
x Object -> Text -> Parser Bool
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"sig_verify"
            Parser
  (SigHeaderName
   -> Encryption
   -> Maybe (TlsData 'Server)
   -> (Text -> IO ())
   -> (MsgToSign -> IO (Maybe LndSig))
   -> GSEnv)
-> Parser SigHeaderName
-> Parser
     (Encryption
      -> Maybe (TlsData 'Server)
      -> (Text -> IO ())
      -> (MsgToSign -> IO (Maybe LndSig))
      -> GSEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
x Object -> Text -> Parser SigHeaderName
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"sig_header_name"
            Parser
  (Encryption
   -> Maybe (TlsData 'Server)
   -> (Text -> IO ())
   -> (MsgToSign -> IO (Maybe LndSig))
   -> GSEnv)
-> Parser Encryption
-> Parser
     (Maybe (TlsData 'Server)
      -> (Text -> IO ()) -> (MsgToSign -> IO (Maybe LndSig)) -> GSEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
x Object -> Text -> Parser Encryption
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"encryption"
            Parser
  (Maybe (TlsData 'Server)
   -> (Text -> IO ()) -> (MsgToSign -> IO (Maybe LndSig)) -> GSEnv)
-> Parser (Maybe (TlsData 'Server))
-> Parser
     ((Text -> IO ()) -> (MsgToSign -> IO (Maybe LndSig)) -> GSEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
x Object -> Text -> Parser (Maybe (TlsData 'Server))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"tls"
            Parser
  ((Text -> IO ()) -> (MsgToSign -> IO (Maybe LndSig)) -> GSEnv)
-> Parser (Text -> IO ())
-> Parser ((MsgToSign -> IO (Maybe LndSig)) -> GSEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> IO ()) -> Parser (Text -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> Text -> IO ()
forall a b. a -> b -> a
const (IO () -> Text -> IO ()) -> IO () -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            Parser ((MsgToSign -> IO (Maybe LndSig)) -> GSEnv)
-> Parser (MsgToSign -> IO (Maybe LndSig)) -> Parser GSEnv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (MsgToSign -> IO (Maybe LndSig))
-> Parser (MsgToSign -> IO (Maybe LndSig))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO (Maybe LndSig) -> MsgToSign -> IO (Maybe LndSig)
forall a b. a -> b -> a
const (IO (Maybe LndSig) -> MsgToSign -> IO (Maybe LndSig))
-> IO (Maybe LndSig) -> MsgToSign -> IO (Maybe LndSig)
forall a b. (a -> b) -> a -> b
$ Maybe LndSig -> IO (Maybe LndSig)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LndSig
forall a. Maybe a
Nothing)
      )

runServer ::
  GSEnv ->
  (GSEnv -> RawRequestBytes -> [ServiceHandler]) ->
  IO ()
runServer :: GSEnv -> (GSEnv -> RawRequestBytes -> [ServiceHandler]) -> IO ()
runServer GSEnv
env GSEnv -> RawRequestBytes -> [ServiceHandler]
handlers =
  case (GSEnv -> Encryption
gsEnvEncryption GSEnv
env, GSEnv -> Maybe (TlsData 'Server)
gsEnvTls GSEnv
env) of
    (Encryption
Encrypted, Just TlsData 'Server
tls) ->
      TLSSettings -> Settings -> Application -> IO ()
runTLS
        ( ByteString -> ByteString -> TLSSettings
tlsSettingsMemory
            (Text -> ByteString
TE.encodeUtf8 (Text -> ByteString)
-> (TlsCert 'Server -> Text) -> TlsCert 'Server -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TlsCert 'Server -> Text
coerce (TlsCert 'Server -> ByteString) -> TlsCert 'Server -> ByteString
forall a b. (a -> b) -> a -> b
$ TlsData 'Server -> TlsCert 'Server
forall (rel :: GRel). TlsData rel -> TlsCert rel
tlsCert TlsData 'Server
tls)
            (Text -> ByteString
TE.encodeUtf8 (Text -> ByteString)
-> (TlsKey 'Server -> Text) -> TlsKey 'Server -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TlsKey 'Server -> Text
coerce (TlsKey 'Server -> ByteString) -> TlsKey 'Server -> ByteString
forall a b. (a -> b) -> a -> b
$ TlsData 'Server -> TlsKey 'Server
forall (rel :: GRel). TlsData rel -> TlsKey rel
tlsKey TlsData 'Server
tls)
        )
        (Int -> Settings -> Settings
setPort Int
port Settings
defaultSettings)
    (Encryption
Encrypted, Maybe (TlsData 'Server)
Nothing) ->
      Text -> Application -> IO ()
forall a. HasCallStack => Text -> a
error (Text -> Application -> IO ()) -> Text -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text
"Fatal error - can not run LSP gRPC endpoint"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" over TLS unless TlsData is provided!"
    (Encryption
UnEncrypted, Maybe (TlsData 'Server)
_) ->
      Int -> Application -> IO ()
Warp.run Int
port
    (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ if GSEnv -> Bool
gsEnvSigVerify GSEnv
env
      then GSEnv -> (GSEnv -> RawRequestBytes -> Application) -> Application
extractBodyBytesMiddleware GSEnv
env ((GSEnv -> RawRequestBytes -> Application) -> Application)
-> (GSEnv -> RawRequestBytes -> Application) -> Application
forall a b. (a -> b) -> a -> b
$ (GSEnv -> RawRequestBytes -> [ServiceHandler])
-> GSEnv -> RawRequestBytes -> Application
serverApp GSEnv -> RawRequestBytes -> [ServiceHandler]
handlers
      else (GSEnv -> RawRequestBytes -> [ServiceHandler])
-> GSEnv -> RawRequestBytes -> Application
serverApp GSEnv -> RawRequestBytes -> [ServiceHandler]
handlers GSEnv
env (ByteString -> RawRequestBytes
RawRequestBytes ByteString
forall a. Monoid a => a
mempty)
  where
    port :: Int
port = GSEnv -> Int
gsEnvPort GSEnv
env

serverApp ::
  (GSEnv -> RawRequestBytes -> [ServiceHandler]) ->
  GSEnv ->
  RawRequestBytes ->
  Application
serverApp :: (GSEnv -> RawRequestBytes -> [ServiceHandler])
-> GSEnv -> RawRequestBytes -> Application
serverApp GSEnv -> RawRequestBytes -> [ServiceHandler]
handlers GSEnv
env RawRequestBytes
body Request
req Response -> IO ResponseReceived
rep = do
  let app :: Application
app = [Compression] -> [ServiceHandler] -> Application
grpcApp [Compression
gzip] ([ServiceHandler] -> Application)
-> [ServiceHandler] -> Application
forall a b. (a -> b) -> a -> b
$ GSEnv -> RawRequestBytes -> [ServiceHandler]
handlers GSEnv
env RawRequestBytes
body
  Application
app Request
req Response -> IO ResponseReceived
middleware
  where
    sigHeaderName :: ByteString
sigHeaderName =
      SigHeaderName -> ByteString
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from (SigHeaderName -> ByteString) -> SigHeaderName -> ByteString
forall a b. (a -> b) -> a -> b
$ GSEnv -> SigHeaderName
gsEnvSigHeaderName GSEnv
env
    middleware :: Response -> IO ResponseReceived
middleware Response
res = do
      Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()
modifyHTTP2Data Request
req ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
-> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe HTTP2Data
http2data0 ->
        let http2data :: HTTP2Data
http2data = HTTP2Data -> Maybe HTTP2Data -> HTTP2Data
forall a. a -> Maybe a -> a
fromMaybe HTTP2Data
defaultHTTP2Data Maybe HTTP2Data
http2data0
         in HTTP2Data -> Maybe HTTP2Data
forall a. a -> Maybe a
Just (HTTP2Data -> Maybe HTTP2Data) -> HTTP2Data -> Maybe HTTP2Data
forall a b. (a -> b) -> a -> b
$
              HTTP2Data
http2data
                { http2dataTrailers :: TrailersMaker
http2dataTrailers =
                    ByteString -> TrailersMaker -> TrailersMaker
trailersMaker
                      ByteString
forall a. Monoid a => a
mempty
                      (HTTP2Data -> TrailersMaker
http2dataTrailers HTTP2Data
http2data)
                }
      Response -> IO ResponseReceived
rep (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
        (ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapResponseHeaders
          (\ResponseHeaders
hs -> (HeaderName
"trailer", ByteString
sigHeaderName) (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hs)
          Response
res
    trailersMaker :: ByteString -> TrailersMaker -> TrailersMaker
trailersMaker ByteString
acc TrailersMaker
oldMaker Maybe ByteString
Nothing = do
      NextTrailersMaker
ts <- TrailersMaker
oldMaker Maybe ByteString
forall a. Maybe a
Nothing
      case NextTrailersMaker
ts of
        Trailers ResponseHeaders
ss -> do
          Maybe LndSig
mSig <- GSEnv -> MsgToSign -> IO (Maybe LndSig)
gsEnvSigner GSEnv
env (MsgToSign -> IO (Maybe LndSig)) -> MsgToSign -> IO (Maybe LndSig)
forall a b. (a -> b) -> a -> b
$ ByteString -> MsgToSign
Sig.MsgToSign ByteString
acc
          NextTrailersMaker -> IO NextTrailersMaker
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NextTrailersMaker -> IO NextTrailersMaker)
-> NextTrailersMaker -> IO NextTrailersMaker
forall a b. (a -> b) -> a -> b
$ case Maybe LndSig
mSig of
            Maybe LndSig
Nothing ->
              NextTrailersMaker
ts
            Just LndSig
sig ->
              ResponseHeaders -> NextTrailersMaker
Trailers (ResponseHeaders -> NextTrailersMaker)
-> ResponseHeaders -> NextTrailersMaker
forall a b. (a -> b) -> a -> b
$
                ( ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk ByteString
sigHeaderName,
                  ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ LndSig -> ByteString
Sig.unLndSig LndSig
sig
                ) (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
:
                ResponseHeaders
ss
        NextTrailersMaker {} ->
          GRPCStatus -> IO NextTrailersMaker
forall e a. Exception e => e -> IO a
throwIO (GRPCStatus -> IO NextTrailersMaker)
-> GRPCStatus -> IO NextTrailersMaker
forall a b. (a -> b) -> a -> b
$
            GRPCStatusCode -> ByteString -> GRPCStatus
GRPCStatus
              GRPCStatusCode
INTERNAL
              ByteString
"UNEXPECTED_NEW_TRAILERS_MAKER"
    trailersMaker ByteString
acc TrailersMaker
oldMaker (Just ByteString
bs) = do
      NextTrailersMaker -> IO NextTrailersMaker
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (NextTrailersMaker -> IO NextTrailersMaker)
-> (TrailersMaker -> NextTrailersMaker)
-> TrailersMaker
-> IO NextTrailersMaker
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrailersMaker -> NextTrailersMaker
NextTrailersMaker
        (TrailersMaker -> IO NextTrailersMaker)
-> TrailersMaker -> IO NextTrailersMaker
forall a b. (a -> b) -> a -> b
$ ByteString -> TrailersMaker -> TrailersMaker
trailersMaker (ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs) TrailersMaker
oldMaker

extractBodyBytesMiddleware ::
  GSEnv ->
  (GSEnv -> RawRequestBytes -> Application) ->
  Application
extractBodyBytesMiddleware :: GSEnv -> (GSEnv -> RawRequestBytes -> Application) -> Application
extractBodyBytesMiddleware GSEnv
env GSEnv -> RawRequestBytes -> Application
app Request
req Response -> IO ResponseReceived
resp = do
  ByteString
body <- ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> IO ByteString
strictRequestBody Request
req
  GSEnv -> Text -> IO ()
gsEnvLogger GSEnv
env (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
    Text
"Server ==> extracted raw request body"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Out a => a -> Text
inspect ByteString
body
  MVar ByteString
body' <- ByteString -> IO (MVar ByteString)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ByteString
body
  GSEnv -> RawRequestBytes -> Application
app GSEnv
env (ByteString -> RawRequestBytes
RawRequestBytes ByteString
body) (MVar ByteString -> Request
req' MVar ByteString
body') Response -> IO ResponseReceived
resp
  where
    requestBody' :: MVar b -> IO b
requestBody' MVar b
mvar =
      MVar b -> (b -> IO (b, b)) -> IO b
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar
        MVar b
mvar
        ( \b
b ->
            (b, b) -> IO (b, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((b, b) -> IO (b, b)) -> (b, b) -> IO (b, b)
forall a b. (a -> b) -> a -> b
$
              if b
b b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
forall a. Monoid a => a
mempty
                then (b
forall a. Monoid a => a
mempty, b
forall a. Monoid a => a
mempty)
                else (b
forall a. Monoid a => a
mempty, b
b)
        )
    req' :: MVar ByteString -> Request
req' MVar ByteString
b =
      Request
req
        { requestBody :: IO ByteString
requestBody = MVar ByteString -> IO ByteString
forall {b}. (Eq b, Monoid b) => MVar b -> IO b
requestBody' MVar ByteString
b
        }