Conduit tutorial

well-typed · Oct 25, 2024 · 94dead4 · 94dead4
1 parent fddd0ec
commit 94dead4
Show file tree

Hide file tree

Showing 10 changed files with 216 additions and 14 deletions.
diff --git 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 <<EOF
           allow-newer: proto-lens:base
           allow-newer: proto-lens-runtime:base
@@ -226,22 +232,25 @@ jobs:
             flags:       +build-demo +build-stress-test 
             ghc-options: -Werror
 
-          package quickstart
+          package quickstart-tutorial
+            ghc-options: -Werror
+
+          package basics-tutorial
             ghc-options: -Werror
 
-          package basics
+          package lowlevel-tutorial
             ghc-options: -Werror
 
-          package lowlevel
+          package metadata-tutorial
             ghc-options: -Werror
 
-          package metadata
+          package monadstack-tutorial
             ghc-options: -Werror
 
-          package monadstack
+          package conduit-tutorial
             ghc-options: -Werror
           EOF
-          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(basics-tutorial|grapesy|grpc-spec|lowlevel-tutorial|metadata-tutorial|monadstack-tutorial|quickstart-tutorial)$/; }' >> 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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.
diff --git a/tutorials/conduit/app/Client.hs 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
@@ -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:         [email protected]
+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
@@ -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
@@ -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