diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 5d116696..040e4e39 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -162,6 +162,7 @@ jobs: if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/./tutorials/lowlevel" >> cabal.project ; fi 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 cat cabal.project - name: sdist run: | @@ -187,6 +188,8 @@ jobs: echo "PKGDIR_metadata_tutorial=${PKGDIR_metadata_tutorial}" >> "$GITHUB_ENV" PKGDIR_monadstack_tutorial="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/monadstack-tutorial-[0-9.]*')" 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" rm -f cabal.project cabal.project.local touch cabal.project touch cabal.project.local @@ -197,6 +200,7 @@ jobs: if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: ${PKGDIR_lowlevel_tutorial}" >> cabal.project ; fi 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 echo "package grpc-spec" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project echo "package grapesy" >> cabal.project @@ -211,6 +215,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 monadstack-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 conduit-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)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -283,6 +292,8 @@ jobs: if [ $((HCNUMVER < 91000)) -ne 0 ] ; then ${CABAL} -vnormal check ; fi if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_monadstack_tutorial} || false ; fi 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 - 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 3ca8013c..9b01403f 100644 --- a/cabal.project +++ b/cabal.project @@ -6,6 +6,7 @@ packages: , ./tutorials/lowlevel , ./tutorials/metadata , ./tutorials/monadstack + , ./tutorials/conduit package grpc-spec tests: True diff --git a/cabal.project.ci b/cabal.project.ci index 66e30839..724f7ea1 100644 --- a/cabal.project.ci +++ b/cabal.project.ci @@ -6,6 +6,7 @@ packages: , ./tutorials/lowlevel , ./tutorials/metadata , ./tutorials/monadstack + , ./tutorials/conduit package grpc-spec tests: True @@ -18,19 +19,22 @@ package grapesy flags: +build-demo +build-stress-test ghc-options: -Werror -package quickstart +package quickstart-tutorial ghc-options: -Werror -package basics +package basics-tutorial ghc-options: -Werror -package lowlevel +package lowlevel-tutorial ghc-options: -Werror -package metadata +package metadata-tutorial ghc-options: -Werror -package monadstack +package monadstack-tutorial + ghc-options: -Werror + +package conduit-tutorial ghc-options: -Werror -- diff --git a/tutorials/basics/app/Client.hs b/tutorials/basics/app/Client.hs index f4afd86a..9a4db0c8 100644 --- a/tutorials/basics/app/Client.hs +++ b/tutorials/basics/app/Client.hs @@ -49,8 +49,8 @@ recordRoute conn = do replicateM_ 10 $ do i <- randomRIO (0, length db - 1) let p = (db !! i) ^. #location - send $ NextElem p threadDelay 500_000 -- 0.5 seconds + send $ NextElem p send NoNextElem print resp diff --git a/tutorials/conduit/LICENSE b/tutorials/conduit/LICENSE new file mode 100644 index 00000000..54362a91 --- /dev/null +++ b/tutorials/conduit/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/conduit/README.md b/tutorials/conduit/README.md new file mode 100644 index 00000000..0764ce4c --- /dev/null +++ b/tutorials/conduit/README.md @@ -0,0 +1,7 @@ +# Basics tutorial using the low-level API + +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 client using the +`grapesy` [`conduit`](https://hackage.haskell.org/package/conduit) API. \ No newline at end of file diff --git a/tutorials/conduit/app/Client.hs b/tutorials/conduit/app/Client.hs new file mode 100644 index 00000000..d5a19d82 --- /dev/null +++ b/tutorials/conduit/app/Client.hs @@ -0,0 +1,105 @@ +module Client (main) where + +import Conduit +import Control.Concurrent +import Data.Conduit.List +import Data.Int +import Data.Text (Text) +import System.Random + +import Network.GRPC.Client +import Network.GRPC.Client.StreamType.Conduit +import Network.GRPC.Common +import Network.GRPC.Common.Protobuf + +import RouteGuide + +import Proto.API.RouteGuide + +{------------------------------------------------------------------------------- + Call each of the methods of the RouteGuide service +-------------------------------------------------------------------------------} + +listFeatures :: Connection -> IO () +listFeatures conn = do + let lo = defMessage + & #latitude .~ 400000000 + & #longitude .~ -750000000 + hi = defMessage + & #latitude .~ 420000000 + & #longitude .~ -730000000 + req = defMessage + & #lo .~ lo + & #hi .~ hi + + let sink :: ConduitT (Proto Feature) Void IO () + sink = mapM_C print + + serverStreaming conn (rpc @(Protobuf RouteGuide "listFeatures")) req $ \source -> + runConduit $ source .| sink + +recordRoute :: Connection -> IO () +recordRoute conn = do + db <- getDB + + let source :: ConduitT () (Proto Point) IO () + source = replicateMC 10 $ do + i <- randomRIO (0, length db - 1) + let p = (db !! i) ^. #location + threadDelay 500_000 -- 0.5 seconds + return p + + resp <- clientStreaming_ conn (rpc @(Protobuf RouteGuide "recordRoute")) $ \sink -> + runConduit $ source .| sink + print resp + +routeChat :: Connection -> IO () +routeChat conn = do + + let clientSource :: ConduitT () (Proto RouteNote) IO () + clientSource = sourceList messages + + clientSink :: ConduitT (Proto RouteNote) Void IO () + clientSink = mapM_C print + + biDiStreaming conn (rpc @(Protobuf RouteGuide "routeChat")) $ \serverSink serverSource -> do + runConduit $ clientSource .| serverSink + runConduit $ serverSource .| clientSink + where + messages :: [Proto RouteNote] + messages = [ + makeRouteNote "First message" 0 0 + , makeRouteNote "Second message" 0 1 + , makeRouteNote "Third message" 1 0 + , makeRouteNote "Fourth message" 0 0 + , makeRouteNote "Fifth message" 1 0 + ] + + makeRouteNote :: Text -> Int32 -> Int32 -> Proto RouteNote + makeRouteNote message latitude longitude = + let location = + defMessage + & #latitude .~ latitude + & #longitude .~ longitude + in defMessage + & #message .~ message + & #location .~ location + +{------------------------------------------------------------------------------- + Main application +-------------------------------------------------------------------------------} + +main :: IO () +main = + withConnection def server $ \conn -> do + putStrLn "-------------- ListFeatures --------------" + listFeatures conn + + putStrLn "-------------- RecordRoute --------------" + recordRoute conn + + putStrLn "-------------- RouteChat --------------" + routeChat conn + where + server :: Server + server = ServerInsecure $ Address "127.0.0.1" defaultInsecurePort Nothing diff --git a/tutorials/conduit/conduit-tutorial.cabal b/tutorials/conduit/conduit-tutorial.cabal new file mode 100644 index 00000000..980a7ecd --- /dev/null +++ b/tutorials/conduit/conduit-tutorial.cabal @@ -0,0 +1,43 @@ +cabal-version: 3.0 +name: conduit-tutorial +synopsis: gRPC basics tutorial for grapesy, using conduits +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 + NumericUnderscores + OverloadedLabels + OverloadedStrings + TypeApplications + +executable route_guide_client + import: lang + main-is: Client.hs + hs-source-dirs: app + ghc-options: -main-is Client + build-depends: basics-tutorial + + build-depends: + , conduit >= 1.3 && < 1.4 + , grapesy >= 0.1 && < 0.2 + , random >= 1.2 && < 1.3 + , text >= 1.2 && < 2.2 diff --git a/tutorials/lowlevel/app/Client.hs b/tutorials/lowlevel/app/Client.hs index 67bed545..4e1af5f4 100644 --- a/tutorials/lowlevel/app/Client.hs +++ b/tutorials/lowlevel/app/Client.hs @@ -51,8 +51,8 @@ recordRoute conn = do replicateM_ 10 $ do i <- randomRIO (0, length db - 1) let p = (db !! i) ^. #location - sendNextInput call p threadDelay 500_000 -- 0.5 seconds + sendNextInput call p sendEndOfInput call (resp, NoMetadata) <- recvFinalOutput call print resp diff --git a/tutorials/monadstack/app/Client.hs b/tutorials/monadstack/app/Client.hs index 018a66f5..1a5655b3 100644 --- a/tutorials/monadstack/app/Client.hs +++ b/tutorials/monadstack/app/Client.hs @@ -81,8 +81,8 @@ recordRoute = do replicateM_ 10 $ do i <- randomRIO (0, length db - 1) let p = (db !! i) ^. #location - send $ NextElem p threadDelay 500_000 -- 0.5 seconds + send $ NextElem p send NoNextElem liftIO $ print resp