Basics tutorial

.github/workflows/haskell-ci.yml

@@ -157,6 +157,7 @@ jobs:
           touch cabal.project
           echo "packages: $GITHUB_WORKSPACE/source/./grapesy" >> cabal.project
           if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/./tutorials/quickstart" >> cabal.project ; fi
+          if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/./tutorials/basics" >> cabal.project ; fi
           cat cabal.project
       - name: sdist
         run: |
@@ -172,15 +173,20 @@ jobs:
           echo "PKGDIR_grapesy=${PKGDIR_grapesy}" >> "$GITHUB_ENV"
           PKGDIR_quickstart="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/quickstart-[0-9.]*')"
           echo "PKGDIR_quickstart=${PKGDIR_quickstart}" >> "$GITHUB_ENV"
+          PKGDIR_basics="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/basics-[0-9.]*')"
+          echo "PKGDIR_basics=${PKGDIR_basics}" >> "$GITHUB_ENV"
           rm -f cabal.project cabal.project.local
           touch cabal.project
           touch cabal.project.local
           echo "packages: ${PKGDIR_grapesy}" >> cabal.project
           if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: ${PKGDIR_quickstart}" >> cabal.project ; fi
+          if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: ${PKGDIR_basics}" >> cabal.project ; fi
           echo "package grapesy" >> cabal.project
           echo "    ghc-options: -Werror=missing-methods" >> cabal.project
           if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "package quickstart" >> 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 basics" >> 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
@@ -190,7 +196,7 @@ jobs:
             benchmarks: True
             flags:      +build-demo +build-stress-test +snappy
           EOF
-          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(grapesy|quickstart)$/; }' >> cabal.project.local
+          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(basics|grapesy|quickstart)$/; }' >> cabal.project.local
           cat cabal.project
           cat cabal.project.local
       - name: dump install plan
@@ -222,6 +228,8 @@ jobs:
           ${CABAL} -vnormal check
           if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_quickstart} || false ; fi
           if [ $((HCNUMVER < 91000)) -ne 0 ] ; then ${CABAL} -vnormal check ; fi
+          if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_basics} || 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

cabal.project

@@ -1,4 +1,4 @@
-packages: ./grapesy, ./tutorials/quickstart
+packages: ./grapesy, ./tutorials/quickstart, ./tutorials/basics
 
 package grapesy
   tests: True

grapesy/src/Network/GRPC/Common/NextElem.hs

