diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 040e4e39..5657729a 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -163,6 +163,7 @@ jobs: if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/./tutorials/metadata" >> cabal.project ; fi if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/./tutorials/monadstack" >> cabal.project ; fi if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/./tutorials/conduit" >> cabal.project ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/./tutorials/trailers-only" >> cabal.project ; fi cat cabal.project - name: sdist run: | @@ -190,6 +191,8 @@ jobs: echo "PKGDIR_monadstack_tutorial=${PKGDIR_monadstack_tutorial}" >> "$GITHUB_ENV" PKGDIR_conduit_tutorial="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/conduit-tutorial-[0-9.]*')" echo "PKGDIR_conduit_tutorial=${PKGDIR_conduit_tutorial}" >> "$GITHUB_ENV" + PKGDIR_trailers_only_tutorial="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/trailers-only-tutorial-[0-9.]*')" + echo "PKGDIR_trailers_only_tutorial=${PKGDIR_trailers_only_tutorial}" >> "$GITHUB_ENV" rm -f cabal.project cabal.project.local touch cabal.project touch cabal.project.local @@ -201,6 +204,7 @@ jobs: if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: ${PKGDIR_metadata_tutorial}" >> cabal.project ; fi if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: ${PKGDIR_monadstack_tutorial}" >> cabal.project ; fi if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: ${PKGDIR_conduit_tutorial}" >> cabal.project ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: ${PKGDIR_trailers_only_tutorial}" >> cabal.project ; fi echo "package grpc-spec" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project echo "package grapesy" >> cabal.project @@ -217,6 +221,8 @@ jobs: if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "package conduit-tutorial" >> cabal.project ; fi if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "package trailers-only-tutorial" >> cabal.project ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi cat >> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(basics-tutorial|conduit-tutorial|grapesy|grpc-spec|lowlevel-tutorial|metadata-tutorial|monadstack-tutorial|quickstart-tutorial|trailers-only-tutorial)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -294,6 +303,8 @@ jobs: if [ $((HCNUMVER < 91000)) -ne 0 ] ; then ${CABAL} -vnormal check ; fi if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_conduit_tutorial} || false ; fi if [ $((HCNUMVER < 91000)) -ne 0 ] ; then ${CABAL} -vnormal check ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_trailers_only_tutorial} || false ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then ${CABAL} -vnormal check ; fi - name: haddock run: | $CABAL v2-haddock --disable-documentation $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all diff --git a/cabal.project b/cabal.project index 9b01403f..7123e82b 100644 --- a/cabal.project +++ b/cabal.project @@ -7,6 +7,7 @@ packages: , ./tutorials/metadata , ./tutorials/monadstack , ./tutorials/conduit + , ./tutorials/trailers-only package grpc-spec tests: True diff --git a/cabal.project.ci b/cabal.project.ci index 724f7ea1..9ffcd013 100644 --- a/cabal.project.ci +++ b/cabal.project.ci @@ -7,6 +7,7 @@ packages: , ./tutorials/metadata , ./tutorials/monadstack , ./tutorials/conduit + , ./tutorials/trailers-only package grpc-spec tests: True @@ -37,6 +38,9 @@ package monadstack-tutorial package conduit-tutorial ghc-options: -Werror +package trailers-only-tutorial + ghc-options: -Werror + -- -- ghc 9.10 -- diff --git a/tutorials/trailers-only/LICENSE b/tutorials/trailers-only/LICENSE new file mode 100644 index 00000000..54362a91 --- /dev/null +++ b/tutorials/trailers-only/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2023-2024, Well-Typed LLP and Anduril Industries Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Well-Typed LLP, the name of Anduril + Industries Inc., nor the names of other contributors may be + used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/tutorials/trailers-only/README.md b/tutorials/trailers-only/README.md new file mode 100644 index 00000000..2040d49d --- /dev/null +++ b/tutorials/trailers-only/README.md @@ -0,0 +1,12 @@ +# Basics tutorial, taking advantage of the gRPC Trailers-Only case + +See `/tutorials/basics` for the more direct `grapesy` translation of the +[official Basics tutorial](https://grpc.io/docs/languages/python/basics/). + +In this tutorial we re-implement the server using the low-level API (similar to +what we did in `/tutorials/lowlevel`), but taking advantage of the Trailers-Only +case in `listFeatures`. + +We don't re-implement the client (you can run the client from +`tutorials/basics`). + diff --git a/tutorials/trailers-only/app/Server.hs b/tutorials/trailers-only/app/Server.hs new file mode 100644 index 00000000..549029fe --- /dev/null +++ b/tutorials/trailers-only/app/Server.hs @@ -0,0 +1,92 @@ +module Server (main) where + +import Control.Monad +import Data.IORef +import Data.Maybe (fromMaybe) +import Data.Time + +import Network.GRPC.Common +import Network.GRPC.Common.Protobuf +import Network.GRPC.Common.StreamElem qualified as StreamElem +import Network.GRPC.Server +import Network.GRPC.Server.Protobuf +import Network.GRPC.Server.Run +import Network.GRPC.Server.StreamType (Methods(..), fromMethods) + +import Proto.API.RouteGuide + +import RouteGuide + +{------------------------------------------------------------------------------- + Individual handlers +-------------------------------------------------------------------------------} + +getFeature :: DB -> Call (Protobuf RouteGuide "getFeature") -> IO () +getFeature db call = do + p <- recvFinalInput call + sendFinalOutput call ( + fromMaybe (defMessage & #location .~ p) (featureAt db p) + , NoMetadata + ) + +listFeatures :: DB -> Call (Protobuf RouteGuide "listFeatures") -> IO () +listFeatures db call = do + r <- recvFinalInput call + case featuresIn db r of + [] -> sendTrailersOnly call NoMetadata + ps -> StreamElem.forM_ ps NoMetadata (sendOutput call) + +recordRoute :: DB -> Call (Protobuf RouteGuide "recordRoute") -> IO () +recordRoute db call = do + start <- getCurrentTime + (ps, NoMetadata) <- StreamElem.collect (recvInput call) + stop <- getCurrentTime + sendFinalOutput call ( + summary db (stop `diffUTCTime` start) ps + , NoMetadata + ) + +routeChat :: Call (Protobuf RouteGuide "routeChat") -> IO () +routeChat call = do + st :: IORef Chat <- newIORef emptyChat + NoMetadata <- StreamElem.whileNext_ (recvInput call) $ \note -> do + prev <- atomicModifyIORef st $ \chat -> ( + recordNote note chat + , getNotes chat (note ^. #location) + ) + -- Can't use StreamElem.forM_ here: we don't want to send 'FinalElem' yet + forM_ prev $ sendNextOutput call + sendTrailers call NoMetadata + +{------------------------------------------------------------------------------- + Server top-level +-------------------------------------------------------------------------------} + +methods :: DB -> Methods IO (ProtobufMethodsOf RouteGuide) +methods db = + RawMethod (mkRpcHandler $ getFeature db) + $ RawMethod (mkRpcHandler $ listFeatures db) + $ RawMethod (mkRpcHandler $ recordRoute db) + $ RawMethod (mkRpcHandler $ routeChat ) + $ NoMoreMethods + + +-- Alternative way to define the handlers, avoiding 'fromMethods' +_handlers :: DB -> [SomeRpcHandler IO] +_handlers db = [ + someRpcHandler . mkRpcHandler $ getFeature db + , someRpcHandler . mkRpcHandler $ listFeatures db + , someRpcHandler . mkRpcHandler $ recordRoute db + , someRpcHandler . mkRpcHandler $ routeChat + ] + +main :: IO () +main = do + db <- getDB + runServerWithHandlers def config $ fromMethods (methods db) + where + config :: ServerConfig + config = ServerConfig { + serverInsecure = Just (InsecureConfig Nothing defaultInsecurePort) + , serverSecure = Nothing + } diff --git a/tutorials/trailers-only/trailers-only-tutorial.cabal b/tutorials/trailers-only/trailers-only-tutorial.cabal new file mode 100644 index 00000000..b820a5d0 --- /dev/null +++ b/tutorials/trailers-only/trailers-only-tutorial.cabal @@ -0,0 +1,44 @@ +cabal-version: 3.0 +name: trailers-only-tutorial +synopsis: gRPC basics tutorial for grapesy, taking advantage of + the gRPC Trailers-Only case. +version: 0.1.0 +license: BSD-3-Clause +license-file: LICENSE +author: Edsko de Vries +maintainer: edsko@well-typed.com +build-type: Simple +tested-with: GHC==8.10.7 + , GHC==9.2.8 + , GHC==9.4.8 + , GHC==9.6.6 + , GHC==9.8.2 + +common lang + build-depends: base >= 4.14 && < 5 + default-language: Haskell2010 + ghc-options: -Wall + + if impl(ghc >= 9.0) + ghc-options: + -Wunused-packages + + default-extensions: + DataKinds + ImportQualifiedPost + NumericUnderscores + OverloadedLabels + OverloadedStrings + ScopedTypeVariables + TypeApplications + +executable route_guide_server + import: lang + main-is: Server.hs + hs-source-dirs: app + ghc-options: -main-is Server + build-depends: basics-tutorial + + build-depends: + , grapesy >= 0.1 && < 0.2 + , time >= 1.9 && < 1.13