diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 1065e2b..c52e452 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.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 <> 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 diff --git a/cabal.project b/cabal.project index 75a04e4..d389d10 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ -packages: ./grapesy, ./tutorials/quickstart +packages: ./grapesy, ./tutorials/quickstart, ./tutorials/basics package grapesy tests: True diff --git a/grapesy/src/Network/GRPC/Common/NextElem.hs b/grapesy/src/Network/GRPC/Common/NextElem.hs index ae561d3..890dafb 100644 --- a/grapesy/src/Network/GRPC/Common/NextElem.hs +++ b/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 diff --git a/tutorials/basics/LICENSE b/tutorials/basics/LICENSE new file mode 100644 index 0000000..54362a9 --- /dev/null +++ b/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. diff --git a/tutorials/basics/Setup.hs b/tutorials/basics/Setup.hs new file mode 100644 index 0000000..bf45b62 --- /dev/null +++ b/tutorials/basics/Setup.hs @@ -0,0 +1,3 @@ +import Data.ProtoLens.Setup + +main = defaultMainGeneratingProtos "proto" \ No newline at end of file diff --git a/tutorials/basics/app/Client.hs b/tutorials/basics/app/Client.hs new file mode 100644 index 0000000..f4afd86 --- /dev/null +++ b/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 diff --git a/tutorials/basics/app/Server.hs b/tutorials/basics/app/Server.hs new file mode 100644 index 0000000..c699586 --- /dev/null +++ b/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 + } diff --git a/tutorials/basics/basics.cabal b/tutorials/basics/basics.cabal new file mode 100644 index 0000000..5aa8675 --- /dev/null +++ b/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 + diff --git a/tutorials/basics/data/README.md b/tutorials/basics/data/README.md new file mode 100644 index 0000000..9c51a78 --- /dev/null +++ b/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. diff --git a/tutorials/basics/data/route_guide_db.json b/tutorials/basics/data/route_guide_db.json new file mode 100644 index 0000000..9d6a980 --- /dev/null +++ b/tutorials/basics/data/route_guide_db.json @@ -0,0 +1,601 @@ +[{ + "location": { + "latitude": 407838351, + "longitude": -746143763 + }, + "name": "Patriots Path, Mendham, NJ 07945, USA" +}, { + "location": { + "latitude": 408122808, + "longitude": -743999179 + }, + "name": "101 New Jersey 10, Whippany, NJ 07981, USA" +}, { + "location": { + "latitude": 413628156, + "longitude": -749015468 + }, + "name": "U.S. 6, Shohola, PA 18458, USA" +}, { + "location": { + "latitude": 419999544, + "longitude": -740371136 + }, + "name": "5 Conners Road, Kingston, NY 12401, USA" +}, { + "location": { + "latitude": 414008389, + "longitude": -743951297 + }, + "name": "Mid Hudson Psychiatric Center, New Hampton, NY 10958, USA" +}, { + "location": { + "latitude": 419611318, + "longitude": -746524769 + }, + "name": "287 Flugertown Road, Livingston Manor, NY 12758, USA" +}, { + "location": { + "latitude": 406109563, + "longitude": -742186778 + }, + "name": "4001 Tremley Point Road, Linden, NJ 07036, USA" +}, { + "location": { + "latitude": 416802456, + "longitude": -742370183 + }, + "name": "352 South Mountain Road, Wallkill, NY 12589, USA" +}, { + "location": { + "latitude": 412950425, + "longitude": -741077389 + }, + "name": "Bailey Turn Road, Harriman, NY 10926, USA" +}, { + "location": { + "latitude": 412144655, + "longitude": -743949739 + }, + "name": "193-199 Wawayanda Road, Hewitt, NJ 07421, USA" +}, { + "location": { + "latitude": 415736605, + "longitude": -742847522 + }, + "name": "406-496 Ward Avenue, Pine Bush, NY 12566, USA" +}, { + "location": { + "latitude": 413843930, + "longitude": -740501726 + }, + "name": "162 Merrill Road, Highland Mills, NY 10930, USA" +}, { + "location": { + "latitude": 410873075, + "longitude": -744459023 + }, + "name": "Clinton Road, West Milford, NJ 07480, USA" +}, { + "location": { + "latitude": 412346009, + "longitude": -744026814 + }, + "name": "16 Old Brook Lane, Warwick, NY 10990, USA" +}, { + "location": { + "latitude": 402948455, + "longitude": -747903913 + }, + "name": "3 Drake Lane, Pennington, NJ 08534, USA" +}, { + "location": { + "latitude": 406337092, + "longitude": -740122226 + }, + "name": "6324 8th Avenue, Brooklyn, NY 11220, USA" +}, { + "location": { + "latitude": 406421967, + "longitude": -747727624 + }, + "name": "1 Merck Access Road, Whitehouse Station, NJ 08889, USA" +}, { + "location": { + "latitude": 416318082, + "longitude": -749677716 + }, + "name": "78-98 Schalck Road, Narrowsburg, NY 12764, USA" +}, { + "location": { + "latitude": 415301720, + "longitude": -748416257 + }, + "name": "282 Lakeview Drive Road, Highland Lake, NY 12743, USA" +}, { + "location": { + "latitude": 402647019, + "longitude": -747071791 + }, + "name": "330 Evelyn Avenue, Hamilton Township, NJ 08619, USA" +}, { + "location": { + "latitude": 412567807, + "longitude": -741058078 + }, + "name": "New York State Reference Route 987E, Southfields, NY 10975, USA" +}, { + "location": { + "latitude": 416855156, + "longitude": -744420597 + }, + "name": "103-271 Tempaloni Road, Ellenville, NY 12428, USA" +}, { + "location": { + "latitude": 404663628, + "longitude": -744820157 + }, + "name": "1300 Airport Road, North Brunswick Township, NJ 08902, USA" +}, { + "location": { + "latitude": 407113723, + "longitude": -749746483 + }, + "name": "" +}, { + "location": { + "latitude": 402133926, + "longitude": -743613249 + }, + "name": "" +}, { + "location": { + "latitude": 400273442, + "longitude": -741220915 + }, + "name": "" +}, { + "location": { + "latitude": 411236786, + "longitude": -744070769 + }, + "name": "" +}, { + "location": { + "latitude": 411633782, + "longitude": -746784970 + }, + "name": "211-225 Plains Road, Augusta, NJ 07822, USA" +}, { + "location": { + "latitude": 415830701, + "longitude": -742952812 + }, + "name": "" +}, { + "location": { + "latitude": 413447164, + "longitude": -748712898 + }, + "name": "165 Pedersen Ridge Road, Milford, PA 18337, USA" +}, { + "location": { + "latitude": 405047245, + "longitude": -749800722 + }, + "name": "100-122 Locktown Road, Frenchtown, NJ 08825, USA" +}, { + "location": { + "latitude": 418858923, + "longitude": -746156790 + }, + "name": "" +}, { + "location": { + "latitude": 417951888, + "longitude": -748484944 + }, + "name": "650-652 Willi Hill Road, Swan Lake, NY 12783, USA" +}, { + "location": { + "latitude": 407033786, + "longitude": -743977337 + }, + "name": "26 East 3rd Street, New Providence, NJ 07974, USA" +}, { + "location": { + "latitude": 417548014, + "longitude": -740075041 + }, + "name": "" +}, { + "location": { + "latitude": 410395868, + "longitude": -744972325 + }, + "name": "" +}, { + "location": { + "latitude": 404615353, + "longitude": -745129803 + }, + "name": "" +}, { + "location": { + "latitude": 406589790, + "longitude": -743560121 + }, + "name": "611 Lawrence Avenue, Westfield, NJ 07090, USA" +}, { + "location": { + "latitude": 414653148, + "longitude": -740477477 + }, + "name": "18 Lannis Avenue, New Windsor, NY 12553, USA" +}, { + "location": { + "latitude": 405957808, + "longitude": -743255336 + }, + "name": "82-104 Amherst Avenue, Colonia, NJ 07067, USA" +}, { + "location": { + "latitude": 411733589, + "longitude": -741648093 + }, + "name": "170 Seven Lakes Drive, Sloatsburg, NY 10974, USA" +}, { + "location": { + "latitude": 412676291, + "longitude": -742606606 + }, + "name": "1270 Lakes Road, Monroe, NY 10950, USA" +}, { + "location": { + "latitude": 409224445, + "longitude": -748286738 + }, + "name": "509-535 Alphano Road, Great Meadows, NJ 07838, USA" +}, { + "location": { + "latitude": 406523420, + "longitude": -742135517 + }, + "name": "652 Garden Street, Elizabeth, NJ 07202, USA" +}, { + "location": { + "latitude": 401827388, + "longitude": -740294537 + }, + "name": "349 Sea Spray Court, Neptune City, NJ 07753, USA" +}, { + "location": { + "latitude": 410564152, + "longitude": -743685054 + }, + "name": "13-17 Stanley Street, West Milford, NJ 07480, USA" +}, { + "location": { + "latitude": 408472324, + "longitude": -740726046 + }, + "name": "47 Industrial Avenue, Teterboro, NJ 07608, USA" +}, { + "location": { + "latitude": 412452168, + "longitude": -740214052 + }, + "name": "5 White Oak Lane, Stony Point, NY 10980, USA" +}, { + "location": { + "latitude": 409146138, + "longitude": -746188906 + }, + "name": "Berkshire Valley Management Area Trail, Jefferson, NJ, USA" +}, { + "location": { + "latitude": 404701380, + "longitude": -744781745 + }, + "name": "1007 Jersey Avenue, New Brunswick, NJ 08901, USA" +}, { + "location": { + "latitude": 409642566, + "longitude": -746017679 + }, + "name": "6 East Emerald Isle Drive, Lake Hopatcong, NJ 07849, USA" +}, { + "location": { + "latitude": 408031728, + "longitude": -748645385 + }, + "name": "1358-1474 New Jersey 57, Port Murray, NJ 07865, USA" +}, { + "location": { + "latitude": 413700272, + "longitude": -742135189 + }, + "name": "367 Prospect Road, Chester, NY 10918, USA" +}, { + "location": { + "latitude": 404310607, + "longitude": -740282632 + }, + "name": "10 Simon Lake Drive, Atlantic Highlands, NJ 07716, USA" +}, { + "location": { + "latitude": 409319800, + "longitude": -746201391 + }, + "name": "11 Ward Street, Mount Arlington, NJ 07856, USA" +}, { + "location": { + "latitude": 406685311, + "longitude": -742108603 + }, + "name": "300-398 Jefferson Avenue, Elizabeth, NJ 07201, USA" +}, { + "location": { + "latitude": 419018117, + "longitude": -749142781 + }, + "name": "43 Dreher Road, Roscoe, NY 12776, USA" +}, { + "location": { + "latitude": 412856162, + "longitude": -745148837 + }, + "name": "Swan Street, Pine Island, NY 10969, USA" +}, { + "location": { + "latitude": 416560744, + "longitude": -746721964 + }, + "name": "66 Pleasantview Avenue, Monticello, NY 12701, USA" +}, { + "location": { + "latitude": 405314270, + "longitude": -749836354 + }, + "name": "" +}, { + "location": { + "latitude": 414219548, + "longitude": -743327440 + }, + "name": "" +}, { + "location": { + "latitude": 415534177, + "longitude": -742900616 + }, + "name": "565 Winding Hills Road, Montgomery, NY 12549, USA" +}, { + "location": { + "latitude": 406898530, + "longitude": -749127080 + }, + "name": "231 Rocky Run Road, Glen Gardner, NJ 08826, USA" +}, { + "location": { + "latitude": 407586880, + "longitude": -741670168 + }, + "name": "100 Mount Pleasant Avenue, Newark, NJ 07104, USA" +}, { + "location": { + "latitude": 400106455, + "longitude": -742870190 + }, + "name": "517-521 Huntington Drive, Manchester Township, NJ 08759, USA" +}, { + "location": { + "latitude": 400066188, + "longitude": -746793294 + }, + "name": "" +}, { + "location": { + "latitude": 418803880, + "longitude": -744102673 + }, + "name": "40 Mountain Road, Napanoch, NY 12458, USA" +}, { + "location": { + "latitude": 414204288, + "longitude": -747895140 + }, + "name": "" +}, { + "location": { + "latitude": 414777405, + "longitude": -740615601 + }, + "name": "" +}, { + "location": { + "latitude": 415464475, + "longitude": -747175374 + }, + "name": "48 North Road, Forestburgh, NY 12777, USA" +}, { + "location": { + "latitude": 404062378, + "longitude": -746376177 + }, + "name": "" +}, { + "location": { + "latitude": 405688272, + "longitude": -749285130 + }, + "name": "" +}, { + "location": { + "latitude": 400342070, + "longitude": -748788996 + }, + "name": "" +}, { + "location": { + "latitude": 401809022, + "longitude": -744157964 + }, + "name": "" +}, { + "location": { + "latitude": 404226644, + "longitude": -740517141 + }, + "name": "9 Thompson Avenue, Leonardo, NJ 07737, USA" +}, { + "location": { + "latitude": 410322033, + "longitude": -747871659 + }, + "name": "" +}, { + "location": { + "latitude": 407100674, + "longitude": -747742727 + }, + "name": "" +}, { + "location": { + "latitude": 418811433, + "longitude": -741718005 + }, + "name": "213 Bush Road, Stone Ridge, NY 12484, USA" +}, { + "location": { + "latitude": 415034302, + "longitude": -743850945 + }, + "name": "" +}, { + "location": { + "latitude": 411349992, + "longitude": -743694161 + }, + "name": "" +}, { + "location": { + "latitude": 404839914, + "longitude": -744759616 + }, + "name": "1-17 Bergen Court, New Brunswick, NJ 08901, USA" +}, { + "location": { + "latitude": 414638017, + "longitude": -745957854 + }, + "name": "35 Oakland Valley Road, Cuddebackville, NY 12729, USA" +}, { + "location": { + "latitude": 412127800, + "longitude": -740173578 + }, + "name": "" +}, { + "location": { + "latitude": 401263460, + "longitude": -747964303 + }, + "name": "" +}, { + "location": { + "latitude": 412843391, + "longitude": -749086026 + }, + "name": "" +}, { + "location": { + "latitude": 418512773, + "longitude": -743067823 + }, + "name": "" +}, { + "location": { + "latitude": 404318328, + "longitude": -740835638 + }, + "name": "42-102 Main Street, Belford, NJ 07718, USA" +}, { + "location": { + "latitude": 419020746, + "longitude": -741172328 + }, + "name": "" +}, { + "location": { + "latitude": 404080723, + "longitude": -746119569 + }, + "name": "" +}, { + "location": { + "latitude": 401012643, + "longitude": -744035134 + }, + "name": "" +}, { + "location": { + "latitude": 404306372, + "longitude": -741079661 + }, + "name": "" +}, { + "location": { + "latitude": 403966326, + "longitude": -748519297 + }, + "name": "" +}, { + "location": { + "latitude": 405002031, + "longitude": -748407866 + }, + "name": "" +}, { + "location": { + "latitude": 409532885, + "longitude": -742200683 + }, + "name": "" +}, { + "location": { + "latitude": 416851321, + "longitude": -742674555 + }, + "name": "" +}, { + "location": { + "latitude": 406411633, + "longitude": -741722051 + }, + "name": "3387 Richmond Terrace, Staten Island, NY 10303, USA" +}, { + "location": { + "latitude": 413069058, + "longitude": -744597778 + }, + "name": "261 Van Sickle Road, Goshen, NY 10924, USA" +}, { + "location": { + "latitude": 418465462, + "longitude": -746859398 + }, + "name": "" +}, { + "location": { + "latitude": 411733222, + "longitude": -744228360 + }, + "name": "" +}, { + "location": { + "latitude": 410248224, + "longitude": -747127767 + }, + "name": "3 Hasta Way, Newton, NJ 07860, USA" +}] diff --git a/tutorials/basics/proto/LICENSE.proto b/tutorials/basics/proto/LICENSE.proto new file mode 100644 index 0000000..5f638b6 --- /dev/null +++ b/tutorials/basics/proto/LICENSE.proto @@ -0,0 +1,18 @@ +The protobuf file is a modified version of `examples/protos/route_guide.proto` +from the official gRPC repository at https://github.com/grpc/grpc. + +Its license is reproduced below: + +// Copyright 2015 gRPC authors. +// +// 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. diff --git a/tutorials/basics/proto/route_guide.proto b/tutorials/basics/proto/route_guide.proto new file mode 100644 index 0000000..b2ee656 --- /dev/null +++ b/tutorials/basics/proto/route_guide.proto @@ -0,0 +1,92 @@ +syntax = "proto3"; + +package routeguide; + +// Interface exported by the server. +service RouteGuide { + // A simple RPC. + // + // Obtains the feature at a given position. + // + // A feature with an empty name is returned if there's no feature at the given + // position. + rpc GetFeature(Point) returns (Feature) {} + + // A server-to-client streaming RPC. + // + // Obtains the Features available within the given Rectangle. Results are + // streamed rather than returned at once (e.g. in a response message with a + // repeated field), as the rectangle may cover a large area and contain a + // huge number of features. + rpc ListFeatures(Rectangle) returns (stream Feature) {} + + // A client-to-server streaming RPC. + // + // Accepts a stream of Points on a route being traversed, returning a + // RouteSummary when traversal is completed. + rpc RecordRoute(stream Point) returns (RouteSummary) {} + + // A Bidirectional streaming RPC. + // + // Accepts a stream of RouteNotes sent while a route is being traversed, + // while receiving other RouteNotes (e.g. from other users). + rpc RouteChat(stream RouteNote) returns (stream RouteNote) {} +} + +// Points are represented as latitude-longitude pairs in the E7 representation +// (degrees multiplied by 10**7 and rounded to the nearest integer). +// Latitudes should be in the range +/- 90 degrees and longitude should be in +// the range +/- 180 degrees (inclusive). +message Point { + int32 latitude = 1; + int32 longitude = 2; +} + +// A latitude-longitude rectangle, represented as two diagonally opposite +// points "lo" and "hi". +message Rectangle { + // One corner of the rectangle. + Point lo = 1; + + // The other corner of the rectangle. + Point hi = 2; +} + +// A feature names something at a given point. +// +// If a feature could not be named, the name is empty. +message Feature { + // The name of the feature. + string name = 1; + + // The point where the feature is detected. + Point location = 2; +} + +// A RouteNote is a message sent while at a given point. +message RouteNote { + // The location from which the message is sent. + Point location = 1; + + // The message to be sent. + string message = 2; +} + +// A RouteSummary is received in response to a RecordRoute rpc. +// +// It contains the number of individual points received, the number of +// detected features, and the total distance covered as the cumulative sum of +// the distance between each point. +message RouteSummary { + // The number of points received. + int32 point_count = 1; + + // The number of known features passed while traversing the route. + int32 feature_count = 2; + + // The distance covered in metres. + int32 distance = 3; + + // The duration of the traversal in seconds. + int32 elapsed_time = 4; +} diff --git a/tutorials/basics/src/Proto/API/RouteGuide.hs b/tutorials/basics/src/Proto/API/RouteGuide.hs new file mode 100644 index 0000000..43ad511 --- /dev/null +++ b/tutorials/basics/src/Proto/API/RouteGuide.hs @@ -0,0 +1,16 @@ +module Proto.API.RouteGuide ( + module Proto.RouteGuide + ) where + +import Network.GRPC.Common +import Network.GRPC.Common.Protobuf + +import Proto.RouteGuide + +{------------------------------------------------------------------------------- + Metadata +-------------------------------------------------------------------------------} + +type instance RequestMetadata (Protobuf RouteGuide meth) = NoMetadata +type instance ResponseInitialMetadata (Protobuf RouteGuide meth) = NoMetadata +type instance ResponseTrailingMetadata (Protobuf RouteGuide meth) = NoMetadata diff --git a/tutorials/basics/src/RouteGuide.hs b/tutorials/basics/src/RouteGuide.hs new file mode 100644 index 0000000..c5c1f25 --- /dev/null +++ b/tutorials/basics/src/RouteGuide.hs @@ -0,0 +1,160 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module RouteGuide ( + -- * Querying the database + DB + , getDB + , featureAt + , featuresIn + , summary + -- * Route chat + , Chat + , emptyChat + , getNotes + , recordNote + ) where + +import Data.Aeson +import Data.Int +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (listToMaybe, fromMaybe) +import Data.Time + +import Network.GRPC.Common.Protobuf + +import Proto.RouteGuide + +import Paths_basics + +{------------------------------------------------------------------------------- + Querying the database +-------------------------------------------------------------------------------} + +-- | The DB of predefined features +type DB = [Proto Feature] + +-- | Load the database from disk +getDB :: IO DB +getDB = do + path <- getDataFileName "route_guide_db.json" + either error return =<< eitherDecodeFileStrict path + +featureAt :: DB -> Proto Point -> Maybe (Proto Feature) +featureAt db p = listToMaybe $ filter (\f -> f ^. #location == p) db + +featuresIn :: DB -> Proto Rectangle -> [Proto Feature] +featuresIn db r = filter (\f -> inRectangle r (f ^. #location)) db + +summary :: DB -> NominalDiffTime -> [Proto Point] -> Proto RouteSummary +summary db duration ps = + defMessage + & #pointCount .~ fromIntegral (length ps) + & #featureCount .~ fromIntegral (length visited) + & #distance .~ floor (distance ps) + & #elapsedTime .~ round duration + where + visited :: [Proto Feature] + visited = filter (\f -> any (== f ^. #location) ps) db + +{------------------------------------------------------------------------------- + Route chat +-------------------------------------------------------------------------------} + +type Chat = Map (Proto Point) [Proto RouteNote] + +emptyChat :: Chat +emptyChat = Map.empty + +getNotes :: Chat -> Proto Point -> [Proto RouteNote] +getNotes chat p = Map.findWithDefault [] p chat + +recordNote :: Proto RouteNote -> Chat -> Chat +recordNote note chat = + Map.alter (Just . (note :) . fromMaybe []) (note ^. #location) chat + +{------------------------------------------------------------------------------- + Internal Auxiliary +-------------------------------------------------------------------------------} + +inRectangle :: Proto Rectangle -> Proto Point -> Bool +inRectangle r p = and [ + p ^. #longitude >= left + , p ^. #longitude <= right + , p ^. #latitude >= bottom + , p ^. #latitude <= top + ] + where + left, right, top, bottom :: Int32 + left = min (r ^. #lo ^. #longitude) (r ^. #hi ^. #longitude) + right = max (r ^. #lo ^. #longitude) (r ^. #hi ^. #longitude) + top = max (r ^. #lo ^. #latitude) (r ^. #hi ^. #latitude) + bottom = min (r ^. #lo ^. #latitude) (r ^. #hi ^. #latitude) + +-- | Total distance between the points +distance :: [Proto Point] -> Double +distance = \case + [] -> 0 + p:ps -> go 0 p ps + where + go :: Double -> Proto Point -> [Proto Point] -> Double + go !acc _ [] = acc + go !acc prev (p:ps) = go (acc + distanceBetween prev p) p ps + +-- | Distance between two points (in meters) +-- +-- For consistency, this is a direct translation of the Python example code in +-- the gRPC repo. +distanceBetween :: Proto Point -> Proto Point -> Double +distanceBetween fr to = + let a, c :: Double + a = sin (deltaLat / 2) ** 2 + + (cos frLat * cos toLat * sin (deltaLon / 2) ** 2) + c = 2 * atan2 (sqrt a) (sqrt (1 - a)) + in r * c + where + coordFactor :: Double + coordFactor = 10_000_000 + + frLat, frLon, toLat, toLon :: Double + frLat = degToRad $ fromIntegral (fr ^. #latitude) / coordFactor + frLon = degToRad $ fromIntegral (fr ^. #longitude) / coordFactor + toLat = degToRad $ fromIntegral (to ^. #latitude) / coordFactor + toLon = degToRad $ fromIntegral (to ^. #longitude) / coordFactor + + deltaLat, deltaLon :: Double + deltaLat = toLat - frLat + deltaLon = toLon - frLon + + -- Earth's radius + r :: Double + r = 6371000 + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance FromJSON (Proto Feature) where + parseJSON = withObject "Feature" $ \obj -> do + location <- obj .: "location" + name <- obj .: "name" + return $ + defMessage + & #location .~ location + & #name .~ name + +instance FromJSON (Proto Point) where + parseJSON = withObject "Point" $ \obj -> do + latitude <- obj .: "latitude" + longitude <- obj .: "longitude" + return $ + defMessage + & #latitude .~ latitude + & #longitude .~ longitude + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +degToRad :: Double -> Double +degToRad d = d * (pi / 180) diff --git a/tutorials/quickstart/app/Server.hs b/tutorials/quickstart/app/Server.hs index 8fde68b..b63deab 100644 --- a/tutorials/quickstart/app/Server.hs +++ b/tutorials/quickstart/app/Server.hs @@ -8,16 +8,24 @@ import Network.GRPC.Server.StreamType import Proto.API.Helloworld -methods :: Methods IO (ProtobufMethodsOf Greeter) -methods = - Method (mkNonStreaming sayHello) - $ NoMoreMethods +{------------------------------------------------------------------------------- + Individual handlers +-------------------------------------------------------------------------------} sayHello :: Proto HelloRequest -> IO (Proto HelloReply) sayHello req = do let resp = defMessage & #message .~ "Hello, " <> req ^. #name return resp +{------------------------------------------------------------------------------- + Server top-level +-------------------------------------------------------------------------------} + +methods :: Methods IO (ProtobufMethodsOf Greeter) +methods = + Method (mkNonStreaming sayHello) + $ NoMoreMethods + main :: IO () main = runServerWithHandlers def config $ fromMethods methods diff --git a/tutorials/quickstart/LICENSE.proto b/tutorials/quickstart/proto/LICENSE.proto similarity index 100% rename from tutorials/quickstart/LICENSE.proto rename to tutorials/quickstart/proto/LICENSE.proto diff --git a/tutorials/quickstart/proto/helloworld.proto b/tutorials/quickstart/proto/helloworld.proto index 4f2dd1f..cb91e82 100644 --- a/tutorials/quickstart/proto/helloworld.proto +++ b/tutorials/quickstart/proto/helloworld.proto @@ -1,5 +1,7 @@ syntax = "proto3"; +package helloworld; + // The greeting service definition. service Greeter { // Sends a greeting diff --git a/tutorials/quickstart/quickstart.cabal b/tutorials/quickstart/quickstart.cabal index d334de3..7ce8638 100644 --- a/tutorials/quickstart/quickstart.cabal +++ b/tutorials/quickstart/quickstart.cabal @@ -23,10 +23,15 @@ custom-setup common lang build-depends: base >= 4.14 && < 5 default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall + + if impl(ghc >= 9.0) + ghc-options: + -Wunused-packages default-extensions: DataKinds + ImportQualifiedPost OverloadedLabels OverloadedStrings TypeApplications @@ -54,8 +59,11 @@ executable greeter_server ghc-options: -main-is Server build-depends: - , grapesy + -- internal , quickstart + build-depends: + -- inherited + , grapesy executable greeter_client import: lang @@ -64,5 +72,8 @@ executable greeter_client ghc-options: -main-is Client build-depends: + -- internal + , quickstart + build-depends: + -- inherited , grapesy - , quickstart \ No newline at end of file diff --git a/tutorials/quickstart/src/Proto/API/Helloworld.hs b/tutorials/quickstart/src/Proto/API/Helloworld.hs index d6a9838..c949eb9 100644 --- a/tutorials/quickstart/src/Proto/API/Helloworld.hs +++ b/tutorials/quickstart/src/Proto/API/Helloworld.hs @@ -2,9 +2,10 @@ module Proto.API.Helloworld ( module Proto.Helloworld ) where -import Proto.Helloworld -import Network.GRPC.Common.Protobuf import Network.GRPC.Common +import Network.GRPC.Common.Protobuf + +import Proto.Helloworld {------------------------------------------------------------------------------- Metadata