@@ -10,6 +10,7 @@ module Network.GRPC.Common.NextElem (
     NextElem(..)
     -- * API
   , mapM_
+  , forM_
   , collect
   , whileNext_
   , toStreamElem
@@ -40,6 +41,9 @@ mapM_ f = go
     go []     = f NoNextElem
     go (x:xs) = f (NextElem x) >> go xs
 
+forM_ :: Monad m => [a] -> (NextElem a -> m ()) -> m ()
+forM_ = flip mapM_
+
 collect :: forall m a. Monad m => m (NextElem a) -> m [a]
 collect f = go []
   where

tutorials/basics/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.

tutorials/basics/Setup.hs

@@ -0,0 +1,3 @@
+import Data.ProtoLens.Setup
+
+main = defaultMainGeneratingProtos "proto"

tutorials/basics/app/Client.hs

@@ -0,0 +1,102 @@
+module Client (main) where
+
+import Control.Concurrent
+import Control.Monad
+import Data.Int
+import Data.Text (Text)
+import System.Random
+
+import Network.GRPC.Client
+import Network.GRPC.Client.StreamType.IO
+import Network.GRPC.Common
+import Network.GRPC.Common.NextElem qualified as NextElem
+import Network.GRPC.Common.Protobuf
+
+import RouteGuide
+
+import Proto.API.RouteGuide
+
+{-------------------------------------------------------------------------------
+  Call each of the methods of the RouteGuide service
+-------------------------------------------------------------------------------}
+
+getFeature :: Connection -> IO ()
+getFeature conn = do
+    let req = defMessage
+                & #latitude  .~  409146138
+                & #longitude .~ -746188906
+    resp <- nonStreaming conn (rpc @(Protobuf RouteGuide "getFeature")) req
+    print resp
+
+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
+    serverStreaming conn (rpc @(Protobuf RouteGuide "listFeatures")) req $ \recv ->
+      NextElem.whileNext_ recv print
+
+recordRoute :: Connection -> IO ()
+recordRoute conn = do
+    db   <- getDB
+    resp <- clientStreaming_ conn (rpc @(Protobuf RouteGuide "recordRoute")) $ \send -> 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 NoNextElem
+    print resp
+
+routeChat :: Connection -> IO ()
+routeChat conn = do
+    biDiStreaming conn (rpc @(Protobuf RouteGuide "routeChat")) $ \send recv -> do
+      NextElem.forM_ messages send
+      NextElem.whileNext_ recv print
+  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 "-------------- GetFeature --------------"
+      getFeature conn
+
+      putStrLn "-------------- ListFeatures --------------"
+      listFeatures conn
+
+      putStrLn "-------------- RecordRoute --------------"
+      recordRoute conn
+
+      putStrLn "-------------- RouteChat --------------"
+      routeChat conn
+  where
+    server :: Server
+    server = ServerInsecure $ Address "127.0.0.1" defaultInsecurePort Nothing

tutorials/basics/app/Server.hs

@@ -0,0 +1,81 @@
+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.Server.Protobuf
+import Network.GRPC.Server.Run
+import Network.GRPC.Server.StreamType
+import Network.GRPC.Common.NextElem qualified as NextElem
+
+import Proto.API.RouteGuide
+
+import RouteGuide
+
+{-------------------------------------------------------------------------------
+  Individual handlers
+-------------------------------------------------------------------------------}
+
+getFeature :: DB -> Proto Point -> IO (Proto Feature)
+getFeature db p =
+    return $ fromMaybe (defMessage & #location .~ p) (featureAt db p)
+
+listFeatures ::
+     DB
+  -> Proto Rectangle
+  -> (NextElem (Proto Feature) -> IO ())
+  -> IO ()
+listFeatures db r send =
+    NextElem.forM_ (featuresIn db r) send
+
+recordRoute ::
+     DB
+  -> IO (NextElem (Proto Point))
+  -> IO (Proto RouteSummary)
+recordRoute db recv = do
+    start <- getCurrentTime
+    ps    <- NextElem.collect recv
+    stop  <- getCurrentTime
+    return $ summary db (stop `diffUTCTime` start) ps
+
+routeChat ::
+     IO (NextElem (Proto RouteNote))
+  -> (NextElem (Proto RouteNote) -> IO ())
+  -> IO ()
+routeChat recv send = do
+    st :: IORef Chat <- newIORef emptyChat
+    NextElem.whileNext_ recv $ \note -> do
+      prev <- atomicModifyIORef st $ \chat -> (
+          recordNote note chat
+        , getNotes chat (note ^. #location)
+        )
+      -- Can't use NextElem.forM_ here: we don't want to send 'NoNextElem' yet
+      forM_ prev $ send . NextElem
+    send NoNextElem
+
+{-------------------------------------------------------------------------------
+  Server top-level
+-------------------------------------------------------------------------------}
+
+methods :: DB -> Methods IO (ProtobufMethodsOf RouteGuide)
+methods db =
+      Method (mkNonStreaming    $ getFeature   db)
+    $ Method (mkServerStreaming $ listFeatures db)
+    $ Method (mkClientStreaming $ recordRoute  db)
+    $ Method (mkBiDiStreaming   $ routeChat      )
+    $ NoMoreMethods
+
+main :: IO ()
+main = do
+    db <- getDB
+    runServerWithHandlers def config $ fromMethods (methods db)
+  where
+    config :: ServerConfig
+    config = ServerConfig {
+          serverInsecure = Just (InsecureConfig Nothing defaultInsecurePort)
+        , serverSecure   = Nothing
+        }

tutorials/basics/basics.cabal

@@ -0,0 +1,98 @@
+cabal-version:      3.0
+name:               basics
+synopsis:           gRPC basics tutorial for grapesy
+version:            0.1.0
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Edsko de Vries
+maintainer:         edsko@well-typed.com
+build-type:         Custom
+extra-source-files: proto/route_guide.proto
+data-dir:           data
+data-files:         route_guide_db.json
+tested-with:        GHC==8.10.7
+                  , GHC==9.2.8
+                  , GHC==9.4.8
+                  , GHC==9.6.4
+                  , GHC==9.8.2
+
+custom-setup
+  setup-depends:
+      base             >= 4.14 && < 5
+    , Cabal            >= 3.0  && < 4
+    , proto-lens-setup >= 0.4  && < 0.5
+
+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:
+      BangPatterns
+      DataKinds
+      FlexibleInstances
+      ImportQualifiedPost
+      LambdaCase
+      NumericUnderscores
+      OverloadedLabels
+      OverloadedStrings
+      ScopedTypeVariables
+      TypeApplications
+      TypeFamilies
+
+library
+  import:             lang
+  hs-source-dirs:     src
+  build-tool-depends: proto-lens-protoc:proto-lens-protoc
+
+  build-depends:
+    , aeson              >= 1.5 && < 2.3
+    , containers         >= 0.6 && < 0.8
+    , grapesy            >= 0.1 && < 0.2
+    , proto-lens-runtime >= 0.7 && < 0.8
+    , time               >= 1.9 && < 1.13
+  exposed-modules:
+      RouteGuide
+      Proto.API.RouteGuide
+  other-modules:
+      Proto.RouteGuide
+      Paths_basics
+  autogen-modules:
+      Proto.RouteGuide
+      Paths_basics
+
+executable route_guide_server
+  import:          lang
+  main-is:         Server.hs
+  hs-source-dirs:  app
+  ghc-options:     -main-is Server
+
+  build-depends:
+      -- internal
+    , basics
+  build-depends:
+      -- inherited
+    , grapesy
+    , time
+
+executable route_guide_client
+  import:         lang
+  main-is:        Client.hs
+  hs-source-dirs: app
+  ghc-options:    -main-is Client
+
+  build-depends:
+      -- internal
+    , basics
+  build-depends:
+      -- inherited
+    , grapesy
+  build-depends:
+      -- additional
+    , random >= 1.2 && < 1.3
+    , text   >= 1.2 && < 2.2
+

tutorials/basics/data/README.md

@@ -0,0 +1,4 @@
+# RouteGuide features database
+
+This is a copy of the database from the official gRPC repo at
+http://github.com/grpc/grpc.