diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,32 @@ +# UTxO RPC Client SDK + +An SDK for clients of the [UTxO RPC](https://utxorpc.org/) specification. + +The goal of this SDK is to reduce boilerplate and increase ease of use of the UTxO RPC spec. This SDK provides convenience methods for creating a connection to a UTxO RPC service and for calling each each method in the UTxO RPC specification. Automated logging of each event in a gRPC call is also supported. + +## How to Use + +Use the SDK through one of the client-creating functions in `Utxorpc.Client`. +1. `simpleUtxorpcClient` -- connect to a service using the bare minimum required information. + 1. See `/quick-start/Main.hs`. +1. `utxorpcClient` -- connect to a service using the provided `UtxorpcInfo`. + 1. See `/example/Main.hs` +1. `UtxorpcClientWith` -- for fine grained control, provide a `GrpcClientConfig` (from `http2-client-grpc`) + +Each of these functions provides a record type hosting functions for each method in UTxO RPC, as well as a method to close the connection. + +## Logging + +This SDK supports automated logging through the `UtxorpcClientLogger` type. It is a record hosting user-defined logging functions for each of the following events: +1. Request sent. +1. Reply received. +1. Server stream data received. +1. Server stream ended. + +For more information, see `Utxorpc.Logged` and `/example`. + +## Examples + +There are two provided examples: +1. `/quick-start` shows the bare minimum required to make a single unary request. +1. `/example` shows a more involved example. `/example/SimpleLogger.hs` is a simple logger implementation that prints human-readable output, and `/example/KatipLogger.hs` is a more involved logger that demonstrates how to use logging functions that run in a transformer stack. diff --git a/example/KatipLogger.hs b/example/KatipLogger.hs new file mode 100644 --- /dev/null +++ b/example/KatipLogger.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module KatipLogger (katipLogger) where + +import Control.Monad.Trans.Reader (ReaderT (..)) +import Data.Aeson as A +import qualified Data.ByteString.Char8 as BS +import Data.UUID (UUID) +import Katip +import Katip.Monadic (KatipContextTState (..), unKatipContextT) +import Utxorpc.Client + +katipLogger :: KatipContextTState -> UtxorpcClientLogger (KatipContextT IO) +katipLogger st = + UtxorpcClientLogger + katipRequestLogger + katipReplyLogger + katipServerStreamLogger + katipServerStreamEndLogger + (\action -> runReaderT (unKatipContextT action) st) + +katipRequestLogger :: RequestLogger (KatipContextT IO) +katipRequestLogger path _client uuid msg = + addContext path uuid Nothing $ + $(logTM) InfoS (showLS msg) + +katipReplyLogger :: ReplyLogger (KatipContextT IO) +katipReplyLogger path _client uuid reply = + addContext path uuid Nothing $ + $(logTM) InfoS (showLS reply) + +katipServerStreamLogger :: ServerStreamLogger (KatipContextT IO) +katipServerStreamLogger path _client (uuid, index) msg = + addContext path uuid (Just index) $ + $(logTM) InfoS (showLS msg) + +katipServerStreamEndLogger :: ServerStreamEndLogger (KatipContextT IO) +katipServerStreamEndLogger path _client (uuid, index) (_headers, _trailers) = + addContext path uuid (Just index) $ + $(logTM) InfoS "End of stream" + +addContext :: (KatipContext m) => BS.ByteString -> UUID -> Maybe Int -> m a -> m a +addContext path uuid index = katipAddContext $ MsgContext path uuid index + +data MsgContext = MsgContext + { _path :: BS.ByteString, + _uuid :: UUID, + _index :: Maybe Int + } + +instance ToJSON MsgContext where + toJSON :: MsgContext -> Value + toJSON MsgContext {_path, _uuid, _index} = + A.object + ( "path" + A..= BS.unpack _path + : "UUID" + A..= show _uuid + : indexContext + ) + where + indexContext = case _index of + Just idx -> ["Message #" A..= show idx] + Nothing -> [] + +instance ToObject MsgContext + +instance LogItem MsgContext where + payloadKeys :: Verbosity -> MsgContext -> PayloadSelection + payloadKeys _ _ = AllKeys diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +module Main (main) where + +import qualified Data.ByteString.Char8 as BS +import Data.ProtoLens (Message (..)) +import Katip +import Katip.Monadic +import KatipLogger (katipLogger) +import Network.GRPC.Client (CIHeaderList) +import Network.HTTP2.Frame (ErrorCode) +import Safe (readMay) +import SimpleLogger (simpleLogger) +import System.Environment (getArgs) +import UnliftIO (MonadIO, bracket, stdout, throwString) +import Utxorpc.Client (UtxorpcClientLogger, UtxorpcInfo (..), utxorpcClient) +import Utxorpc.Types + ( BuildClientImpl (getChainTip), + ServerStreamReply, + SubmitClientImpl (watchMempool), + SyncClientImpl (fetchBlock), + UnaryReply, + UtxorpcClient (buildClient, submitClient, syncClient), + ) +import "http2-client" Network.HTTP2.Client (ClientError, TooMuchConcurrency) + +-- Get server info from args pass to `runUtxo` +main :: IO () +main = + do + args <- getArgs + case parseInfo args of + Left err -> putStrLn err >> putStrLn usageStr + Right serviceInfo -> + if "--katip" `elem` args + then runKatipExample serviceInfo + else runSimpleExample serviceInfo + where + -- Parse command line args for server info + parseInfo :: [String] -> Either String (UtxorpcInfo m) + parseInfo args = + case filter (not . (==) '-' . head) args of + (hostName : portStr : tlsStr : gzipStr : hdrs) -> + UtxorpcInfo hostName + <$> parse ("Invalid port number: " ++ portStr) portStr + <*> parse ("Invalid tlsEnabled arg: " ++ tlsStr) tlsStr + <*> parse ("Invalid useGzip arg: " ++ gzipStr) gzipStr + <*> parsedHeaders hdrs + <*> pure Nothing + invalidArgs -> Left $ "Not enough args (" ++ show (length invalidArgs) ++ " received)." + where + parse msg str = case readMay str of + Nothing -> Left msg + Just val -> Right val + + parsedHeaders :: [String] -> Either String [(BS.ByteString, BS.ByteString)] + parsedHeaders = mapM (mkPair . BS.split ':' . BS.pack) + where + mkPair :: [BS.ByteString] -> Either String (BS.ByteString, BS.ByteString) + mkPair [k, v] = Right (k, v) + mkPair headerStr = + Left $ + "Invalid header key:value pair: " ++ show (BS.unpack <$> headerStr) + + usageStr = "Usage: [--katip] [: [...]]" + +runKatipExample :: UtxorpcInfo m -> IO () +runKatipExample serviceInfo = do + bracket mkLogEnv closeScribes $ \le -> do + eService <- utxorpcClient $ serviceInfo {_logger = Just $ mkKatipLogger le} + case eService of + Left clientErr -> handleClientErr clientErr + Right service -> runUtxo service + where + -- Make KatipLogger. LogEnv required for the `unlift` function + mkKatipLogger :: LogEnv -> UtxorpcClientLogger (KatipContextT IO) + mkKatipLogger le = katipLogger $ KatipContextTState le mempty "example" + + -- Make log environment for KatipLogger + mkLogEnv :: IO LogEnv + mkLogEnv = do + handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2 + le <- initLogEnv "Utxorpc" "development" + registerScribe "stdout" handleScribe defaultScribeSettings le + +runSimpleExample :: UtxorpcInfo m -> IO () +runSimpleExample serviceInfo = do + eService <- utxorpcClient $ serviceInfo {_logger = Just simpleLogger} + case eService of + Left clientErr -> handleClientErr clientErr + Right service -> runUtxo service + +-- Make UTxO RPC calls with empty messages +-- Errors are handled by throwing IO exceptions and exiting +-- `handleStream` is the stream handler function expected by a `ServerStreamCall`. +-- Note that the type of `handleStream` has nothing to do with the type of the +-- logger. +runUtxo :: UtxorpcClient -> IO () +runUtxo client = do + _maybeFetchBlockResponse <- handleUnaryReply $ fetchBlock (syncClient client) defMessage + _maybeChainTipResponse <- handleUnaryReply $ getChainTip (buildClient client) defMessage + _maybeStreamState <- + handleStreamReply $ + watchMempool (submitClient client) (0 :: Int) defMessage handleStream + return () + where + handleStream n _headerList _reply = do + putStrLn ("The stream handler is processing message #" ++ show n) + return (n + 1) + +-- Composite handlers for each error type that can be returned by the + +handleUnaryReply :: UnaryReply o -> IO (Maybe o) +handleUnaryReply reply = do + res <- reply + case res of + Left clientErr -> + handleClientErr clientErr + Right (Left tmc) -> + handleTMC tmc + Right (Right (Left errCode)) -> + handleHTTP2Err errCode + Right (Right (Right (headers, trailers, Left errMsg))) -> + handleServerError (headers, trailers, errMsg) + Right (Right (Right (_, _, Right msg))) -> + return $ Just msg + +handleStreamReply :: ServerStreamReply a -> IO (Maybe a) +handleStreamReply runReply = do + reply <- runReply + case reply of + Left clientErr -> + handleClientErr clientErr + Right (Left tmc) -> + handleTMC tmc + Right (Right (streamState, _headerList, _trailerList)) -> return $ Just streamState + +-- Error handlers that throw IO exceptions +-- A production application should handle these more gracefully +-- E.g., TooMuchConcurrency errors indicate a need to wait and +-- try again. + +handleClientErr :: (MonadIO m) => ClientError -> m a +handleClientErr _ = throwString "Early end of stream!" + +handleTMC :: (MonadIO m) => TooMuchConcurrency -> m a +handleTMC _ = throwString "Too much concurrency!" + +handleHTTP2Err :: (MonadIO m) => ErrorCode -> m a +handleHTTP2Err errCode = throwString $ "HTTP2 Error: " ++ show errCode + +handleServerError :: (MonadIO m) => (CIHeaderList, Maybe CIHeaderList, String) -> m a +handleServerError (_headers, _trailers, msg) = throwString $ "Received error message: " ++ msg diff --git a/example/SimpleLogger.hs b/example/SimpleLogger.hs new file mode 100644 --- /dev/null +++ b/example/SimpleLogger.hs @@ -0,0 +1,111 @@ +module SimpleLogger (simpleLogger) where + +import Control.Lens.Combinators (over, _1) +import Control.Monad (unless) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI (..)) +import Data.ProtoLens.TextFormat (showMessage) +import Data.Time.LocalTime (getZonedTime) +import Data.UUID (UUID) +import Network.GRPC.Client.Helpers (GrpcClient (..)) +import Network.GRPC.HTTP2.Encoding (Compression (..)) +import Utxorpc.Client (ReplyLogger, RequestLogger, ServerStreamEndLogger, ServerStreamLogger, UtxorpcClientLogger (..)) + +-- Prints simple, human-readable messages +simpleLogger :: UtxorpcClientLogger IO +simpleLogger = + UtxorpcClientLogger + simpleRequestLogger + simpleReplyLogger + simpleServerStreamLogger + simpleServerStreamEndLogger + id + +simpleRequestLogger :: RequestLogger IO +simpleRequestLogger rpcPath client uuid req = do + footer <- printPreamble "REQUEST" rpcPath client uuid + unless (null $ _grpcClientHeaders client) $ + putStrLn $ + showHdrs "Headers" (_grpcClientHeaders client) + putStrLn $ "Compression: " ++ BS.unpack (_compressionName (_grpcClientCompression client)) + putStrLn $ "Message:\n" ++ indent 1 (showMessage req) + putStrLn footer + +simpleReplyLogger :: ReplyLogger IO +simpleReplyLogger rpcPath client uuid reply = do + footer <- printPreamble "REPLY" rpcPath client uuid + case reply of + Left _clientErr -> putStrLn "Error: Early end of Stream!" + Right (Left _tmc) -> putStrLn "Error: Too much concurrency!" + Right (Right (Left errCode)) -> putStrLn $ "Error code: " ++ show errCode + Right (Right (Right (hdrs, trailers, Left errMsg))) -> do + putStr $ showHdrTrailers hdrs trailers + putStrLn $ "Error: " ++ errMsg + Right (Right (Right (hdrs, trailers, Right o))) -> do + putStr $ showHdrTrailers hdrs trailers + putStrLn $ "Message:\n" ++ indent 1 (showMessage o) + putStrLn footer + +simpleServerStreamLogger :: ServerStreamLogger IO +simpleServerStreamLogger rpcPath client (uuid, index) o = do + footer <- printPreamble "STREAM DATA" rpcPath client uuid + putStrLn $ "Message (#" ++ show index ++ "):" + putStrLn $ indent 1 (showMessage o) + putStrLn footer + +simpleServerStreamEndLogger :: ServerStreamEndLogger IO +simpleServerStreamEndLogger rpcPath client (uuid, numMessages) (hdrs, trailers) = do + footer <- printPreamble "STREAM DATA" rpcPath client uuid + putStrLn $ showHdrTrailers' hdrs trailers + putStrLn $ "Server stream ended after " ++ show numMessages ++ " messages." + putStrLn footer + +printPreamble :: String -> BS.ByteString -> GrpcClient -> UUID -> IO String +printPreamble eventName rpcPath client uuid = do + (header, footer) <- headerFooter eventName + putStrLn header + putStrLn $ "UUID: " ++ show uuid + putStrLn $ "Path: " ++ BS.unpack rpcPath + putStrLn $ "Authority: " ++ show (_grpcClientAuthority client) + return footer + +headerFooter :: String -> IO (String, String) +headerFooter eventName = do + zoned <- getZonedTime + return (header zoned, footer) + where + header zoned = replicate lPadding c ++ " " ++ hdrText ++ " " ++ replicate rPadding c + where + hdrText = eventName ++ ": " ++ show zoned + lPadding = diff `div` 2 + rPadding = diff `div` 2 + (diff `mod` 2) + diff = w - 2 - length hdrText + + footer = replicate w c + + w = 75 + c = '-' + +showHdrTrailers :: [(CI BS.ByteString, BS.ByteString)] -> Maybe [(CI BS.ByteString, BS.ByteString)] -> String +showHdrTrailers hdrs trailers = + showCIHdrs "Headers" hdrs + ++ maybe "" (showCIHdrs "Trailers") trailers + +showHdrTrailers' :: [(BS.ByteString, BS.ByteString)] -> [(BS.ByteString, BS.ByteString)] -> String +showHdrTrailers' hdrs trailers = + showHdrs "Headers" hdrs + ++ showHdrs "Trailers" trailers + +showHdrs :: String -> [(BS.ByteString, BS.ByteString)] -> String +showHdrs name hdrs = + name + ++ ":\n" + ++ (if not (null hdrs) then indent 1 . unlines $ map showHdr hdrs else "") + where + showHdr (k, v) = BS.unpack k ++ ": " ++ BS.unpack v + +showCIHdrs :: String -> [(CI BS.ByteString, BS.ByteString)] -> String +showCIHdrs name hdrs = showHdrs name $ map (over _1 original) hdrs + +indent :: Int -> String -> String +indent n = unlines . map (replicate n '\t' ++) . lines diff --git a/quick-start/Main.hs b/quick-start/Main.hs new file mode 100644 --- /dev/null +++ b/quick-start/Main.hs @@ -0,0 +1,35 @@ +module Main (main) where + +import Control.Exception (throwIO) +import Control.Lens.Operators ((&), (.~)) +import qualified Data.ByteString.Char8 as BS +import Data.ProtoLens (Message (..)) +import Proto.Utxorpc.V1alpha.Sync.Sync_Fields (hash, index, ref) +import UnliftIO.Exception (throwString) +import Utxorpc.Client (simpleUtxorpcClient) +import Utxorpc.Types (fetchBlock, syncClient) + +main :: IO () +main = do + -- Connect to a UTxO RPC service + eClient <- simpleUtxorpcClient "hostname" 443 True + case eClient of + Left clientErr -> throwIO clientErr + Right client -> do + -- Make a unary request + result <- fetchBlock (syncClient client) fetchBlockRequest + case result of + -- Handle success + Right (Right (Right (_headers, _trailers, fetchBlockResponse))) -> + print fetchBlockResponse + err -> throwString $ show err + where + fetchBlockRequest = + defMessage + & ref + .~ [ defMessage + & index .~ 40608434 + & hash + .~ BS.pack + "3e4947072df1ed22a0518cb717c2904ebf0952b0c33292b402fae25d9562022e" + ] diff --git a/src/Utxorpc/Client.hs b/src/Utxorpc/Client.hs new file mode 100644 --- /dev/null +++ b/src/Utxorpc/Client.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Utxorpc.Client +-- Description : Create a connected UTxO RPC client. +-- Create a UTxO RPC client connected to a UTxO RPC service. The @'UtxorpcClient'@ provides functions for each of the methods in the UTxO RPC specification. +-- Provide a UtxorpcClientLogger to perform automated logging. +module Utxorpc.Client + ( UtxorpcInfo (..), + utxorpcClient, + simpleUtxorpcClient, + utxorpcClientWith, + UtxorpcClientLogger (..), + RequestLogger, + ReplyLogger, + ServerStreamLogger, + ServerStreamEndLogger, + ) +where + +import qualified Data.ByteString.Char8 as BS +import Network.GRPC.Client (gzip, uncompressed) +import Network.GRPC.Client.Helpers + ( GrpcClient (_grpcClientHeaders), + GrpcClientConfig, + UseTlsOrNot, + close, + grpcClientConfigSimple, + setupGrpcClient, + _grpcClientConfigCompression, + ) +import Network.GRPC.HTTP2.ProtoLens (RPC (RPC)) +import Proto.Utxorpc.V1alpha.Build.Build +import Proto.Utxorpc.V1alpha.Submit.Submit +import Proto.Utxorpc.V1alpha.Sync.Sync +import Proto.Utxorpc.V1alpha.Watch.Watch +import Utxorpc.Logged (ReplyLogger, RequestLogger, ServerStreamEndLogger, ServerStreamLogger, UtxorpcClientLogger (..), loggedSStream, loggedUnary) +import Utxorpc.Types +import "http2-client" Network.HTTP2.Client (ClientError, HostName, PortNumber, runClientIO) + +-- | Configuration info for a UTxO RPC Client. +-- For more fine-grained control, use @'GrpcClientConfig'@ and @'UtxorpcClientWith'@ +data UtxorpcInfo m = UtxorpcInfo + { -- | Host name of the service. + _hostName :: HostName, + -- | Port number of the service. + _portNumber :: PortNumber, + -- | Whether or not to use TLS. + _tlsEnabled :: UseTlsOrNot, + -- | Whether or not to use gzip compression. + _useGzip :: Bool, + -- | Headers to include in each request (e.g., API key/authorization). + _clientHeaders :: [(BS.ByteString, BS.ByteString)], + -- | Log all RPC events. + _logger :: Maybe (UtxorpcClientLogger m) + } + +-- | Make a connection to a UTxO RPC service with the minimum required information. +-- No compression is used, no headers are added, and no logging is performed. +-- For more configurability, use @'utxorpcClient'@ or @'utxorpcClientWith'@. +simpleUtxorpcClient :: + -- | Host name of the service. + HostName -> + -- | Port number of the service. + PortNumber -> + -- | Whether or not to use TLS. + UseTlsOrNot -> + IO (Either ClientError UtxorpcClient) +simpleUtxorpcClient host port tlsEnabled = + utxorpcClient $ + UtxorpcInfo host port tlsEnabled False [] Nothing + +-- | Connect to a UTxO RPC service from a @'UtxorpcInfo'@. +-- Provides more configurability than @'simpleUtxorpcClient'@ but less than @'utxorpcClientWith'@. +utxorpcClient :: UtxorpcInfo m -> IO (Either ClientError UtxorpcClient) +utxorpcClient + UtxorpcInfo {_hostName, _portNumber, _tlsEnabled, _useGzip, _logger, _clientHeaders} = do + eClient <- grpcClient _hostName _portNumber _tlsEnabled _useGzip + return $ fromGrpc _logger . withHeaders _clientHeaders <$> eClient + where + withHeaders hdrs client = + let oldHdrs = _grpcClientHeaders client + in client {_grpcClientHeaders = oldHdrs ++ hdrs} + +-- | Connect to a UTxO RPC from a @'GrpcClientConfig'@. +-- For a simpler interface with less configurability, use @'utxorpcClient'@ or @'simpleUtxorpcClient'@. +utxorpcClientWith :: + GrpcClientConfig -> + Maybe (UtxorpcClientLogger m) -> + IO (Either ClientError UtxorpcClient) +utxorpcClientWith config logger = do + eClient <- runClientIO $ setupGrpcClient config + return $ fromGrpc logger <$> eClient + +grpcClient :: + HostName -> + PortNumber -> + UseTlsOrNot -> + Bool -> + IO (Either ClientError GrpcClient) +grpcClient host port tlsEnabled doCompress = runClientIO $ do + setupGrpcClient + ( (grpcClientConfigSimple host port tlsEnabled) + { _grpcClientConfigCompression = compression + } + ) + where + compression = if doCompress then gzip else uncompressed + +fromGrpc :: Maybe (UtxorpcClientLogger m) -> GrpcClient -> UtxorpcClient +fromGrpc logger client = + UtxorpcClient + (buildClientImpl logger client) + (submitClientImpl logger client) + (syncClientImpl logger client) + (watchClientImpl logger client) + (runClientIO $ Network.GRPC.Client.Helpers.close client) + +{-------------------------------------- + BUILD +--------------------------------------} + +buildClientImpl :: Maybe (UtxorpcClientLogger m) -> GrpcClient -> BuildClientImpl +buildClientImpl logger client = + BuildClientImpl + (loggedUnary logger getChainTipRPC client) + (loggedUnary logger getChainParamRPC client) + (loggedUnary logger getUtxoByAddressRPC client) + (loggedUnary logger getUtxoByRefRPC client) + (loggedSStream logger holdUtxoRPC client) + +getChainTipRPC :: RPC LedgerStateService "getChainTip" +getChainTipRPC = RPC + +getChainParamRPC :: RPC LedgerStateService "getChainParam" +getChainParamRPC = RPC + +getUtxoByAddressRPC :: RPC LedgerStateService "getUtxoByAddress" +getUtxoByAddressRPC = RPC + +getUtxoByRefRPC :: RPC LedgerStateService "getUtxoByRef" +getUtxoByRefRPC = RPC + +holdUtxoRPC :: RPC LedgerStateService "holdUtxo" +holdUtxoRPC = RPC + +{-------------------------------------- + SUBMIT +--------------------------------------} + +submitClientImpl :: Maybe (UtxorpcClientLogger m) -> GrpcClient -> SubmitClientImpl +submitClientImpl logger client = + SubmitClientImpl + (loggedUnary logger submitTxRPC client) + (loggedUnary logger readMempoolRPC client) + (loggedSStream logger waitForTxRPC client) + (loggedSStream logger watchMempoolRPC client) + +submitTxRPC :: RPC SubmitService "submitTx" +submitTxRPC = RPC + +readMempoolRPC :: RPC SubmitService "readMempool" +readMempoolRPC = RPC + +waitForTxRPC :: RPC SubmitService "waitForTx" +waitForTxRPC = RPC + +watchMempoolRPC :: RPC SubmitService "watchMempool" +watchMempoolRPC = RPC + +{-------------------------------------- + SYNC +--------------------------------------} + +syncClientImpl :: Maybe (UtxorpcClientLogger m) -> GrpcClient -> SyncClientImpl +syncClientImpl logger client = + SyncClientImpl + (loggedUnary logger fetchBlockRPC client) + (loggedUnary logger dumpHistoryRPC client) + (loggedSStream logger followTipRPC client) + +fetchBlockRPC :: RPC ChainSyncService "fetchBlock" +fetchBlockRPC = RPC + +dumpHistoryRPC :: RPC ChainSyncService "dumpHistory" +dumpHistoryRPC = RPC + +followTipRPC :: RPC ChainSyncService "followTip" +followTipRPC = RPC + +{-------------------------------------- + WATCH +--------------------------------------} + +watchClientImpl :: Maybe (UtxorpcClientLogger m) -> GrpcClient -> WatchClientImpl +watchClientImpl logger client = + WatchClientImpl $ loggedSStream logger watchTxRPC client + +watchTxRPC :: RPC WatchService "watchTx" +watchTxRPC = RPC diff --git a/src/Utxorpc/Logged.hs b/src/Utxorpc/Logged.hs new file mode 100644 --- /dev/null +++ b/src/Utxorpc/Logged.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} + +module Utxorpc.Logged + ( UtxorpcClientLogger (..), + RequestLogger, + ReplyLogger, + ServerStreamLogger, + ServerStreamEndLogger, + loggedSStream, + loggedSStream', + loggedUnary, + loggedUnary', + UnaryExecutor, + ServerStreamExecutor, + ) +where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString.Char8 as BS +import Data.ProtoLens (Message) +import Data.UUID (UUID) +import Data.UUID.V4 (nextRandom) +import Network.GRPC.Client (HeaderList, RawReply) +import Network.GRPC.Client.Helpers (GrpcClient (..), rawStreamServer, rawUnary) +import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput) +import Network.GRPC.HTTP2.Types (IsRPC (..)) +import Network.HTTP2.Client.Exceptions (ClientIO) +import Utxorpc.Types (ServerStreamReply, UnaryReply) +import "http2-client" Network.HTTP2.Client (ClientError, TooMuchConcurrency, runClientIO) + +{-------------------------------------- + Types +--------------------------------------} + +-- | Logging functions to log requests, replies, server stream messages, and server stream endings. +-- A UUID is generated for each request and passed downstream to the other logging functions. +data UtxorpcClientLogger m = UtxorpcClientLogger + { -- | Log outgoing requests. + requestLogger :: RequestLogger m, + -- | Log incoming unary replies. + replyLogger :: ReplyLogger m, + -- | Log incoming server stream messages. + serverStreamLogger :: ServerStreamLogger m, + -- | Log the end of a server stream. + serverStreamEndLogger :: ServerStreamEndLogger m, + -- | Provided here as a convenience to allow logging functions to be written in any monadic stack + -- without having to apply the unlift function to each logging function individually. + unlift :: forall x. m x -> IO x + } + +-- | Log outgoing requests of all types (i.e., unary requests and server stream requests). +type RequestLogger m = + forall i. + (Show i, Message i) => + -- | The RPC path + BS.ByteString -> + -- | Included because it contains useful information such as the server address. + GrpcClient -> + -- | Generated for this request, and passed to other logging functions for other RPC events generated by this request. + -- E.g., A unary request and its reply both have the same UUID. + UUID -> + -- | The request message being sent. + i -> + m () + +-- | Log unary replies. +type ReplyLogger m = + forall o. + (Show o, Message o) => + -- | The RPC path + BS.ByteString -> + -- | Included because it contains useful information such as the server address. + GrpcClient -> + -- | Generated for the request that this reply is associated with. + UUID -> + -- | Message received from the service (with headers) or an error. + Either ClientError (Either TooMuchConcurrency (RawReply o)) -> + m () + +-- | Log server stream messages. +type ServerStreamLogger m = + forall o. + (Show o, Message o) => + -- | The RPC path + BS.ByteString -> + -- | Included because it contains useful information such as the server address. + GrpcClient -> + -- | The UUID was generated for the request that caused this reply, + -- the Int is the index of this message in the stream. + (UUID, Int) -> + -- | Message received from the service. + o -> + m () + +-- The GrcpClient is included because it contains useful information such as the server address. +-- The UUID was generated for the request that this reply is associated with. +type ServerStreamEndLogger m = + -- | The RPC path + BS.ByteString -> + -- | Included because it contains useful information such as the server address. + GrpcClient -> + -- | The UUID was generated for the request that caused this reply, + -- the Int is the total number of messages received in the stream. + (UUID, Int) -> + -- | Headers and Trailers. + (HeaderList, HeaderList) -> + m () + +-- | The type of http-client-grpc's `rawUnary`. Used internally and in tests. +type UnaryExecutor r i o = + -- | The RPC to call. + r -> + -- | An initialized client. + GrpcClient -> + -- | The input. + i -> + ClientIO (Either TooMuchConcurrency (RawReply o)) + +-- | The type of http2-client-grpc's `rawStreamServer`. Used internally and in tests. +type ServerStreamExecutor r i o = + forall a. + -- | The RPC to call. + r -> + -- | An initialized client. + GrpcClient -> + -- | An initial state. + a -> + -- | The input of the stream request. + i -> + -- | A state-passing handler called for each server-sent output. + -- Headers are repeated for convenience but are the same for every iteration. + (a -> HeaderList -> o -> ClientIO a) -> + ClientIO (Either TooMuchConcurrency (a, HeaderList, HeaderList)) + +{-------------------------------------- + Logged wrappers of gRPC library functions +--------------------------------------} + +loggedUnary :: + (GRPCInput r i, GRPCOutput r o, Show i, Message i, Show o, Message o) => + Maybe (UtxorpcClientLogger m) -> + r -> + GrpcClient -> + i -> + UnaryReply o +loggedUnary = loggedUnary' rawUnary + +loggedUnary' :: + (GRPCInput r i, Show i, Message i, Show o, Message o) => + UnaryExecutor r i o -> + Maybe (UtxorpcClientLogger m) -> + r -> + GrpcClient -> + i -> + UnaryReply o +loggedUnary' sendUnary logger rpc client msg = + maybe (runClientIO $ sendUnary rpc client msg) logged logger + where + logged UtxorpcClientLogger {requestLogger, replyLogger, unlift} = do + uuid <- nextRandom + unlift $ requestLogger (path rpc) client uuid msg + o <- runClientIO $ sendUnary rpc client msg + unlift $ replyLogger (path rpc) client uuid o + return o + +-- The gRPC library requires a handler that produces a `ClientIO`, +-- but this does not make sense since a user-provided handler is not +-- likely to generate a `ClientError` or `TooMuchConcurrency`. +-- Instead, we accept a handler of type `IO` and lift it. +loggedSStream :: + (GRPCOutput r o, GRPCInput r i, Show i, Message i, Show o, Message o) => + Maybe (UtxorpcClientLogger m) -> + r -> + GrpcClient -> + a -> + i -> + (a -> HeaderList -> o -> IO a) -> + ServerStreamReply a +loggedSStream = loggedSStream' rawStreamServer + +loggedSStream' :: + (GRPCOutput r o, Show i, Message i, Show o, Message o) => + ServerStreamExecutor r i o -> + Maybe (UtxorpcClientLogger m) -> + r -> + GrpcClient -> + a -> + i -> + (a -> HeaderList -> o -> IO a) -> + ServerStreamReply a +loggedSStream' sendStreamReq logger r client initStreamState req chunkHandler = + maybe + (runClientIO $ sendStreamReq r client initStreamState req liftedChunkHandler) + logged + logger + where + liftedChunkHandler streamState headerList reply = liftIO $ chunkHandler streamState headerList reply + + logged + UtxorpcClientLogger {requestLogger, serverStreamLogger, serverStreamEndLogger, unlift} = do + uuid <- nextRandom + unlift $ requestLogger rpcPath client uuid req + streamResult <- runLoggedStream uuid + handleStreamResult streamResult + where + runLoggedStream uuid = + runClientIO $ + sendStreamReq r client (initStreamState, uuid, 0) req loggedChunkHandler + + loggedChunkHandler (streamState, uuid, index) headerList msg = do + liftIO . unlift $ serverStreamLogger rpcPath client (uuid, index) msg + a <- liftIO $ chunkHandler streamState headerList msg + return (a, uuid, index + 1) + + handleStreamResult streamResult = + case streamResult of + Right (Right ((finalStreamState, uuid, index), hl, hl')) -> do + liftIO . unlift $ serverStreamEndLogger rpcPath client (uuid, index) (hl, hl') + return $ Right $ Right (finalStreamState, hl, hl') + Right (Left tmc) -> return $ Right $ Left tmc + Left errCode -> return $ Left errCode + + rpcPath = path r diff --git a/src/Utxorpc/Types.hs b/src/Utxorpc/Types.hs new file mode 100644 --- /dev/null +++ b/src/Utxorpc/Types.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Utxorpc.Types +-- Description : Record types and type aliases. +-- The types in this module are required to call methods of a `UtxorpcClient`. +module Utxorpc.Types + ( UtxorpcClient (..), + BuildClientImpl (..), + SubmitClientImpl (..), + SyncClientImpl (..), + WatchClientImpl (..), + ServerStreamCall, + ServerStreamReply, + UnaryReply, + ) +where + +import Network.GRPC.Client (HeaderList, RawReply) +import Proto.Utxorpc.V1alpha.Build.Build +import Proto.Utxorpc.V1alpha.Submit.Submit +import Proto.Utxorpc.V1alpha.Sync.Sync +import Proto.Utxorpc.V1alpha.Watch.Watch +import "http2-client" Network.HTTP2.Client (ClientError, TooMuchConcurrency) + +-- | Type definition for functions that make calls to server stream methods. +-- Note that the stream state, a, can be different for each call. +type ServerStreamCall i o = + forall a. + -- | The initial state for the stream processing function. + a -> + -- | The request message to send to the service. + i -> + -- | The stream processing function. It is a fold over some state a with stream messages o. + (a -> HeaderList -> o -> IO a) -> + -- | The final state of the stream processing function, or an error. + ServerStreamReply a + +-- | The type returned by calls to unary service methods. +type UnaryReply o = + IO + (Either ClientError (Either TooMuchConcurrency (RawReply o))) + +-- | The type returned by calls to server stream methods. a is the final state of the stream processing function. +type ServerStreamReply a = + IO + (Either ClientError (Either TooMuchConcurrency (a, HeaderList, HeaderList))) + +{--------------------------------------- + UtxorpcClient +---------------------------------------} + +-- | Methods for each module in UTxO RPC. +-- >>> fetchBlock (buildClient client) defMessage +data UtxorpcClient = UtxorpcClient + { -- | Build module service methods. + buildClient :: BuildClientImpl, + -- | Submit module service methods. + submitClient :: SubmitClientImpl, + -- | Sync module service methods. + syncClient :: SyncClientImpl, + -- | Watch module service methods. + watchClient :: WatchClientImpl, + -- | Closes the gRPC connection. + close :: IO (Either ClientError ()) + } + +{--------------------------------------- + Build +---------------------------------------} + +-- | Methods of the Build module +data BuildClientImpl = BuildClientImpl + { getChainTip :: GetChainTipRequest -> UnaryReply GetChainTipResponse, + getChainParam :: GetChainParamRequest -> UnaryReply GetChainParamResponse, + getUtxoByAddress :: GetUtxoByAddressRequest -> UnaryReply GetUtxoByAddressResponse, + getUtxoByRef :: GetUtxoByRefRequest -> UnaryReply GetUtxoByRefResponse, + holdUtxo :: ServerStreamCall HoldUtxoRequest HoldUtxoResponse + } + +{--------------------------------------- + Submit +---------------------------------------} + +-- | Methods of the Submit module +data SubmitClientImpl = SubmitClientImpl + { submitTx :: SubmitTxRequest -> UnaryReply SubmitTxResponse, + readMempool :: ReadMempoolRequest -> UnaryReply ReadMempoolResponse, + waitForTx :: ServerStreamCall WaitForTxRequest WaitForTxResponse, + watchMempool :: ServerStreamCall WatchMempoolRequest WatchMempoolResponse + } + +{--------------------------------------- + Sync +---------------------------------------} + +-- | Methods of the Sync module +data SyncClientImpl = SyncClientImpl + { fetchBlock :: FetchBlockRequest -> UnaryReply FetchBlockResponse, + dumpHistory :: DumpHistoryRequest -> UnaryReply DumpHistoryResponse, + followTip :: ServerStreamCall FollowTipRequest FollowTipResponse + } + +{--------------------------------------- + Watch +---------------------------------------} + +-- | Methods of the watch module +newtype WatchClientImpl = WatchClientImpl + { watchTx :: ServerStreamCall WatchTxRequest WatchTxResponse + } diff --git a/test/logged_test.hs b/test/logged_test.hs new file mode 100644 --- /dev/null +++ b/test/logged_test.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} + +module Main (main) where + +import Control.Monad (foldM) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.List (foldl') +import Data.ProtoLens.Message (defMessage) +import Network.GRPC.Client (HeaderList, RawReply) +import Network.GRPC.HTTP2.ProtoLens (RPC (RPC)) +import Proto.Utxorpc.V1alpha.Sync.Sync +import Test.Hspec +import Utxorpc.Logged +import "http2-client" Network.HTTP2.Client (ClientError, TooMuchConcurrency) + +type UnaryReq = FetchBlockRequest + +unaryReq :: UnaryReq +unaryReq = defMessage + +type UnaryReply = FetchBlockResponse + +type UnaryRpc = RPC ChainSyncService "fetchBlock" + +unaryRpc :: UnaryRpc +unaryRpc = RPC + +type StreamReq = FollowTipRequest + +streamReq :: StreamReq +streamReq = defMessage + +type StreamReply = FollowTipResponse + +streamReplies :: Int -> [StreamReply] +streamReplies n = replicate n defMessage + +type StreamRpc = RPC ChainSyncService "followTip" + +streamRpc :: StreamRpc +streamRpc = RPC + +mockLogger :: (String -> IO ()) -> UtxorpcClientLogger IO +mockLogger f = + UtxorpcClientLogger + (mockRequestLogger f) + (mockReplyLogger f) + (mockStreamLogger f) + (mockStreamEndLogger f) + id + +showIndex :: Int -> String +showIndex i = " (" ++ show i ++ ")" + +mockRequestLogger :: (String -> IO ()) -> RequestLogger IO +mockRequestLogger f _ _ _ msg = f $ requestLoggerOut msg + +requestLoggerOut :: (Show a) => a -> String +requestLoggerOut msg = "REQUEST_LOGGER" ++ show msg + +mockReplyLogger :: (String -> IO ()) -> ReplyLogger IO +mockReplyLogger f _ _ _ msg = f $ replyLoggerOut msg + +replyLoggerOut :: + (Show a) => + Either ClientError (Either TooMuchConcurrency (RawReply a)) -> + String +replyLoggerOut (Right (Right (Right (_, _, Right msg)))) = "REPLY_LOGGER" ++ show msg +replyLoggerOut _ = "REPLY_LOGGER: error" + +mockStreamLogger :: (String -> IO ()) -> ServerStreamLogger IO +mockStreamLogger f _ _ (_, index) msg = f $ streamLoggerOut index msg + +streamLoggerOut :: (Show a) => Int -> a -> String +streamLoggerOut index msg = "STREAM_LOGGER" ++ showIndex index ++ show msg + +mockStreamEndLogger :: (String -> IO ()) -> ServerStreamEndLogger IO +mockStreamEndLogger f _ _ (_, index) _ = f $ streamEndLoggerOut index + +streamEndLoggerOut :: Int -> String +streamEndLoggerOut index = "STREAM_END_LOGGER" ++ showIndex index + +mockUnaryExecutor :: UnaryExecutor r i UnaryReply +mockUnaryExecutor _ _ _ = return $ Right $ Right ([], Nothing, Right defMessage) + +mockServerStreamExecutor :: Int -> ServerStreamExecutor r i StreamReply +mockServerStreamExecutor n _ _ initStreamState _ inStream = do + finalStreamState <- foldM run initStreamState $ streamReplies n + return $ Right (finalStreamState, [], []) + where + run state = inStream state [] + +mockInStream :: (String -> IO ()) -> Int -> HeaderList -> StreamReply -> IO Int +mockInStream logF index _ msg = do + logF $ inStreamOut index msg + return $ index + 1 + +inStreamOut :: (Show o) => Int -> o -> String +inStreamOut index msg = "IN_STREAM_OUT" ++ showIndex index ++ show msg + +testUnary :: IO () +testUnary = do + out <- newIORef "" + let logF str = writeIORef out . (++ str ++ "\n") =<< readIORef out + _reply <- + loggedUnary' + mockUnaryExecutor + (Just $ mockLogger logF) + unaryRpc + undefined + unaryReq + out' <- readIORef out + + hspec $ describe "Unary Logging" $ do + it "should log the request" $ do + head (lines out') `shouldBe` requestLoggerOut unaryReq + it "should log the reply" $ do + tail (lines out') + `shouldBe` [ replyLoggerOut $ + Right (Right (Right ([], Nothing, Right (defMessage :: UnaryReply)))) + ] + +testStream :: IO () +testStream = do + out <- newIORef "" + let logF str = writeIORef out . (++ str ++ "\n") =<< readIORef out + let numStreamMsgs = 3 + + _finalStreamState <- + loggedSStream' + (mockServerStreamExecutor numStreamMsgs) + (Just $ mockLogger logF) + streamRpc + undefined + 0 + streamReq + (mockInStream logF) + out' <- readIORef out + + hspec $ describe "Stream logging" $ do + it "should log the request" $ do + head (lines out') `shouldBe` requestLoggerOut streamReq + it "should log the stream" $ do + let msgsWithIndex = zip [0 .. numStreamMsgs] (streamReplies numStreamMsgs) + let targetStreamLogs (index, msg) = [streamLoggerOut index msg, inStreamOut index msg] + let f logs (index, msg) = logs ++ targetStreamLogs (index, msg) + init (tail (lines out')) + `shouldBe` foldl' f [] msgsWithIndex + it "should log the end of the stream" $ do + last (lines out') `shouldBe` streamEndLoggerOut numStreamMsgs + +main :: IO () +main = do + testUnary + testStream diff --git a/utxorpc-client.cabal b/utxorpc-client.cabal new file mode 100644 --- /dev/null +++ b/utxorpc-client.cabal @@ -0,0 +1,150 @@ +cabal-version: 3.0 + +name: utxorpc-client +version: 0.0.1.0 +synopsis: An SDK for clients of the UTxO RPC specification. +description: This SDK includes helper functions for creating a UTxO gRPC client, calling UTxO RPC methods, and logging every interaction. +category: Network, Blockchain, Cardano +homepage: https://github.com/utxorpc/utxorpc-client#readme +bug-reports: https://github.com/utxorpc/utxorpc-client/issues +author: Dominic Mayhew +maintainer: dominic.j.mayhew@gmail.com +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/utxorpc/haskell-sdk + +library + exposed-modules: + Utxorpc.Client + Utxorpc.Types + other-modules: + Utxorpc.Logged + hs-source-dirs: + src + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wmissing-home-modules + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + build-depends: + base >=4.7 && <5 + , bytestring < 0.13 + , http2-client >= 0.10.0.1 && < 0.11 + , http2-client-grpc < 0.9 + , http2-grpc-proto-lens < 0.2 + , http2-grpc-types < 0.6 + , proto-lens < 0.8 + , utxorpc >= 0.0.3 && < 0.1 + , uuid < 1.4 + default-language: Haskell2010 + +executable client-example + main-is: + Main.hs + other-modules: + SimpleLogger + KatipLogger + hs-source-dirs: + example + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wmissing-home-modules + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + build-depends: + aeson < 2.3 + , base >=4.7 && <5 + , bytestring < 0.13 + , case-insensitive < 1.3 + , katip < 0.9 + , http2 < 5.2 + , http2-client >= 0.10.0.1 && < 11 + , http2-client-grpc < 0.9 + , http2-grpc-types < 0.6 + , lens < 5.3 + , proto-lens < 0.8 + , safe < 0.4 + , time < 1.13 + , transformers < 0.7 + , unliftio < 0.3 + , utxorpc-client + , uuid < 1.4 + default-language: Haskell2010 + +executable client-quick-start + main-is: + Main.hs + hs-source-dirs: + quick-start + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wmissing-home-modules + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + build-depends: + , base >=4.7 && <5 + , bytestring < 0.13 + , lens < 5.3 + , proto-lens < 0.8 + , unliftio < 0.3 + , utxorpc >= 0.0.3.0 && < 0.1 + , utxorpc-client + default-language: Haskell2010 + +test-suite logged_test_client + type: + exitcode-stdio-1.0 + main-is: + logged_test.hs + other-modules: + Utxorpc.Logged + Utxorpc.Types + hs-source-dirs: + test + src + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wmissing-home-modules + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + build-depends: + base >=4.7 && <5 + , bytestring < 0.13 + , http2-client >= 0.10.0.1 && < 11 + , http2-client-grpc < 0.9 + , http2-grpc-proto-lens < 0.2 + , http2-grpc-types >= 0.5.0.0 && < 0.6 + , hspec >= 2.11.7 && < 2.12 + , proto-lens < 0.8 + , utxorpc >= 0.0.3.0 && < 0.1 + , uuid < 1.4 + default-language: Haskell2010