utxorpc-server (empty) → 0.0.1.0
raw patch · 17 files changed
+1415/−0 lines, 17 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, case-insensitive, directory, hspec, http2-grpc-proto-lens, http2-grpc-types, katip, lens, proto-lens, time, transformers, unliftio, utxorpc, utxorpc-server, uuid, wai, warp, warp-grpc, warp-tls
Files
- LICENSE +201/−0
- example/BuildImpl.hs +49/−0
- example/EmptyHandlers.hs +29/−0
- example/KatipLogger.hs +91/−0
- example/Main.hs +66/−0
- example/SimpleLogger.hs +96/−0
- example/SubmitImpl.hs +39/−0
- example/SyncImpl.hs +35/−0
- example/WatchImpl.hs +18/−0
- src/Utxorpc/Build.hs +34/−0
- src/Utxorpc/Logged.hs +202/−0
- src/Utxorpc/Server.hs +103/−0
- src/Utxorpc/Submit.hs +32/−0
- src/Utxorpc/Sync.hs +30/−0
- src/Utxorpc/Watch.hs +26/−0
- test/logged_test.hs +230/−0
- utxorpc-server.cabal +134/−0
+ LICENSE view
@@ -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.
+ example/BuildImpl.hs view
@@ -0,0 +1,49 @@+module BuildImpl (handlerImpls) where++import Control.Monad.IO.Class (MonadIO)+import EmptyHandlers (emptySStreamHandler, emptyUnaryHandler)+import Network.GRPC.Server (ServerStreamHandler, UnaryHandler)+import Proto.Utxorpc.V1alpha.Build.Build+import Utxorpc.Server (BuildHandlers (..))++handlerImpls ::+ (MonadIO m) =>+ (String -> m ()) ->+ BuildHandlers m Int+handlerImpls logF =+ BuildHandlers+ (chainTipHandler logF)+ (chainParamHandler logF)+ (utxoByAddressHandler logF)+ (utxoByRefHandler logF)+ (holdUtxoHandler logF)++chainTipHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ UnaryHandler m GetChainTipRequest GetChainTipResponse+chainTipHandler = emptyUnaryHandler++chainParamHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ UnaryHandler m GetChainParamRequest GetChainParamResponse+chainParamHandler = emptyUnaryHandler++utxoByAddressHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ UnaryHandler m GetUtxoByAddressRequest GetUtxoByAddressResponse+utxoByAddressHandler = emptyUnaryHandler++utxoByRefHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ UnaryHandler m GetUtxoByRefRequest GetUtxoByRefResponse+utxoByRefHandler = emptyUnaryHandler++holdUtxoHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ ServerStreamHandler m HoldUtxoRequest HoldUtxoResponse Int+holdUtxoHandler = emptySStreamHandler
+ example/EmptyHandlers.hs view
@@ -0,0 +1,29 @@+module EmptyHandlers (emptyUnaryHandler, emptySStreamHandler) where++import Data.ProtoLens (Message (defMessage))+import Network.GRPC.Server (ServerStream (..))+import Network.Wai (Request)++emptyUnaryHandler :: (Monad m, Message o) => (String -> m ()) -> Request -> i -> m o+emptyUnaryHandler logF _ _ = do+ logF "A unary handler is processing a request and generating a reply..."+ return defMessage++emptySStreamHandler ::+ (Monad m, Message o) =>+ (String -> m ()) ->+ Request ->+ i ->+ m (Int, ServerStream m o Int)+emptySStreamHandler logF _ _ =+ return+ ( 0,+ ServerStream $ \n ->+ if n > 3+ then do+ logF "The stream handler is ending the stream"+ return Nothing+ else do+ logF "The stream handler is generating a message"+ return $ Just (n + 1, defMessage)+ )
+ example/KatipLogger.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module KatipLogger (katipLogger, unliftKatip, mkLogEnv) where++import Control.Monad.Trans.Reader (runReaderT)+import Data.Aeson as A+import qualified Data.ByteString.Char8 as BS+import Data.UUID (UUID)+import Katip+import Katip.Monadic+import UnliftIO (stdout)+import Utxorpc.Server (ReplyLogger, RequestLogger, ServerStreamEndLogger, ServerStreamLogger, UtxorpcServiceLogger (..))++katipLogger :: (KatipContext m) => UtxorpcServiceLogger m+katipLogger =+ UtxorpcServiceLogger+ katipRequestLogger+ katipReplyLogger+ katipServerStreamLogger+ katipServerStreamEndLogger++unliftKatip :: LogEnv -> KatipContextT IO a -> IO a+unliftKatip le ctxT = do+ let rdr = unKatipContextT ctxT+ let initState = KatipContextTState le mempty mempty+ runReaderT rdr initState++mkLogEnv :: IO LogEnv+mkLogEnv = do+ handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2+ le <- initLogEnv "UtxorpcService" "production"+ registerScribe "stdout" handleScribe defaultScribeSettings le++katipRequestLogger :: (KatipContext m) => RequestLogger m+katipRequestLogger rpcPath _req uuid i = do+ addContext rpcPath uuid Nothing Request $+ $(logTM) InfoS (showLS i)+ return ()++katipReplyLogger :: (KatipContext m) => ReplyLogger m+katipReplyLogger path _req uuid reply = do+ addContext path uuid Nothing Reply $+ $(logTM) InfoS (showLS reply)++katipServerStreamLogger :: (KatipContext m) => ServerStreamLogger m+katipServerStreamLogger path _req (uuid, index) msg =+ addContext path uuid (Just index) ServerStream $+ $(logTM) InfoS (showLS msg)++katipServerStreamEndLogger :: (KatipContext m) => ServerStreamEndLogger m+katipServerStreamEndLogger path _req (uuid, index) =+ addContext path uuid (Just index) ServerStreamEnd $+ $(logTM) InfoS "End of stream"++addContext :: (KatipContext m) => BS.ByteString -> UUID -> Maybe Int -> GrpcEvent -> m a -> m a+addContext path uuid index event = katipAddContext $ MsgContext path uuid index event++data MsgContext = MsgContext+ { _path :: BS.ByteString,+ _uuid :: UUID,+ _index :: Maybe Int,+ _event :: GrpcEvent+ }++data GrpcEvent = Request | Reply | ServerStream | ServerStreamEnd deriving (Show)++instance ToJSON MsgContext where+ toJSON :: MsgContext -> Value+ toJSON MsgContext {_path, _uuid, _index, _event} =+ A.object+ ( "path"+ A..= BS.unpack _path+ : "UUID"+ A..= show _uuid+ : "Event"+ A..= show _event+ : 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
+ example/Main.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Main (main) where++import qualified BuildImpl+import Data.List (find, isPrefixOf)+import Katip (Severity (..), closeScribes, logTM, ls)+import KatipLogger (katipLogger, mkLogEnv, unliftKatip)+import Network.GRPC.HTTP2.Encoding (Compression, gzip)+import Network.Wai.Handler.Warp (Settings, defaultSettings, setPort)+import Network.Wai.Handler.WarpTLS (TLSSettings, defaultTlsSettings)+import SimpleLogger (simpleLogger)+import qualified SubmitImpl+import qualified SyncImpl+import System.Environment (getArgs)+import UnliftIO (MonadIO, bracket)+import Utxorpc.Server (ServiceConfig (..), UtxorpcHandlers (UtxorpcHandlers), runUtxorpc)+import qualified WatchImpl++main :: IO ()+main = do+ args <- getArgs+ let port = maybe 3000 (read . drop 2) $ find ("-p" `isPrefixOf`) args+ putStrLn $ "Starting server on port " ++ show port+ if "--katip" `elem` args+ then runKatipExample defaultTlsSettings (setPort port defaultSettings) [gzip]+ else runSimpleExample++runKatipExample :: TLSSettings -> Settings -> [Compression] -> IO ()+runKatipExample tlsSettings warpSettings compression =+ bracket mkLogEnv closeScribes $ \le -> do+ runUtxorpc $ config le+ where+ config le =+ ServiceConfig+ tlsSettings+ warpSettings+ (handlersImpl katipLogF)+ (Just katipLogger)+ (unliftKatip le)+ compression++ katipLogF str = $(logTM) InfoS (ls str)++runSimpleExample :: IO ()+runSimpleExample = do+ runUtxorpc $+ ServiceConfig+ defaultTlsSettings+ defaultSettings+ (handlersImpl putStrLn)+ (Just simpleLogger)+ id+ [gzip]++handlersImpl :: (MonadIO m) => (String -> m ()) -> UtxorpcHandlers m Int Int Int Int Int+handlersImpl logF =+ UtxorpcHandlers+ (BuildImpl.handlerImpls logF)+ (SubmitImpl.handlerImpls logF)+ (SyncImpl.handlerImpls logF)+ (WatchImpl.handlerImpls logF)
+ example/SimpleLogger.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE RankNTypes #-}++module SimpleLogger (simpleLogger) where++import Control.Lens (over, _1)+import Control.Monad (unless)+import Control.Monad.IO.Class (MonadIO (liftIO))+import qualified Data.ByteString.Char8 as BS+import Data.CaseInsensitive (CI (..))+import Data.Time (getZonedTime)+import Data.UUID (UUID)+import Network.Wai (Request (..))+import Utxorpc.Server (ServerStreamEndLogger, ServerStreamLogger, UtxorpcServiceLogger (..))++simpleLogger :: (MonadIO m) => UtxorpcServiceLogger m+simpleLogger =+ UtxorpcServiceLogger+ simpleRequestLogger+ simpleReplyLogger+ simpleServerStreamLogger+ simpleServerStreamEndLogger++simpleRequestLogger :: (Show i, MonadIO m) => BS.ByteString -> Request -> UUID -> i -> m ()+simpleRequestLogger rpcPath req uuid i =+ liftIO $+ logEvent "REQUEST" rpcPath req uuid Nothing i++simpleReplyLogger :: (Show o, MonadIO m) => BS.ByteString -> Request -> UUID -> o -> m ()+simpleReplyLogger rpcPath req uuid o =+ liftIO $+ logEvent "REQUEST" rpcPath req uuid Nothing o++simpleServerStreamLogger :: (MonadIO m) => ServerStreamLogger m+simpleServerStreamLogger rpcPath req (uuid, index) o =+ liftIO $+ logEvent "SERVER STREAM" rpcPath req uuid (Just index) o++simpleServerStreamEndLogger :: (MonadIO m) => ServerStreamEndLogger m+simpleServerStreamEndLogger rpcPath req (uuid, index) =+ liftIO $+ logEvent "SERVER STREAM END" rpcPath req uuid (Just index) "End of server stream"++logEvent ::+ (Show a) =>+ String ->+ BS.ByteString ->+ Request ->+ UUID ->+ Maybe Int ->+ a ->+ IO ()+logEvent eventName rpcPath req uuid index msg = do+ (header, footer) <- headerFooter eventName+ putStrLn header+ putStrLn $ "UUID: " ++ show uuid+ case index of+ Just i -> putStrLn $ "Message #" ++ show i+ Nothing -> return ()+ putStrLn $ "Path: " ++ BS.unpack rpcPath+ putStrLn $ "Remote: " ++ show (remoteHost req)+ unless (null $ requestHeaders req) $+ liftIO . putStr $+ showCIHdrs "Headers" (requestHeaders req)+ liftIO . putStrLn $ "Message\n" ++ indent 1 (show msg)+ putStrLn 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 = '-'++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
+ example/SubmitImpl.hs view
@@ -0,0 +1,39 @@+module SubmitImpl (handlerImpls) where++import Control.Monad.IO.Class (MonadIO)+import EmptyHandlers (emptySStreamHandler, emptyUnaryHandler)+import Network.GRPC.Server (ServerStreamHandler, UnaryHandler)+import Proto.Utxorpc.V1alpha.Submit.Submit+import Utxorpc.Server (SubmitHandlers (..))++handlerImpls :: (MonadIO m) => (String -> m ()) -> SubmitHandlers m Int Int+handlerImpls logF =+ SubmitHandlers+ (submitTxHandler logF)+ (readMempoolHandler logF)+ (waitForTxHandler logF)+ (watchMempoolHandler logF)++submitTxHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ UnaryHandler m SubmitTxRequest SubmitTxResponse+submitTxHandler = emptyUnaryHandler++readMempoolHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ UnaryHandler m ReadMempoolRequest ReadMempoolResponse+readMempoolHandler = emptyUnaryHandler++waitForTxHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ ServerStreamHandler m WaitForTxRequest WaitForTxResponse Int+waitForTxHandler = emptySStreamHandler++watchMempoolHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ ServerStreamHandler m WatchMempoolRequest WatchMempoolResponse Int+watchMempoolHandler = emptySStreamHandler
+ example/SyncImpl.hs view
@@ -0,0 +1,35 @@+module SyncImpl (handlerImpls) where++import Control.Monad.IO.Class (MonadIO)+import EmptyHandlers (emptySStreamHandler, emptyUnaryHandler)+import Network.GRPC.Server (ServerStreamHandler, UnaryHandler)+import Proto.Utxorpc.V1alpha.Sync.Sync (DumpHistoryRequest, DumpHistoryResponse, FetchBlockRequest, FetchBlockResponse, FollowTipRequest, FollowTipResponse)+import Utxorpc.Server (SyncHandlers (..))++handlerImpls ::+ (MonadIO m) =>+ (String -> m ()) ->+ SyncHandlers m Int+handlerImpls logF =+ SyncHandlers+ (fetchBlockHandler logF)+ (dumpHistoryHandler logF)+ (followTipHandler logF)++fetchBlockHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ UnaryHandler m FetchBlockRequest FetchBlockResponse+fetchBlockHandler = emptyUnaryHandler++dumpHistoryHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ UnaryHandler m DumpHistoryRequest DumpHistoryResponse+dumpHistoryHandler = emptyUnaryHandler++followTipHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ ServerStreamHandler m FollowTipRequest FollowTipResponse Int+followTipHandler = emptySStreamHandler
+ example/WatchImpl.hs view
@@ -0,0 +1,18 @@+module WatchImpl (handlerImpls) where++import Control.Monad.IO.Class (MonadIO)+import EmptyHandlers (emptySStreamHandler)+import Network.GRPC.Server (ServerStreamHandler)+import Proto.Utxorpc.V1alpha.Watch.Watch (WatchTxRequest, WatchTxResponse)+import Utxorpc.Server (WatchHandlers (..))++handlerImpls :: (MonadIO m) => (String -> m ()) -> WatchHandlers m Int+handlerImpls logF =+ WatchHandlers+ (watchTxHandler logF)++watchTxHandler ::+ (MonadIO m) =>+ (String -> m ()) ->+ ServerStreamHandler m WatchTxRequest WatchTxResponse Int+watchTxHandler = emptySStreamHandler
+ src/Utxorpc/Build.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Utxorpc.Build (BuildHandlers (..), serviceHandlers) where++import Control.Monad.IO.Class (MonadIO)+import Network.GRPC.HTTP2.ProtoLens (RPC (RPC))+import Network.GRPC.Server (ServerStreamHandler, ServiceHandler, UnaryHandler)+import Proto.Utxorpc.V1alpha.Build.Build+import Utxorpc.Logged (UtxorpcServiceLogger, loggedSStream, loggedUnary)++data BuildHandlers m a = BuildHandlers+ { getChainTip :: UnaryHandler m GetChainTipRequest GetChainTipResponse,+ getChainParam :: UnaryHandler m GetChainParamRequest GetChainParamResponse,+ getUtxoByAddress :: UnaryHandler m GetUtxoByAddressRequest GetUtxoByAddressResponse,+ getUtxoByRef :: UnaryHandler m GetUtxoByRefRequest GetUtxoByRefResponse,+ holdUtxo :: ServerStreamHandler m HoldUtxoRequest HoldUtxoResponse a+ }++serviceHandlers ::+ (MonadIO m) =>+ Maybe (UtxorpcServiceLogger m) ->+ (forall x. m x -> IO x) ->+ BuildHandlers m b ->+ [ServiceHandler]+serviceHandlers logger f BuildHandlers {getChainTip, getChainParam, getUtxoByAddress, getUtxoByRef, holdUtxo} =+ [chainTipSH, chainParamSH, byAddressSH, byRefSH, holdSH]+ where+ chainTipSH = loggedUnary f (RPC :: RPC LedgerStateService "getChainTip") getChainTip logger+ chainParamSH = loggedUnary f (RPC :: RPC LedgerStateService "getChainParam") getChainParam logger+ byAddressSH = loggedUnary f (RPC :: RPC LedgerStateService "getUtxoByAddress") getUtxoByAddress logger+ byRefSH = loggedUnary f (RPC :: RPC LedgerStateService "getUtxoByRef") getUtxoByRef logger+ holdSH = loggedSStream f (RPC :: RPC LedgerStateService "holdUtxo") holdUtxo logger
+ src/Utxorpc/Logged.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Utxorpc.Logged+ ( UtxorpcServiceLogger (..),+ RequestLogger,+ ReplyLogger,+ ServerStreamLogger,+ ServerStreamEndLogger,+ loggedUnary,+ loggedUnaryHandler,+ loggedSStream,+ loggedSStreamHandler,+ )+where++import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.ByteString.Char8 as BS+import Data.UUID (UUID)+import Data.UUID.V4 (nextRandom)+import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput)+import Network.GRPC.HTTP2.Types (IsRPC (..))+import Network.GRPC.Server (ServiceHandler, UnaryHandler)+import Network.GRPC.Server.Handlers.Trans (ServerStream (..), ServerStreamHandler, serverStream, unary)+import Network.Wai (Request (..))++-- | A record of logging functions that runs in the same monad as+-- the request handlers. Monadic state is passed along throughout the+-- lifecycle of responding to a request. This means that changes to the+-- monadic state in the request logger is seen by the stream logger, stream+-- handler and logger, and reply logger. An `unlift` function to run the monad+-- in IO is provided to @'runUtxorpc'@.+data UtxorpcServiceLogger m = UtxorpcServiceLogger+ { requestLogger :: RequestLogger m,+ replyLogger :: ReplyLogger m,+ serverStreamLogger :: ServerStreamLogger m,+ serverStreamEndLogger :: ServerStreamEndLogger m+ }++-- | Log incoming requests.+type RequestLogger m =+ forall i.+ (Show i) =>+ -- | The RPC path+ BS.ByteString ->+ -- | Request metadata+ Request ->+ -- | A UUID generated for this request and passed to stream and reply loggers.+ UUID ->+ -- | The request message+ i ->+ m ()++-- | Log outgoing replies.+type ReplyLogger m =+ forall o.+ (Show o) =>+ -- | The RPC path+ BS.ByteString ->+ -- | Request metadata+ Request ->+ -- Generated for the request that caused this reply+ UUID ->+ -- | The reply message+ o ->+ m ()++-- | Log outgoing server stream messages.+type ServerStreamLogger m =+ forall o.+ (Show o) =>+ -- | The RPC path+ BS.ByteString ->+ -- | Request metadata+ Request ->+ -- | The UUID generated for the request that generated this stream,+ -- and the 0-based index of the message in the stream.+ (UUID, Int) ->+ -- | The stream message+ o ->+ m ()++-- | Log the end of a server stream.+type ServerStreamEndLogger m =+ -- | The RPC path+ BS.ByteString ->+ -- | Request metadata+ Request ->+ -- | The UUID generated for the request that generated this stream,+ -- and the 0-based index of the message in the stream.+ (UUID, Int) ->+ m ()++-- | Creates a ServiceHandler that warp-grpc uses to handle requests+loggedUnary ::+ (MonadIO m, GRPCInput r i, GRPCOutput r o, Show i, Show o) =>+ -- | An `unlift` function for the logger and handler monad+ -- Monad state is carried through from request logger, to handler, to reply logger,+ -- So changes to the monad state in the request logger is seen by the handler and reply logger.+ (forall x. m x -> IO x) ->+ -- | The RPC+ r ->+ -- | Generate a reply from request metadata and a proto Message+ UnaryHandler m i o ->+ -- | A logger that runs in the same monad as the handlers+ Maybe (UtxorpcServiceLogger m) ->+ ServiceHandler+loggedUnary unlift rpc handler maybeLogger =+ unary unlift rpc $ maybe handler loggedHandler maybeLogger+ where+ -- Generate UUID here for easier testing of `loggedUnaryHandler`+ loggedHandler logger req msg = do+ uuid <- liftIO nextRandom+ loggedUnaryHandler rpc handler uuid logger req msg++loggedUnaryHandler ::+ (MonadIO m, Show i, Show o, IsRPC r) =>+ r ->+ UnaryHandler m i o ->+ UUID ->+ UtxorpcServiceLogger m ->+ UnaryHandler m i o+loggedUnaryHandler+ rpc+ handler+ uuid+ UtxorpcServiceLogger {requestLogger, replyLogger}+ req+ msg =+ do+ requestLogger (path rpc) req uuid msg+ reply <- handler req msg+ replyLogger rpcPath req uuid reply+ return reply+ where+ rpcPath = path rpc++-- | Creates a ServiceHandler that warp-grpc uses to handle stream requests+loggedSStream ::+ (MonadIO m, GRPCInput r i, GRPCOutput r o, Show i, Show o) =>+ -- | An unlift function for the logger and handler+ -- Monadic state changes are passed from request logger to stream logger and handlers, and so on.+ -- So changes to the monadic state in the request logger are seen by the handler and other loggers.+ (forall x. m x -> IO x) ->+ -- | The RPC+ r ->+ -- | A function that, given request metadata and a protobuf Message,+ -- generates an initial stream state and a function that folds over the stream state to produce+ -- a stream of messages.+ ServerStreamHandler m i o a ->+ -- | A logger that runs in the same monad as the handler+ Maybe (UtxorpcServiceLogger m) ->+ ServiceHandler+loggedSStream unlift rpc handler Nothing = serverStream unlift rpc handler+loggedSStream unlift rpc handler (Just logger) =+ serverStream unlift rpc loggedHandler+ where+ loggedHandler req msg = do+ uuid <- liftIO nextRandom+ loggedSStreamHandler rpc handler uuid logger req msg++loggedSStreamHandler ::+ (MonadIO m, IsRPC r, Show i, Show o) =>+ r ->+ ServerStreamHandler m i o a ->+ UUID ->+ UtxorpcServiceLogger m ->+ ServerStreamHandler m i o (a, Int)+loggedSStreamHandler+ rpc+ handler+ uuid+ UtxorpcServiceLogger {requestLogger, serverStreamLogger, serverStreamEndLogger}+ req+ msg = do+ -- Log request+ requestLogger rpcPath req uuid msg+ -- Get initial stream state and stream output function+ (initStreamState, ServerStream {serverStreamNext}) <- handler req msg+ -- Wrap stream output function with logging+ let loggedStreamNext = mkLoggedStreamNext serverStreamNext+ -- The unwrapped handler returns the initial stream state and stream output function+ -- We add initial log state and return the wrapped stream output function+ return ((initStreamState, 0), ServerStream loggedStreamNext)+ where+ mkLoggedStreamNext getNext (streamState, index) = do+ -- Get next chunk+ next <- getNext streamState+ case next of+ Nothing -> do+ -- Log end of stream+ serverStreamEndLogger rpcPath req (uuid, index)+ -- Return end of stream+ return Nothing+ Just (nextStreamState, replyMsg) -> do+ -- Log chunk+ serverStreamLogger rpcPath req (uuid, index) replyMsg+ -- The unwrapped stream output function returns the next stream state and the message to send+ -- We add log state+ return $ Just ((nextStreamState, index + 1), replyMsg)++ rpcPath = path rpc
+ src/Utxorpc/Server.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Utxorpc.Server+ ( runUtxorpc,+ ServiceConfig (..),+ UtxorpcHandlers (..),+ BuildHandlers (..),+ SubmitHandlers (..),+ SyncHandlers (..),+ WatchHandlers (..),+ UtxorpcServiceLogger (..),+ RequestLogger,+ ReplyLogger,+ ServerStreamLogger,+ ServerStreamEndLogger,+ )+where++import Control.Monad.IO.Class (MonadIO)+import Network.GRPC.HTTP2.Encoding (Compression)+import Network.GRPC.Server+import Network.Wai.Handler.Warp (Settings)+import Network.Wai.Handler.WarpTLS (TLSSettings)+import Utxorpc.Build as Build (BuildHandlers (..), serviceHandlers)+import Utxorpc.Logged (ReplyLogger, RequestLogger, ServerStreamEndLogger, ServerStreamLogger, UtxorpcServiceLogger (..))+import Utxorpc.Submit as Submit (SubmitHandlers (..), serviceHandlers)+import Utxorpc.Sync as Sync (SyncHandlers (..), serviceHandlers)+import Utxorpc.Watch as Watch (WatchHandlers (..), serviceHandlers)++-- | Run a UTxO RPC service from a @'ServiceConfig'@.+runUtxorpc ::+ (MonadIO m) =>+ -- | Configuration info and method handlers. See @'ServiceConfig'@ for type information.+ ServiceConfig m a b c d e ->+ IO ()+runUtxorpc+ ServiceConfig+ { tlsSettings,+ warpSettings,+ handlers,+ logger,+ unlift,+ compression+ } =+ runGrpc+ tlsSettings+ warpSettings+ (Utxorpc.Server.serviceHandlers logger unlift handlers)+ compression++-- | Configuration info and method handlers. See @'UtxorpcHandlers'@ for type info.+data ServiceConfig m a b c d e = ServiceConfig+ { -- | warp-tls settings for using TLS.+ tlsSettings :: TLSSettings,+ -- | warp settings+ warpSettings :: Settings,+ -- | A handler for each method in the UTxO RPC specification.+ handlers :: UtxorpcHandlers m a b c d e,+ -- | Log each RPC event.+ logger :: Maybe (UtxorpcServiceLogger m),+ -- | An unlift function for the handlers and logger. Allows the handler and logger to be run in any monad, but they must be the same monad.+ unlift :: forall x. m x -> IO x,+ -- | A list of compressions to accept and use.+ compression :: [Compression]+ }++-- | A handler for each method in the UTxO RPC specification.+-- @'ServerStreamHandler'@s require a type variable representing the "stream state" (a value that the stream processes/folds over).+-- The type variables here (other than @`m`@) are the type variables of each stream handler in the record.+data+ UtxorpcHandlers+ m -- Monad of the handler functions+ a -- Stream state of `holdUtxo`+ b -- Stream state of `waitForTx`+ c -- Stream state of `watchMempool`+ d -- Stream state of `followTip`+ e -- Stream state of `watchTx`+ = UtxorpcHandlers+ { -- | Handlers for the Build module.+ buildHandlers :: BuildHandlers m a,+ -- | Handlers for the Submit module.+ submitHandlers :: SubmitHandlers m b c,+ -- | Handlers for the Sync module.+ syncHandlers :: SyncHandlers m d,+ -- | Handlers for the Watch module.+ watchHandlers :: WatchHandlers m e+ }++serviceHandlers ::+ (MonadIO m) =>+ Maybe (UtxorpcServiceLogger m) ->+ (forall x. m x -> IO x) ->+ UtxorpcHandlers m a b c d e ->+ [ServiceHandler]+serviceHandlers+ logger+ unlift+ UtxorpcHandlers {buildHandlers, submitHandlers, syncHandlers, watchHandlers} =+ Build.serviceHandlers logger unlift buildHandlers+ <> Submit.serviceHandlers logger unlift submitHandlers+ <> Sync.serviceHandlers logger unlift syncHandlers+ <> Watch.serviceHandlers logger unlift watchHandlers
+ src/Utxorpc/Submit.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Utxorpc.Submit (SubmitHandlers (..), serviceHandlers) where++import Control.Monad.IO.Class (MonadIO)+import Network.GRPC.HTTP2.ProtoLens (RPC (RPC))+import Network.GRPC.Server (ServerStreamHandler, ServiceHandler, UnaryHandler)+import Proto.Utxorpc.V1alpha.Submit.Submit+import Utxorpc.Logged (UtxorpcServiceLogger, loggedSStream, loggedUnary)++data SubmitHandlers m a b = SubmitHandlers+ { submitTx :: UnaryHandler m SubmitTxRequest SubmitTxResponse,+ readMempool :: UnaryHandler m ReadMempoolRequest ReadMempoolResponse,+ waitForTx :: ServerStreamHandler m WaitForTxRequest WaitForTxResponse a,+ watchMempool :: ServerStreamHandler m WatchMempoolRequest WatchMempoolResponse b+ }++serviceHandlers ::+ (MonadIO m) =>+ Maybe (UtxorpcServiceLogger m) ->+ (forall x. m x -> IO x) ->+ SubmitHandlers m b c ->+ [ServiceHandler]+serviceHandlers logger f SubmitHandlers {submitTx, readMempool, waitForTx, watchMempool} =+ [submitTxSH, readMempoolSH, waitForTxSH, watchMempoolSH]+ where+ submitTxSH = loggedUnary f (RPC :: RPC SubmitService "submitTx") submitTx logger+ readMempoolSH = loggedUnary f (RPC :: RPC SubmitService "readMempool") readMempool logger+ waitForTxSH = loggedSStream f (RPC :: RPC SubmitService "waitForTx") waitForTx logger+ watchMempoolSH = loggedSStream f (RPC :: RPC SubmitService "watchMempool") watchMempool logger
+ src/Utxorpc/Sync.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Utxorpc.Sync (SyncHandlers (..), serviceHandlers) where++import Control.Monad.IO.Class (MonadIO)+import Network.GRPC.HTTP2.ProtoLens (RPC (RPC))+import Network.GRPC.Server (ServerStreamHandler, ServiceHandler, UnaryHandler)+import Proto.Utxorpc.V1alpha.Sync.Sync+import Utxorpc.Logged (UtxorpcServiceLogger, loggedSStream, loggedUnary)++data SyncHandlers m a = SyncHandlers+ { fetchBlock :: UnaryHandler m FetchBlockRequest FetchBlockResponse,+ dumpHistory :: UnaryHandler m DumpHistoryRequest DumpHistoryResponse,+ followTip :: ServerStreamHandler m FollowTipRequest FollowTipResponse a+ }++serviceHandlers ::+ (MonadIO m) =>+ Maybe (UtxorpcServiceLogger m) ->+ (forall x. m x -> IO x) ->+ SyncHandlers m b ->+ [ServiceHandler]+serviceHandlers logger f SyncHandlers {fetchBlock, dumpHistory, followTip} =+ [fetchBlockSH, dumpHistorySH, followTipSH]+ where+ fetchBlockSH = loggedUnary f (RPC :: RPC ChainSyncService "fetchBlock") fetchBlock logger+ dumpHistorySH = loggedUnary f (RPC :: RPC ChainSyncService "dumpHistory") dumpHistory logger+ followTipSH = loggedSStream f (RPC :: RPC ChainSyncService "followTip") followTip logger
+ src/Utxorpc/Watch.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Utxorpc.Watch (WatchHandlers (..), serviceHandlers) where++import Control.Monad.IO.Class (MonadIO)+import Network.GRPC.HTTP2.ProtoLens (RPC (RPC))+import Network.GRPC.Server (ServerStreamHandler, ServiceHandler)+import Proto.Utxorpc.V1alpha.Watch.Watch+import Utxorpc.Logged (UtxorpcServiceLogger, loggedSStream)++newtype WatchHandlers m a = WatchHandlers+ { watchTx :: ServerStreamHandler m WatchTxRequest WatchTxResponse a+ }++serviceHandlers ::+ (MonadIO m) =>+ Maybe (UtxorpcServiceLogger m) ->+ (forall x. m x -> IO x) ->+ WatchHandlers m b ->+ [ServiceHandler]+serviceHandlers logger f WatchHandlers {watchTx} =+ [watchTxSH]+ where+ watchTxSH = loggedSStream f (RPC :: RPC WatchService "watchTx") watchTx logger
+ test/logged_test.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Main (main) where++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT, tell)+import Data.List (foldl')+import Data.ProtoLens.Message (Message, defMessage)+import Data.UUID (UUID)+import Data.UUID.V4 (nextRandom)+import Network.GRPC.HTTP2.ProtoLens (RPC (RPC))+import Network.GRPC.Server (ServerStream (..), ServerStreamHandler, UnaryHandler)+import Proto.Utxorpc.V1alpha.Sync.Sync+import System.Directory (removeFile)+import System.IO (Handle, IOMode (..), hPutStr, readFile', withFile)+import Test.Hspec+import Utxorpc.Logged+ ( ReplyLogger,+ RequestLogger,+ ServerStreamEndLogger,+ ServerStreamLogger,+ UtxorpcServiceLogger (..),+ loggedSStreamHandler,+ loggedUnaryHandler,+ )++logFilePath :: String+logFilePath = "test/test-logs.txt"++mockRequestLogger :: (String -> IO ()) -> RequestLogger (WriterT String IO)+mockRequestLogger logF _ _ uuid msg = do+ lift . logF $ requestOut uuid msg+ tell $ requestOut uuid msg++requestOut :: (Show a) => UUID -> a -> String+requestOut uuid msg = "REQUEST_LOGGER: " ++ "[" ++ show uuid ++ "]" ++ show msg ++ "\n"++mockReplyLogger :: (String -> IO ()) -> ReplyLogger (WriterT String IO)+mockReplyLogger logF _ _ uuid msg = do+ lift . logF $ replyOut uuid msg+ tell $ replyOut uuid msg++replyOut :: (Show a) => UUID -> a -> String+replyOut uuid msg = "REPLY_LOGGER: [" ++ show uuid ++ "] " ++ show msg ++ "\n"++mockServerStreamLogger :: (String -> IO ()) -> ServerStreamLogger (WriterT String IO)+mockServerStreamLogger logF _ _ (uuid, index) _ = do+ lift . logF $ serverStreamOut (uuid, index)+ tell $ serverStreamOut (uuid, index)++serverStreamOut :: (UUID, Int) -> String+serverStreamOut (uuid, int) = "SERVER_STREAM_LOGGER: " ++ show (uuid, int) ++ "\n"++mockServerStreamEndLogger :: (String -> IO ()) -> ServerStreamEndLogger (WriterT String IO)+mockServerStreamEndLogger logF _ _ (uuid, index) = do+ lift . logF $ serverStreamEndOut (uuid, index)+ tell $ serverStreamEndOut (uuid, index)++serverStreamEndOut :: (UUID, Int) -> String+serverStreamEndOut (uuid, index) = "SERVER_STREAM_END_LOGGER: " ++ show (uuid, index) ++ "\n"++mockLogger :: (String -> IO ()) -> UtxorpcServiceLogger (WriterT String IO)+mockLogger logF =+ UtxorpcServiceLogger+ (mockRequestLogger logF)+ (mockReplyLogger logF)+ (mockServerStreamLogger logF)+ (mockServerStreamEndLogger logF)++mockUnaryHandler :: (Message o) => (String -> IO ()) -> UnaryHandler (WriterT String IO) i o+mockUnaryHandler logF _ _ = do+ lift $ logF unaryHandlerOut+ tell unaryHandlerOut+ return defMessage++unaryHandlerOut :: String+unaryHandlerOut = "UNARY_HANDLER\n"++unaryRpc :: RPC ChainSyncService "fetchBlock"+unaryRpc = RPC++unaryReq :: FetchBlockRequest+unaryReq = defMessage++type UnaryReply = FetchBlockResponse++mockSStreamHandler :: (Message o) => (String -> IO ()) -> ServerStreamHandler (WriterT String IO) i o Int+mockSStreamHandler logF _ _ = do+ lift $ logF generateStreamOut+ tell generateStreamOut+ return (0, stream)+ where+ stream = ServerStream $ \index ->+ if index > 3+ then do+ lift $ logF $ streamHandlerEndOut index+ tell $ streamHandlerEndOut index+ return Nothing+ else do+ lift $ logF $ streamHandlerOut index+ tell $ streamHandlerOut index+ return $ Just (index + 1, defMessage)++generateStreamOut :: String+generateStreamOut = "GENERATE_STREAM\n"++streamHandlerOut :: Int -> String+streamHandlerOut index = "STREAM_HANDLER " ++ show index ++ "\n"++streamHandlerEndOut :: Int -> String+streamHandlerEndOut index = "STREAM_HANDLER_END " ++ show index ++ "\n"++sStreamRpc :: RPC ChainSyncService "followTip"+sStreamRpc = RPC++type SStreamReq = FollowTipRequest++sStreamReq :: SStreamReq+sStreamReq = defMessage++type SStreamReply = FollowTipResponse++testUnary :: IO ()+testUnary = do+ uuid <- nextRandom+ (reply, _mState) <- withFile logFilePath WriteMode (runWriterT . handleReq)+ out <- readFile' logFilePath++ (loggedReply, loggedMState) <- withFile logFilePath WriteMode (runWriterT . handleReqLogged uuid)+ loggedOut <- readFile' logFilePath++ hspec $ describe "Unary Logging" $ do+ it "Logged reply should equal unlogged reply" $ do+ reply `shouldBe` loggedReply+ -- We know that the IO effects are accumulating, so if the WriterT state equals the IO effect,+ -- we know the monadic state was passed from one logger/handler to the next+ it "Monad state should accumulate" $ do+ loggedOut `shouldBe` loggedMState+ it "Execution should occur in the right order" $ do+ targetLoggedOut uuid out reply `shouldBe` loggedOut++ removeFile logFilePath+ where+ handleReq :: Handle -> WriterT String IO UnaryReply+ handleReq fileHandle = mockUnaryHandler (hPutStr fileHandle) undefined unaryReq++ handleReqLogged :: UUID -> Handle -> WriterT String IO UnaryReply+ handleReqLogged uuid fileHandle = loggedHandler uuid (hPutStr fileHandle) undefined unaryReq+ loggedHandler uuid logF = loggedUnaryHandler unaryRpc (mockUnaryHandler logF) uuid (mockLogger logF)++ targetLoggedOut uuid unloggedOut reply =+ requestOut uuid unaryReq ++ unloggedOut ++ replyOut uuid reply++testSStream :: IO ()+testSStream = do+ -- Run unlogged+ let withLogFile = withFile logFilePath WriteMode+ ((_streamStates, msgs), _monadState) <-+ withLogFile $ runWriterT . run . handlerWith+ _out <- readFile' logFilePath++ -- Run logged+ uuid <- nextRandom+ ((loggedStreamStates, loggedMsgs), loggedMonadState) <-+ withLogFile $ runWriterT . run . loggedHandlerWith uuid+ loggedOut <- readFile' logFilePath++ hspec $ describe "Stream Logging" $ do+ it "Logged messages should equal unlogged messages" $ do+ msgs `shouldBe` loggedMsgs+ -- We know that the IO effects are accumulating, so if the WriterT state equals the IO effect,+ -- we know the monadic state was passed from one logger/handler to the next+ it "Monad state should accumulate" $ do+ loggedOut `shouldBe` loggedMonadState+ it "Execution should occur in the right order" $ do+ targetLoggedOut uuid loggedStreamStates `shouldBe` loggedOut++ removeFile logFilePath+ where+ handlerWith ::+ Handle ->+ ServerStreamHandler (WriterT String IO) SStreamReq SStreamReply Int+ handlerWith = mockSStreamHandler . hPutStr++ loggedHandlerWith ::+ UUID ->+ Handle ->+ ServerStreamHandler (WriterT String IO) SStreamReq SStreamReply (Int, Int)+ loggedHandlerWith uuid h =+ loggedSStreamHandler+ sStreamRpc+ (mockSStreamHandler $ hPutStr h)+ uuid+ (mockLogger $ hPutStr h)++ run :: (Monad m) => ServerStreamHandler m SStreamReq SStreamReply a -> m ([a], [SStreamReply])+ run handler = do+ (initState, ServerStream {serverStreamNext}) <- handler undefined sStreamReq+ runStream serverStreamNext initState+ where+ runStream stream state = do+ next <- stream state+ case next of+ Just (state', msg) -> do+ (states, msgs) <- runStream stream state'+ return (state : states, msg : msgs)+ Nothing ->+ return ([], [])++ targetLoggedOut uuid loggedStreamStates =+ requestOut uuid unaryReq -- log request+ ++ generateStreamOut -- generate stream+ -- Output for all stream handling and logs+ ++ foldl' (\out streamState -> out ++ targetOut streamState) "" loggedStreamStates+ -- end of stream handler+ ++ streamHandlerEndOut (length loggedStreamStates)+ -- end of stream logger+ ++ serverStreamEndOut (uuid, length loggedStreamStates)+ where+ -- output for a single stream message+ targetOut (index, _) =+ streamHandlerOut index+ ++ serverStreamOut (uuid, index)++main :: IO ()+main = do+ testUnary+ testSStream
+ utxorpc-server.cabal view
@@ -0,0 +1,134 @@+cabal-version: 3.0++name: utxorpc-server+version: 0.0.1.0+synopsis: An SDK for UTxO RPC services.+description: This SDK includes helper functions for creating a UTxO RPC service with automated logging.+category: Network, Blockchain, Cardano+homepage: https://github.com/utxorpc/haskell-sdk#readme+bug-reports: https://github.com/utxorpc/haskell-sdk/issues+author: Dominic Mayhew+maintainer: dominic.j.mayhew@gmail.com+license: Apache-2.0+license-file: LICENSE+build-type: Simple++source-repository head+ type: git+ location: https://github.com/utxorpc/haskell-sdk++library+ exposed-modules:+ Utxorpc.Server+ other-modules:+ Utxorpc.Build+ Utxorpc.Submit+ Utxorpc.Sync+ Utxorpc.Watch+ 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-grpc-proto-lens < 0.2+ , http2-grpc-types >= 0.5.0.0 && < 0.6+ , utxorpc >= 0.0.3.0 && < 0.1+ , uuid < 1.4+ , wai < 3.3+ , warp < 3.5+ , warp-grpc < 0.5+ , warp-tls < 3.5+ default-language: Haskell2010++executable server-example+ main-is:+ Main.hs+ other-modules:+ BuildImpl+ KatipLogger+ EmptyHandlers+ SimpleLogger+ SubmitImpl+ SyncImpl+ WatchImpl+ 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+ , http2-grpc-types < 0.6+ , katip < 0.9+ , lens < 5.3+ , proto-lens < 0.8+ , time < 1.13+ , transformers < 0.7+ , unliftio < 0.3+ , utxorpc >= 0.0.3 && < 0.1+ , utxorpc-server+ , uuid < 1.4+ , wai < 3.3+ , warp < 3.5+ , warp-grpc < 0.5+ , warp-tls < 3.5+ default-language: Haskell2010++test-suite logged_test_server+ type:+ exitcode-stdio-1.0+ main-is:+ logged_test.hs+ other-modules:+ Utxorpc.Logged+ 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+ , directory >= 1.3.8 && < 1.4+ , http2-grpc-proto-lens < 0.2+ , http2-grpc-types < 0.6+ , hspec >= 2.11.7 && < 2.12+ , proto-lens < 0.8+ , transformers < 0.7+ , utxorpc >= 0.0.3 && < 0.1+ , uuid < 1.4+ , wai < 3.3+ , warp-grpc < 0.5+ default-language: Haskell2010