├── .github ├── ISSUE_TEMPLATE │ ├── bug_report.md │ ├── config.yaml │ └── feature_request.md └── workflows │ ├── cabal.project.local │ ├── github-page.yml │ └── haskell.yml ├── .gitignore ├── .stylish-haskell.yaml ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── README.md ├── cabal.project ├── scripts └── check-stylish.sh ├── typed-protocols-doc ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── NOTICE ├── README.md ├── demo │ ├── DemoProtocol.hs │ └── Main.hs ├── protocol.html ├── src │ └── Network │ │ └── TypedProtocol │ │ ├── Documentation.hs │ │ └── Documentation │ │ ├── DefaultMain.hs │ │ ├── GraphViz.hs │ │ ├── Html.hs │ │ ├── TH.hs │ │ ├── Text.hs │ │ └── Types.hs ├── test │ ├── Main.hs │ └── Network │ │ └── TypedProtocol │ │ └── Tests │ │ ├── ControlProtocol.hs │ │ ├── Documentation.hs │ │ ├── TestProtocol.hs │ │ └── TestProtocolTH.hs └── typed-protocols-doc.cabal └── typed-protocols ├── CHANGELOG.md ├── LICENSE ├── NOTICE ├── README.md ├── cborg └── Network │ └── TypedProtocol │ └── Codec │ └── CBOR.hs ├── examples └── Network │ └── TypedProtocol │ ├── Channel.hs │ ├── Driver │ └── Simple.hs │ ├── PingPong │ ├── Client.hs │ ├── Codec.hs │ ├── Codec │ │ └── CBOR.hs │ ├── Examples.hs │ ├── Server.hs │ └── Type.hs │ ├── ReqResp │ ├── Client.hs │ ├── Codec.hs │ ├── Codec │ │ └── CBOR.hs │ ├── Examples.hs │ ├── Server.hs │ └── Type.hs │ ├── ReqResp2 │ ├── Client.hs │ └── Type.hs │ ├── Stateful │ └── ReqResp │ │ ├── Client.hs │ │ ├── Codec.hs │ │ ├── Examples.hs │ │ ├── Server.hs │ │ └── Type.hs │ └── Trans │ └── Wedge.hs ├── src └── Network │ ├── TypedProtocol.hs │ └── TypedProtocol │ ├── Codec.hs │ ├── Core.hs │ ├── Driver.hs │ ├── Lemmas.hs │ ├── Peer.hs │ ├── Peer │ ├── Client.hs │ └── Server.hs │ └── Proofs.hs ├── stateful-cborg └── Network │ └── TypedProtocol │ └── Stateful │ └── Codec │ └── CBOR.hs ├── stateful └── Network │ ├── TypedProtocol.hs │ └── TypedProtocol │ └── Stateful │ ├── Codec.hs │ ├── Driver.hs │ ├── Peer.hs │ ├── Peer │ ├── Client.hs │ └── Server.hs │ └── Proofs.hs ├── test ├── Main.hs └── Network │ └── TypedProtocol │ ├── PingPong │ └── Tests.hs │ └── ReqResp │ └── Tests.hs └── typed-protocols.cabal /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Create a report to help us improve 4 | title: '' 5 | labels: bug 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Describe the bug** 11 | A clear and concise description of what the bug is. 12 | 13 | **To Reproduce** 14 | Steps to reproduce the behaviour: 15 | 16 | **Expected behaviour** 17 | A clear and concise description of what you expected to happen. 18 | 19 | **Desktop (please complete the following information):** 20 | - `GHC` version: 21 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/config.yaml: -------------------------------------------------------------------------------- 1 | blank_issues_enabled: true 2 | contact_links: 3 | - name: Questions 4 | url: https://github.com/input-output-hk/typed-protocols/discussions 5 | about: Please raise any questions in Discussions 6 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest an idea for this project 4 | title: '' 5 | labels: enhancement 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Is your feature request related to a problem? Please describe.** 11 | A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] 12 | 13 | **Describe the solution you'd like** 14 | A clear and concise description of what you want to happen. 15 | 16 | **Describe alternatives you've considered** 17 | A clear and concise description of any alternative solutions or features you've considered. 18 | 19 | **Additional context** 20 | Add any other context or screenshots about the feature request here. 21 | 22 | **Are you willing to implement it?** 23 | * [ ] Are you? :smiley: 24 | -------------------------------------------------------------------------------- /.github/workflows/cabal.project.local: -------------------------------------------------------------------------------- 1 | documentation: True 2 | tests: True 3 | benchmarks: True 4 | 5 | package typed-protocols 6 | ghc-options: -Werror 7 | flags: +asserts 8 | 9 | package typed-protocols-cborg 10 | ghc-options: -Werror 11 | flags: +asserts 12 | 13 | package typed-protocols-examples 14 | ghc-options: -Werror 15 | flags: +asserts 16 | 17 | -------------------------------------------------------------------------------- /.github/workflows/github-page.yml: -------------------------------------------------------------------------------- 1 | name: Haddocks 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | workflow_dispatch: 8 | 9 | jobs: 10 | haddocks: 11 | name: Haddocks 12 | 13 | runs-on: ${{ matrix.os }} 14 | 15 | defaults: 16 | run: 17 | shell: bash 18 | 19 | strategy: 20 | fail-fast: false 21 | matrix: 22 | ghc: ["9.10"] 23 | os: [ubuntu-latest] 24 | 25 | permissions: 26 | pages: write 27 | id-token: write 28 | 29 | environment: 30 | name: github-pages 31 | url: ${{ steps.deployment.outputs.page_url }} 32 | 33 | steps: 34 | - name: Install pandoc 35 | run: sudo apt install pandoc 36 | 37 | - name: Checkout ouroboros-network repository 38 | uses: actions/checkout@v4 39 | 40 | - name: Install Haskell 41 | uses: haskell-actions/setup@v2 42 | id: setup-haskell 43 | with: 44 | ghc-version: ${{ matrix.ghc }} 45 | cabal-version: 'head' 46 | 47 | - uses: actions/cache@v4 48 | name: Cache cabal store 49 | with: 50 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 51 | key: cache-haddock-${{ runner.os }}-${{ matrix.ghc }}-v1-${{ hashFiles('cabal-cache.cabal') }}-${{ github.sha }} 52 | restore-keys: cache-haddock-${{ runner.os }}-${{ matrix.ghc }}-v1-${{ hashFiles('cabal-cache.cabal') }}- 53 | 54 | - name: Update Hackage index 55 | run: cabal update 56 | 57 | - name: Build plan 58 | run: cabal build --dry-run --enable-tests all 59 | 60 | - name: Run pandoc 61 | run: pandoc --from=gfm --to=haddock --output=README.haddock README.md 62 | 63 | - name: Build Haddock documentation 🔧 64 | run: | 65 | cabal haddock-project --prologue=README.haddock --hackage all 66 | 67 | - name: Upload artifacts 68 | uses: actions/upload-pages-artifact@v3 69 | with: 70 | path: ./haddocks 71 | 72 | - name: Deploy 🚀 73 | id: deployment 74 | uses: actions/deploy-pages@v4 75 | 76 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | pull_request: 5 | merge_group: 6 | 7 | jobs: 8 | build: 9 | runs-on: ${{ matrix.os }} 10 | 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | ghc: ["9.6", "9.8", "9.10", "9.12"] 15 | os: [ubuntu-latest, macos-latest, windows-latest] 16 | 17 | env: 18 | CABAL_VERSION: "3.12.1.0" 19 | 20 | defaults: 21 | run: 22 | shell: "bash" 23 | 24 | steps: 25 | - name: Set cache version 26 | run: echo "CACHE_VERSION=pu4Aevoo" >> $GITHUB_ENV 27 | 28 | - name: Install LLVM (macOS) 29 | if: runner.os == 'macOS' && matrix.ghc == '8.10' 30 | run: | 31 | brew install llvm@14 32 | echo "LLVM_CONFIG=$(brew --prefix llvm@14)/bin/llvm-config" >> $GITHUB_ENV 33 | echo "$(brew --prefix llvm@14)/bin" >> $GITHUB_PATH 34 | 35 | - name: Verify LLVM installation 36 | if: runner.os == 'macOS' && matrix.ghc == '8.10' 37 | run: | 38 | llvm-config --version 39 | opt --version 40 | 41 | - name: Print environment variables 42 | if: runner.os == 'macOS' && matrix.ghc == '8.10' 43 | run: | 44 | echo "PATH = $PATH" 45 | echo "LLVM_CONFIG = $LLVM_CONFIG" 46 | 47 | - name: "Setup Haskell" 48 | uses: haskell-actions/setup@v2 49 | id: setup-haskell 50 | with: 51 | ghc-version: ${{ matrix.ghc }} 52 | cabal-version: ${{ env.CABAL_VERSION }} 53 | 54 | - uses: actions/checkout@v4 55 | 56 | - name: "Configure cabal.project.local" 57 | run: | 58 | cat ./.github/workflows/cabal.project.local > ./cabal.project.local 59 | cat ./cabal.project.local 60 | 61 | - name: "Cabal update" 62 | run: cabal update 63 | 64 | - name: Record dependencies 65 | id: record-deps 66 | run: | 67 | cabal build all --dry-run 68 | cat dist-newstyle/cache/plan.json | jq -r '."install-plan"[].id' | sort | uniq > dependencies.txt 69 | echo "weeknum=$(/bin/date -u "+%W")" >> $GITHUB_OUTPUT 70 | 71 | - uses: actions/cache@v4 72 | name: "Cache cabal store" 73 | with: 74 | path: ${{ runner.os == 'Windows' && steps.win-setup-haskell.outputs.cabal-store || steps.setup-haskell.outputs.cabal-store }} 75 | key: cache-dependencies-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }} 76 | restore-keys: cache-dependencies-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }} 77 | 78 | - uses: actions/cache@v4 79 | name: "Cache `dist-newstyle`" 80 | with: 81 | path: | 82 | dist-newstyle 83 | !dist-newstyle/**/.git 84 | key: cache-dist-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ steps.record-deps.outputs.weeknum }} 85 | restore-keys: cache-dist-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }} 86 | 87 | - name: Build dependencies 88 | run: cabal build --only-dependencies all 89 | 90 | - name: Build projects [build] 91 | run: cabal build all 92 | 93 | - name: typed-protocols:test 94 | run: cabal run typed-protocols:test 95 | 96 | # - name: typed-protocols-doc [test] 97 | # run: cabal test typed-protocols-doc 98 | 99 | stylish-haskell: 100 | runs-on: ubuntu-22.04 101 | 102 | env: 103 | STYLISH_HASKELL_VERSION: "0.14.4.0" 104 | 105 | steps: 106 | - name: Set cache version 107 | run: | 108 | echo "CACHE_VERSION=hi5eTh3A" >> $GITHUB_ENV 109 | 110 | - name: "Install build environment (apt-get)" 111 | run: | 112 | sudo apt-get update 113 | sudo apt-get -y install fd-find 114 | 115 | - name: "Setup Haskell" 116 | uses: haskell-actions/setup@v2 117 | id: setup-haskell 118 | with: 119 | ghc-version: 9.2.5 120 | cabal-version: 3.8.1.0 121 | 122 | - name: "Setup cabal bin path" 123 | run: | 124 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 125 | 126 | - uses: actions/cache@v4 127 | name: "Cache `stylish-haskell`" 128 | with: 129 | path: ~/.cabal/bin/stylish-haskell 130 | key: cabal-path-${{ env.STYLISH_HASKELL_VERSION }} 131 | 132 | - name: Download stylish-haskell 133 | run: | 134 | version="${{ env.STYLISH_HASKELL_VERSION }}" 135 | 136 | curl -sL \ 137 | "https://github.com/haskell/stylish-haskell/releases/download/v$version/stylish-haskell-v$version-linux-x86_64.tar.gz" \ 138 | | tar -C "/tmp" -xz 139 | 140 | echo "PATH=/tmp/stylish-haskell-v$version-linux-x86_64:$PATH" >> $GITHUB_ENV 141 | 142 | - name: "`stylish-haskell` version" 143 | run: | 144 | which stylish-haskell 145 | stylish-haskell --version 146 | 147 | - uses: actions/checkout@v4 148 | 149 | - name: "Run `stylish-haskell`" 150 | run: | 151 | ./scripts/check-stylish.sh 152 | git diff --exit-code 153 | 154 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | README.haddock 3 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | [Code of Conduct](https://github.com/input-output-hk/cardano-engineering-handbook/blob/main/CODE-OF-CONDUCT.md) 2 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Building 2 | 3 | The project is build with `cabal-install`. You might need to run `cabal 4 | update` after cloning the repository (to update [`Cardano Haskell 5 | Packages`][CHaP] (`ChaP`) index). 6 | 7 | # Using in your project 8 | 9 | Currently the package is published to [`CHaP`][CHaP]. In future it will be 10 | published to `Hackage`. If you want to pull it from [`CHaP`][CHaP], this is 11 | relatively easy to setup; for example, checkout the 12 | [`cabal.project`](https://github.com/input-output-hk/typed-protocols/blob/master/cabal.project) 13 | file. Alternatively, you can relay on `source-repository-package` stanza in 14 | a `cabal.project` file. 15 | 16 | # Testing 17 | 18 | The `typed-protocols-examples` package contains two simple protocols `PingPong` 19 | & `ReqResp` which are used for illustration & testing. 20 | 21 | ``` 22 | cabal run typed-protocols-examples:test 23 | ``` 24 | 25 | # Code Style 26 | 27 | Please follow local style. For a more detailed style guide see 28 | [link](https://github.com/input-output-hk/ouroboros-network/blob/master/docs/StyleGuide.md). 29 | 30 | # Pull Requests 31 | 32 | Each commit shall be small and preferably address one thing at a time. Well 33 | organised & documented commits make it much easier for the maintainers to 34 | review them. 35 | 36 | New features should be well documented & tested, which means including new 37 | tests as necessary. You might be asked by the maintainers to write & include 38 | additional tests. 39 | 40 | Each commit should build & test, at least the package you are changing. You 41 | can update other packages from this repository in a subsequent commit. 42 | 43 | Please use a draft PRs if the work is still in progress. 44 | 45 | We require all commits to be signed, see [this guide][gh-signing-commits]. 46 | 47 | If your pull requests resolves an existing issue, please link your PR to that 48 | issue, see [GitHub documentation][gh-link-issue]. 49 | 50 | 51 | [CHaP]: https://github.com/input-output-hk/cardano-haskell-packages/ 52 | [gh-link-issue]: https://docs.github.com/en/github/managing-your-work-on-github/linking-a-pull-request-to-an-issue 53 | [gh-signing-commits]: https://docs.github.com/en/authentication/managing-commit-signature-verification/signing-commits 54 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Haskell CI](https://img.shields.io/github/actions/workflow/status/input-output-hk/typed-protocols/haskell.yml?branch=main&label=Build&style=for-the-badge)](https://github.com/input-output-hk/typed-protocols/actions/workflows/haskell.yml) 2 | [![handbook](https://img.shields.io/badge/policy-Cardano%20Engineering%20Handbook-informational?style=for-the-badge)](https://input-output-hk.github.io/cardano-engineering-handbook) 3 | 4 | 5 | typed-protocols 6 | =============== 7 | 8 | 9 | A robust session type framework which supports [protocol pipelining][protocol-pipelining]. 10 | 11 | Haddocks are published [here][haddocks]. 12 | 13 | 14 | Public content 15 | -------------- 16 | 17 | [Duncan Coutts][dcoutts] Haskell eXchange 2019 [talk][haskell-eXchange]. 18 | 19 | Monadic party workshop by Marcin Szamotulski ([coot]): 20 | * [part 1][monadic-party-part-1] 21 | * [part 2][monadic-party-part-2] 22 | * [part 2][monadic-party-part-3] 23 | 24 | Talk at [Haskell Love 2021][haskell-love] by Marcin Szamotulski ([coot]), [slides][haskell-love-slides]. 25 | 26 | An [Agda][typed-protocols-agda] implementation by Marcin Szamotulski ([coot]). 27 | 28 | 29 | [protocol-pipelining]: https://www.wikiwand.com/en/Protocol_pipelining 30 | [haskell-eXchange]: https://www.youtube.com/watch?v=kkynmgwa7gE 31 | [monadic-party-part-1]: https://www.youtube.com/watch?v=j8gza2L61nM 32 | [monadic-party-part-2]: https://www.youtube.com/watch?v=oV6KSl1srL8 33 | [monadic-party-part-3]: https://www.youtube.com/watch?v=nOIQCRPwmPA 34 | [haskell-love-slides]: https://coot.me/posts/typed-protocols-at-haskell-love.html 35 | [haskell-love]: https://www.youtube.com/watch?v=EbK6VAqYh3g 36 | [typed-protocols-agda]: https://coot.me/agda/posts.agda.typed-protocols.html 37 | [coot]: https://github.com/coot 38 | [dcoutts]: https://github.com/dcoutts 39 | [haddocks]: https://input-output-hk.github.io/typed-protocols 40 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | index-state: 2025-05-05T00:00:00Z 2 | 3 | packages: ./typed-protocols 4 | ./typed-protocols-doc 5 | 6 | test-show-details: direct 7 | 8 | if impl(ghc >= 9.12) 9 | allow-newer: 10 | , serdoc-core:template-haskell 11 | , serdoc-core:th-abstraction 12 | 13 | if os(windows) 14 | package text 15 | flags: -simdutf 16 | 17 | source-repository-package 18 | type: git 19 | location: https://github.com/input-output-hk/io-sim 20 | tag: aef112549bf85d51a03919008b6091af8933e9e2 21 | --sha256: sha256-yfhBeAYwWktqBAkvXUVdrgBzNvTwAqMKglcjwflMtM4= 22 | subdir: io-classes 23 | io-sim 24 | -------------------------------------------------------------------------------- /scripts/check-stylish.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -euo pipefail 4 | export LC_ALL=C.UTF-8 5 | 6 | [[ -x '/usr/bin/fd' ]] && FD="fd" || FD="fdfind" 7 | 8 | $FD . './typed-protocols' -e hs -E Setup.hs -E Core.hs -E Channel.hs -X stylish-haskell -c .stylish-haskell.yaml -i 9 | -------------------------------------------------------------------------------- /typed-protocols-doc/.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | -------------------------------------------------------------------------------- /typed-protocols-doc/CHANGELOG.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/input-output-hk/typed-protocols/88e3f8482fc8d2eac606d0d8bb62d84ea7596b65/typed-protocols-doc/CHANGELOG.md -------------------------------------------------------------------------------- /typed-protocols-doc/NOTICE: -------------------------------------------------------------------------------- 1 | Copyright 2019-2025 Input Output Global Inc (IOG) 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | 15 | -------------------------------------------------------------------------------- /typed-protocols-doc/README.md: -------------------------------------------------------------------------------- 1 | typed-protocols-doc 2 | =================== 3 | 4 | Automatically generates HTML documentation for protocols defined with 5 | [typed-protocols](https://input-output-hk.github.io/typed-protocols/typed-protocols/Network-TypedProtocol.html) 6 | -------------------------------------------------------------------------------- /typed-protocols-doc/demo/DemoProtocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | 16 | -- for `deriveSerDoc` 17 | {-# OPTIONS_GHC -Wno-redundant-constraints #-} 18 | 19 | module DemoProtocol 20 | where 21 | 22 | import Control.Monad.Identity 23 | import Control.Monad.Except 24 | 25 | import Data.Proxy 26 | import Data.SerDoc.Class 27 | import Data.SerDoc.Info 28 | import Data.SerDoc.TH 29 | import Data.Text (Text) 30 | import Data.Word 31 | 32 | import Network.TypedProtocol.Core 33 | 34 | data PongInfo = 35 | PongInfo 36 | { pongTimestamp :: Word64 37 | , pongPeerID :: Word64 38 | , pongMessage :: Text 39 | } 40 | deriving (Show, Eq) 41 | 42 | data DemoProtocol a where 43 | -- | Idle state: server waits for ping. 44 | IdleState :: DemoProtocol a 45 | 46 | -- | Awaiting pong state: server has received ping, client waits for pong. 47 | AwaitingPongState :: DemoProtocol a 48 | 49 | -- | End state: either side has terminated the session 50 | EndState :: DemoProtocol a 51 | 52 | data SingDemoProtocol a where 53 | SingIdleState :: SingDemoProtocol (IdleState :: DemoProtocol a) 54 | SingAwaitingPongState :: SingDemoProtocol (AwaitingPongState :: DemoProtocol a) 55 | SingEndState :: SingDemoProtocol (EndState :: DemoProtocol a) 56 | 57 | instance StateTokenI IdleState where stateToken = SingIdleState 58 | instance StateTokenI AwaitingPongState where stateToken = SingAwaitingPongState 59 | instance StateTokenI EndState where stateToken = SingEndState 60 | 61 | instance Protocol (DemoProtocol a) where 62 | data Message (DemoProtocol a) st st' where 63 | PingMessage :: Message (DemoProtocol a) IdleState AwaitingPongState 64 | PongMessage :: Message (DemoProtocol a) AwaitingPongState IdleState 65 | ComplexPongMessage :: Message (DemoProtocol a) AwaitingPongState IdleState 66 | EndMessage :: Message (DemoProtocol a) st EndState 67 | 68 | type StateAgency IdleState = ServerAgency 69 | type StateAgency AwaitingPongState = ClientAgency 70 | type StateAgency EndState = NobodyAgency 71 | 72 | type StateToken = SingDemoProtocol 73 | 74 | 75 | 76 | data DemoCodec a 77 | 78 | instance Codec (DemoCodec a) where 79 | type MonadEncode (DemoCodec a) = Identity 80 | type MonadDecode (DemoCodec a) = Except String 81 | 82 | data PongEnum = NormalPong | ComplexPong 83 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 84 | 85 | data PingEnum = PingRequest | EndPing 86 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 87 | 88 | deriving via (ViaEnum PongEnum) 89 | instance (Codec codec, HasInfo codec (DefEnumEncoding codec)) => HasInfo codec PongEnum 90 | 91 | deriving via (ViaEnum PingEnum) 92 | instance (Codec codec, HasInfo codec (DefEnumEncoding codec)) => HasInfo codec PingEnum 93 | 94 | instance HasInfo (DemoCodec b) () where 95 | info _ _ = basicField "()" (FixedSize 0) 96 | 97 | instance HasInfo (DemoCodec b) Text where 98 | info codec _ = 99 | compoundField "Text" 100 | [ ("length", info codec (Proxy @Word32)) 101 | , ("data", basicField "UTF8 dat" (FixedSize 0)) 102 | ] 103 | 104 | instance HasInfo (DemoCodec b) a => HasInfo (DemoCodec b) [a] where 105 | info codec (_ :: Proxy [a]) = 106 | compoundField "List" 107 | [ ( "length", info codec (Proxy @Word32)) 108 | , ( "values" 109 | , listField (VarSize "length") (info codec (Proxy @a)) 110 | ) 111 | ] 112 | 113 | 114 | instance HasInfo (DemoCodec b) a => HasInfo (DemoCodec b) (Maybe a) where 115 | info codec (_ :: Proxy (Maybe a)) = 116 | compoundField "Maybe" 117 | [ ("isJust", info codec (Proxy @Word32)) 118 | , ( "value" 119 | , sumField "isJust" 120 | [ ("Nothing", info codec (Proxy @())) 121 | , ("Just", info codec (Proxy @a)) 122 | ] 123 | ) 124 | ] 125 | 126 | instance HasInfo (DemoCodec b) (Message (DemoProtocol a) IdleState AwaitingPongState) where 127 | info codec _ = infoOf "PingRequest" $ info codec (Proxy @PingEnum) 128 | 129 | instance HasInfo (DemoCodec b) (Message (DemoProtocol a) st EndState) where 130 | info codec _ = infoOf "EndPing" $ info codec (Proxy @PingEnum) 131 | 132 | instance HasInfo (DemoCodec a) Word16 where 133 | info _ _ = basicField "Word16" (FixedSize 2) 134 | 135 | instance HasInfo (DemoCodec a) Word32 where 136 | info _ _ = basicField "Word32" (FixedSize 4) 137 | 138 | instance HasInfo (DemoCodec a) Word64 where 139 | info _ _ = basicField "Word64" (FixedSize 8) 140 | 141 | $(deriveSerDoc ''DemoCodec [] ''PongInfo) 142 | 143 | instance HasInfo (DemoCodec b) (Message (DemoProtocol a) AwaitingPongState IdleState) where 144 | info codec _ = 145 | compoundField "Pong" 146 | [ ("pongType", info codec (Proxy @PongEnum)) 147 | , ("pongData" 148 | , choiceField 149 | (IndexField "pongType") 150 | [ info codec (Proxy @()) 151 | , info codec (Proxy @PongInfo) 152 | ] 153 | ) 154 | ] 155 | -------------------------------------------------------------------------------- /typed-protocols-doc/demo/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE PartialTypeSignatures #-} 9 | 10 | module Main 11 | where 12 | 13 | import Network.TypedProtocol.Documentation 14 | import DemoProtocol 15 | import Data.SerDoc.Class 16 | 17 | main :: IO () 18 | main = defaultMain 19 | [ $(describeProtocol ''DemoProtocol [''()] ''DemoCodec [''()]) 20 | ] 21 | -------------------------------------------------------------------------------- /typed-protocols-doc/src/Network/TypedProtocol/Documentation.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.Documentation 2 | ( 3 | module M 4 | 5 | , protocolToSVGFile 6 | , protocolToDotFile 7 | 8 | , defaultMain 9 | ) 10 | where 11 | 12 | import Network.TypedProtocol.Documentation.Types as M 13 | import Network.TypedProtocol.Documentation.TH as M 14 | import Network.TypedProtocol.Documentation.GraphViz 15 | import Network.TypedProtocol.Documentation.DefaultMain 16 | -------------------------------------------------------------------------------- /typed-protocols-doc/src/Network/TypedProtocol/Documentation/DefaultMain.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.Documentation.DefaultMain 2 | where 3 | 4 | import qualified Data.Text.Lazy as LText 5 | import qualified Text.Blaze.Html.Renderer.Pretty as Pretty 6 | import Data.SerDoc.Class hiding (info) 7 | import Data.Word 8 | import qualified Network.TypedProtocol.Documentation.Html as HTML 9 | import qualified Network.TypedProtocol.Documentation.Text as TextRender 10 | import Network.TypedProtocol.Documentation.Types 11 | import Options.Applicative 12 | import Control.Monad 13 | import System.FilePath 14 | import qualified Data.Aeson as JSON 15 | import Data.Text.Encoding 16 | import qualified Data.ByteString.Lazy as LBS 17 | import qualified Data.Text as Text 18 | import System.Exit 19 | import System.IO 20 | import System.IO.Unsafe 21 | 22 | data MainOptions = 23 | MainOptions 24 | { moOutputFile :: Maybe FilePath 25 | , moOutputFormat :: OutputFormat 26 | , moListProtocols :: Bool 27 | } 28 | 29 | data OutputFormat 30 | = OutputAuto 31 | | OutputText 32 | | OutputHtml 33 | | OutputJSON 34 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 35 | 36 | parseOutputFormat :: String -> Maybe OutputFormat 37 | parseOutputFormat "auto" = return OutputAuto 38 | parseOutputFormat "text" = return OutputText 39 | parseOutputFormat "html" = return OutputHtml 40 | parseOutputFormat "json" = return OutputJSON 41 | parseOutputFormat _ = Nothing 42 | 43 | pMainOptions :: Parser MainOptions 44 | pMainOptions = 45 | MainOptions 46 | <$> option (Just <$> str) 47 | ( short 'o' 48 | <> value Nothing 49 | <> metavar "FILE" 50 | <> help "Output file (default: stdout)" 51 | ) 52 | <*> option (maybeReader parseOutputFormat) 53 | ( short 'f' 54 | <> value OutputAuto 55 | <> metavar "FORMAT" 56 | <> help "Output format; one of: html, text, json, auto" 57 | ) 58 | <*> switch 59 | ( long "list-protocols" 60 | <> long "list" 61 | <> short 'l' 62 | <> help "Print a list of protocols and exit" 63 | ) 64 | 65 | 66 | defaultMain :: ( HasInfo codec (DefEnumEncoding codec) 67 | , HasInfo codec Word32 68 | ) => [ProtocolDescription codec] -> IO () 69 | defaultMain descriptions = do 70 | mainOptions <- execParser $ info (pMainOptions <**> helper) fullDesc 71 | if moListProtocols mainOptions then do 72 | forM_ descriptions $ \d -> do 73 | putStrLn (protocolName d) 74 | else do 75 | let write = maybe putStrLn writeFile $ moOutputFile mainOptions 76 | render = getRenderer (moOutputFormat mainOptions) (moOutputFile mainOptions) 77 | write . render $ descriptions 78 | 79 | getRenderer :: ( HasInfo codec (DefEnumEncoding codec) 80 | , HasInfo codec Word32 81 | ) 82 | => OutputFormat 83 | -> Maybe FilePath 84 | -> [ProtocolDescription codec] 85 | -> String 86 | getRenderer OutputAuto path = 87 | case takeExtension <$> path of 88 | Just ".html" -> getRenderer OutputHtml path 89 | Just ".htm" -> getRenderer OutputHtml path 90 | Just ".json" -> getRenderer OutputJSON path 91 | Just ".txt" -> getRenderer OutputText path 92 | Nothing -> abort "Cannot detect output file format" 93 | Just ext -> abort $ "Cannot detect output file format from extension " ++ show ext 94 | getRenderer OutputHtml _ = 95 | Pretty.renderHtml . HTML.wrapDocument . HTML.renderProtocolDescriptions 96 | getRenderer OutputText _ = 97 | LText.unpack . TextRender.renderProtocolDescriptions 98 | getRenderer OutputJSON _ = 99 | Text.unpack . decodeUtf8 . LBS.toStrict . JSON.encode 100 | 101 | abort :: String -> a 102 | abort msg = unsafePerformIO $ do 103 | hPutStrLn stderr msg 104 | exitFailure 105 | -------------------------------------------------------------------------------- /typed-protocols-doc/src/Network/TypedProtocol/Documentation/GraphViz.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.TypedProtocol.Documentation.GraphViz 4 | where 5 | 6 | import Data.Maybe 7 | import qualified Data.GraphViz as Dot 8 | import qualified Data.GraphViz.Attributes.Complete as Dot 9 | import Data.Graph.Inductive.Graph (mkGraph, Node) 10 | import Data.Graph.Inductive.PatriciaTree (Gr) 11 | import qualified Data.Text.Lazy as LText 12 | import qualified Data.Map.Strict as Map 13 | import System.IO (Handle) 14 | import qualified Data.ByteString as BS 15 | 16 | import Network.TypedProtocol.Documentation.Types 17 | 18 | protocolToDot :: ProtocolDescription codec -> Dot.DotGraph Node 19 | protocolToDot proto = 20 | Dot.graphToDot 21 | Dot.nonClusteredParams 22 | { Dot.fmtNode = \ (_, (name, agency)) -> 23 | stateToNode name agency 24 | , Dot.fmtEdge = \ (_, _, name) -> 25 | [ Dot.Label (Dot.StrLabel $ LText.pack name) 26 | ] 27 | , Dot.globalAttributes = 28 | [ Dot.GraphAttrs 29 | [ Dot.FontSize 10.0 30 | , Dot.LabelFontSize 10.0 31 | ] 32 | , Dot.NodeAttrs 33 | [ Dot.FontName "Noto Sans" 34 | , Dot.LabelFontName "Noto Sans" 35 | ] 36 | , Dot.EdgeAttrs 37 | [ Dot.FontName "Noto Sans" 38 | , Dot.LabelFontName "Noto Sans" 39 | , Dot.FontSize 8.0 40 | , Dot.LabelFontSize 8.0 41 | ] 42 | ] 43 | } 44 | (mkGraph numberedStateInfos edges :: Gr (StateRef, AgencyID) String) 45 | where 46 | stateInfos = [ (name, agency) | (name, _, agency) <- protocolStates proto ] 47 | stateNames = map fst stateInfos 48 | numberedStateInfos = zip [0::Int,1..] stateInfos 49 | numberedStateNames = zip [0::Int,1..] stateNames 50 | stateDict = 51 | Map.fromList $ map flipPair numberedStateNames 52 | 53 | agencyColor NobodyAgencyID = Dot.toColorList [Dot.X11Color Dot.Black] 54 | agencyColor ServerAgencyID = Dot.toColorList [Dot.X11Color Dot.Blue] 55 | agencyColor ClientAgencyID = Dot.toColorList [Dot.X11Color Dot.Brown] 56 | 57 | edges = catMaybes $ flip map (protocolMessages proto) $ \msg -> do 58 | fromIndex <- Map.lookup (messageFromState msg) stateDict 59 | toIndex <- Map.lookup (messageToState msg) stateDict 60 | return (fromIndex, toIndex, messageName msg) 61 | 62 | stateToNode AnyState _ = 63 | [ Dot.Label (Dot.StrLabel "any state") 64 | , Dot.Color (Dot.toColorList [Dot.X11Color Dot.Gray]) 65 | ] 66 | stateToNode (State name) agency = 67 | [ Dot.Label (Dot.StrLabel $ LText.pack name) 68 | , Dot.Color (agencyColor agency) 69 | ] 70 | 71 | flipPair :: (a, b) -> (b, a) 72 | flipPair (x, y) = (y, x) 73 | 74 | protocolToSVGFile :: ProtocolDescription codec -> FilePath -> IO FilePath 75 | protocolToSVGFile proto = 76 | Dot.runGraphvizCommand Dot.Dot (protocolToDot proto) Dot.Svg 77 | 78 | protocolToDotFile :: ProtocolDescription codec -> FilePath -> IO FilePath 79 | protocolToDotFile proto = 80 | Dot.runGraphvizCommand Dot.Dot (protocolToDot proto) Dot.Canon 81 | 82 | hProtocolToSVG :: ProtocolDescription codec -> Handle -> IO () 83 | hProtocolToSVG proto dst = 84 | Dot.graphvizWithHandle Dot.Dot (protocolToDot proto) Dot.Svg consume 85 | where 86 | consume src = BS.hGetContents src >>= BS.hPut dst 87 | -------------------------------------------------------------------------------- /typed-protocols-doc/src/Network/TypedProtocol/Documentation/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Network.TypedProtocol.Documentation.TH 5 | ( describeProtocol 6 | ) 7 | where 8 | 9 | import Network.TypedProtocol.Documentation.Types 10 | 11 | import Control.Monad 12 | #if MIN_VERSION_template_haskell(2,17,0) 13 | -- This import is only needed when 'getDoc' is available. 14 | import Data.Maybe (maybeToList) 15 | #endif 16 | import Data.Maybe (mapMaybe) 17 | import Data.Proxy 18 | import Language.Haskell.TH 19 | import Language.Haskell.TH.Datatype 20 | import Network.TypedProtocol.Core 21 | 22 | 23 | applyTyArgs :: Type -> [Name] -> Type 24 | applyTyArgs t [] = t 25 | applyTyArgs t (x:xs) = 26 | applyTyArgs (AppT t (ConT x)) xs 27 | 28 | -- | Generate a 'ProtocolDescription' runtime representation of a typed 29 | -- protocol specification, including serialization information. 30 | describeProtocol :: Name -> [Name] -> Name -> [Name] -> ExpQ 31 | describeProtocol protoTyCon protoTyArgs codecTyCon codecTyArgs = do 32 | info <- reifyDatatype protoTyCon 33 | protoDescription <- getDescription protoTyCon 34 | let pname = nameBase (datatypeName info) 35 | 36 | let extractAgency :: InstanceDec -> Maybe Name 37 | extractAgency (TySynInstD (TySynEqn _ _ (PromotedT agency))) = Just agency 38 | extractAgency dec = error $ "Unexpected InstanceDec: " ++ show dec 39 | 40 | let extractAgencies :: [InstanceDec] -> [Name] 41 | extractAgencies = mapMaybe extractAgency 42 | 43 | let extractTheAgency :: [InstanceDec] -> Name 44 | extractTheAgency inst = case extractAgencies inst of 45 | [agency] -> agency 46 | xs -> error $ "Incorrect number of agencies: " ++ show xs 47 | 48 | pstates <- forM (datatypeCons info) $ \conInfo -> do 49 | let conName = constructorName conInfo 50 | stateDescription <- getDescription conName 51 | 52 | stateAgencies <- reifyInstances ''StateAgency [ConT conName] 53 | let agencyName = extractTheAgency stateAgencies 54 | agencyID = case nameBase agencyName of 55 | "ServerAgency" -> 'ServerAgencyID 56 | "ClientAgency" -> 'ClientAgencyID 57 | "NobodyAgency" -> 'NobodyAgencyID 58 | x -> error $ "Unknown agency type " ++ x ++ " in state " ++ nameBase conName 59 | 60 | return (conName, stateDescription, agencyID) 61 | 62 | let protocolTy = applyTyArgs (ConT protoTyCon) protoTyArgs 63 | 64 | [DataInstD _ _ _ _ cons _] <- reifyInstances ''Message [protocolTy] 65 | 66 | let messageInfos = map (describeProtocolMessage protoTyCon protoTyArgs codecTyCon codecTyArgs . extractConName) cons 67 | 68 | [| ProtocolDescription 69 | $(litE (stringL pname)) 70 | protoDescription 71 | "" 72 | $(listE 73 | [ [| ( $(makeState $ ConT conName), stateDescription, $(conE agencyID)) |] 74 | | (conName, stateDescription, agencyID) <- pstates 75 | ] 76 | ) 77 | $(listE messageInfos) 78 | |] 79 | 80 | unearthType :: Type -> Type 81 | #if MIN_VERSION_template_haskell(2,17,0) 82 | unearthType (AppT (AppT MulArrowT _) t) = unearthType t 83 | #endif 84 | unearthType (SigT a _) = unearthType a 85 | unearthType t = t 86 | 87 | 88 | prettyTy :: Type -> String 89 | prettyTy = snd . go 90 | where 91 | go (ConT n) = (False, nameBase n) 92 | go (PromotedT n) = (False, nameBase n) 93 | go (VarT n) = (False, nameBase n) 94 | go (AppT a b) = 95 | let 96 | (_, a') = go a 97 | (wrap, b') = go b 98 | in 99 | (True, a' ++ " " ++ if wrap then "(" ++ b' ++ ")" else b') 100 | go (ForallT _ _ a) = go a 101 | go (ForallVisT _ a) = go a 102 | go (AppKindT _ a) = go a 103 | go t = (True, show t) 104 | 105 | getDescription :: Name -> Q [Description] 106 | getDescription name = do 107 | #if MIN_VERSION_template_haskell(2,17,0) 108 | haddock <- maybeToList <$> getDoc (DeclDoc name) 109 | #else 110 | -- 'getDoc' does not exist before template-haskell-2.17.0 111 | let haddock = [] 112 | #endif 113 | annotations <- reifyAnnotations (AnnLookupName name) 114 | return $ (Description . (:[]) <$> haddock) ++ annotations 115 | 116 | unSigTy :: Type -> Type 117 | unSigTy (SigT t _) = t 118 | unSigTy t@(VarT {}) = t 119 | unSigTy t@(PromotedT {}) = t 120 | unSigTy t = error $ show t 121 | 122 | makeState :: Type -> ExpQ 123 | makeState (ConT name) = conE 'State `appE` (litE . stringL $ nameBase name) 124 | makeState (PromotedT name) = conE 'State `appE` (litE . stringL $ nameBase name) 125 | makeState (VarT _) = conE 'AnyState 126 | makeState ty = error . show $ ty -- conE 'AnyState 127 | 128 | describeProtocolMessage :: Name -> [Name] -> Name -> [Name] -> Name -> ExpQ 129 | describeProtocolMessage protoTyCon protoTyArgs codecTyCon codecTyArgs msgName = do 130 | msgInfo <- reifyConstructor msgName 131 | msgTyInfo <- reifyDatatype msgName 132 | msgDescription <- getDescription msgName 133 | 134 | 135 | let payloads = constructorFields msgInfo 136 | #if MIN_VERSION_template_haskell(2,17,0) 137 | tyVarName :: TyVarBndr a -> Name 138 | tyVarName (PlainTV n _) = n 139 | tyVarName (KindedTV n _ _) = n 140 | #else 141 | tyVarName :: TyVarBndr -> Name 142 | tyVarName (PlainTV n) = n 143 | tyVarName (KindedTV n _) = n 144 | #endif 145 | 146 | findType :: Name -> Cxt -> Type 147 | findType n (AppT (AppT EqualityT (VarT vn)) t : _) 148 | | vn == n 149 | = t 150 | findType n (_ : xs) = findType n xs 151 | findType n [] = VarT n 152 | 153 | fromStateVar = tyVarName . last . init $ datatypeVars msgTyInfo 154 | toStateVar = tyVarName . last $ datatypeVars msgTyInfo 155 | fromState = findType fromStateVar (constructorContext msgInfo) 156 | toState = findType toStateVar (constructorContext msgInfo) 157 | 158 | [e| MessageDescription 159 | { messageName = $(litE . stringL . nameBase $ msgName) 160 | , messageDescription = msgDescription 161 | , messagePayload = $(listE (map (litE . stringL . prettyTy) payloads)) 162 | , messageFromState = $(makeState . unearthType $ fromState) 163 | , messageToState = $(makeState . unearthType $ toState) 164 | , messageInfo = 165 | infoOf $(litE . stringL . nameBase $ msgName) $ 166 | info 167 | (Proxy :: Proxy $(pure $ applyTyArgs (ConT codecTyCon) codecTyArgs)) 168 | (Proxy :: Proxy ( $(conT $ datatypeName msgTyInfo) 169 | $(pure $ applyTyArgs (ConT protoTyCon) protoTyArgs) 170 | $(pure $ unSigTy fromState) 171 | $(pure $ unSigTy toState) 172 | ) 173 | ) 174 | } 175 | |] 176 | 177 | extractConName :: Con -> Name 178 | extractConName con = case con of 179 | NormalC n _ -> n 180 | RecC n _ -> n 181 | InfixC _ n _ -> n 182 | ForallC _ _ c -> extractConName c 183 | GadtC (name:_) _ _ -> name 184 | RecGadtC (name:_) _ _ -> name 185 | x -> error $ "Cannot extract constructor name from " ++ show x 186 | -------------------------------------------------------------------------------- /typed-protocols-doc/src/Network/TypedProtocol/Documentation/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.TypedProtocol.Documentation.Types 4 | ( AgencyID (..) 5 | , StateRef (..) 6 | , ProtocolDescription (..) 7 | , MessageDescription (..) 8 | , Description (..) 9 | ) 10 | where 11 | 12 | import Data.SerDoc.Info 13 | import Language.Haskell.TH.Syntax 14 | import Data.Aeson 15 | 16 | -- | Represents agency at the term level. Used to indicate which side has 17 | -- agency in a particular protocol state. 18 | data AgencyID 19 | = ClientAgencyID 20 | | ServerAgencyID 21 | | NobodyAgencyID 22 | deriving (Show, Read, Ord, Eq, Enum, Bounded, Lift) 23 | 24 | instance ToJSON AgencyID where 25 | toJSON ClientAgencyID = "client" 26 | toJSON ServerAgencyID = "server" 27 | toJSON NobodyAgencyID = "nobody" 28 | 29 | data StateRef 30 | = AnyState 31 | | State !String 32 | deriving (Show, Read, Ord, Eq) 33 | 34 | instance ToJSON StateRef where 35 | toJSON AnyState = Null 36 | toJSON (State str) = toJSON str 37 | 38 | -- | Term-level representation of a typed protocol. 39 | data ProtocolDescription codec = 40 | ProtocolDescription 41 | { protocolName :: String 42 | -- ^ Human-readable protocol name 43 | , protocolDescription :: [Description] 44 | , protocolIdentifier :: String 45 | -- ^ Machine-readable identifier, may be used for things like protocol 46 | -- version negotiation. 47 | , protocolStates :: [(StateRef, [Description], AgencyID)] 48 | -- ^ List of the protocol's possible states, each entry being a state ID, 49 | -- a human-readable description, and an indication of agency (client or 50 | -- server). 51 | , protocolMessages :: [MessageDescription codec] 52 | } 53 | deriving (Show) 54 | 55 | instance ToJSON (ProtocolDescription codec) where 56 | toJSON p = object 57 | [ "name" .= protocolName p 58 | , "description" .= map descriptionParagraphs (protocolDescription p) 59 | , "identifier" .= protocolIdentifier p 60 | , "states" .= 61 | [ object 62 | [ "id" .= stateRef 63 | , "description" .= map descriptionParagraphs desc 64 | , "agency" .= agency 65 | ] 66 | | (stateRef, desc, agency) <- protocolStates p 67 | ] 68 | , "messages" .= protocolMessages p 69 | ] 70 | 71 | -- | Term-level representation of a typed protocol message. 72 | data MessageDescription codec = 73 | MessageDescription 74 | { messageName :: String 75 | , messageDescription :: [Description] 76 | , messagePayload :: [String] 77 | -- ^ List of payload values for this message (free-form descriptions or 78 | -- type names) 79 | , messageFromState :: StateRef 80 | -- ^ References a 'protocolState' in the parent 'ProtocolDescription' by 81 | -- name. 82 | , messageToState :: StateRef 83 | -- ^ References a 'protocolState' in the parent 'ProtocolDescription' by 84 | -- name. 85 | , messageInfo :: FieldInfo codec 86 | } 87 | deriving (Show) 88 | 89 | instance ToJSON (MessageDescription codec) where 90 | toJSON m = object 91 | [ "name" .= messageName m 92 | , "description" .= map descriptionParagraphs (messageDescription m) 93 | , "payload" .= messagePayload m 94 | , "from-state" .= messageFromState m 95 | , "to-state" .= messageToState m 96 | ] 97 | -------------------------------------------------------------------------------- /typed-protocols-doc/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified Network.TypedProtocol.Tests.Documentation as Documentation 4 | 5 | import Test.Tasty 6 | 7 | main :: IO () 8 | main = defaultMain Documentation.tests 9 | -------------------------------------------------------------------------------- /typed-protocols-doc/test/Network/TypedProtocol/Tests/Documentation.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE TemplateHaskell #-} 2 | {-#LANGUAGE DataKinds #-} 3 | 4 | module Network.TypedProtocol.Tests.Documentation 5 | where 6 | 7 | import Test.Tasty 8 | import Test.Tasty.QuickCheck 9 | 10 | import Data.SerDoc.Class 11 | import Data.Maybe 12 | 13 | import Network.TypedProtocol.Documentation 14 | import Network.TypedProtocol.Tests.TestProtocol 15 | import Network.TypedProtocol.Tests.ControlProtocol 16 | 17 | {-# ANN module "HLINT: ignore Use camelCase" #-} 18 | {-# ANN module "HLINT: ignore Move brackets to avoid $" #-} 19 | 20 | tests :: TestTree 21 | tests = testGroup "Documentation" 22 | [ testProperty "no errors" (testProtocolDescription `seq` True) 23 | , testProperty "agencies" (p_correctAgencies testProtocolDescription) 24 | , testProperty "state transitions" (p_correctStateTransitions testProtocolDescription) 25 | ] 26 | 27 | testProtocolDescription :: ProtocolDescription TestCodec 28 | testProtocolDescription = $(describeProtocol ''ControlProtocol [''IO, ''()] ''TestCodec []) 29 | 30 | p_correctAgencies :: ProtocolDescription TestCodec -> Property 31 | p_correctAgencies d = 32 | counterexample (show stateAgencyMap) . 33 | once $ 34 | counterexample "EndState" (lookup (State "EndState") stateAgencyMap === Just NobodyAgencyID) 35 | .&&. 36 | counterexample "InitialState" (lookup (State "InitialState") stateAgencyMap === Just ServerAgencyID) 37 | .&&. 38 | counterexample "IdleState" (lookup (State "IdleState") stateAgencyMap === Just ServerAgencyID) 39 | .&&. 40 | counterexample "WaitForConfirmationState" (lookup (State "WaitForConfirmationState") stateAgencyMap === Just ClientAgencyID) 41 | .&&. 42 | counterexample "WaitForInfoState" (lookup (State "WaitForInfoState") stateAgencyMap === Just ClientAgencyID) 43 | .&&. 44 | counterexample "WaitForPublicKeyState" (lookup (State "WaitForPublicKeyState") stateAgencyMap === Just ClientAgencyID) 45 | where 46 | stateAgencyMap = [(state, agency) | (state, _, agency) <- protocolStates d] 47 | 48 | p_correctStateTransitions :: ProtocolDescription TestCodec -> Property 49 | p_correctStateTransitions d = 50 | once $ 51 | checkMessage "VersionMessage" (State "InitialState") (State "IdleState") 52 | .&&. 53 | checkMessage "GenStagedKeyMessage" (State "IdleState") (State "WaitForPublicKeyState") 54 | .&&. 55 | checkMessage "QueryStagedKeyMessage" (State "IdleState") (State "WaitForPublicKeyState") 56 | .&&. 57 | checkMessage "DropStagedKeyMessage" (State "IdleState") (State "WaitForPublicKeyState") 58 | .&&. 59 | checkMessage "PublicKeyMessage" (State "WaitForPublicKeyState") (State "IdleState") 60 | .&&. 61 | checkMessage "InstallKeyMessage" (State "IdleState") (State "WaitForConfirmationState") 62 | .&&. 63 | checkMessage "InstallResultMessage" (State "WaitForConfirmationState") (State "IdleState") 64 | .&&. 65 | checkMessage "RequestInfoMessage" (State "IdleState") (State "WaitForInfoState") 66 | .&&. 67 | checkMessage "InfoMessage" (State "WaitForInfoState") (State "IdleState") 68 | .&&. 69 | checkMessage "AbortMessage" (State "InitialState") (State "EndState") 70 | .&&. 71 | checkMessage "EndMessage" (State "IdleState") (State "EndState") 72 | .&&. 73 | checkMessage "ProtocolErrorMessage" AnyState (State "EndState") 74 | where 75 | checkMessage :: String -> StateRef -> StateRef -> Property 76 | checkMessage msgName fromState toState = 77 | counterexample msgName $ do 78 | msg <- findMessage msgName 79 | return $ 80 | counterexample "fromState" 81 | (messageFromState msg === fromState) 82 | .&&. 83 | counterexample "toState" 84 | (messageToState msg === toState) 85 | 86 | findMessage :: String -> Maybe (MessageDescription TestCodec) 87 | findMessage msgName = 88 | listToMaybe [ msg | msg <- protocolMessages d, messageName msg == msgName ] 89 | -------------------------------------------------------------------------------- /typed-protocols-doc/test/Network/TypedProtocol/Tests/TestProtocol.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-redundant-constraints #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE EmptyCase #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | 17 | module Network.TypedProtocol.Tests.TestProtocol 18 | where 19 | 20 | import Network.TypedProtocol.Core 21 | import Data.SerDoc.Info 22 | import Control.Monad.Identity 23 | import Control.Monad.Except 24 | import Data.Proxy 25 | import Data.Word 26 | import Data.SerDoc.Class 27 | import Data.SerDoc.TH 28 | import Data.Text (Text) 29 | 30 | data PongInfo = 31 | PongInfo 32 | { pongTimestamp :: Word64 33 | , pongPeerID :: Word64 34 | , pongMessage :: Text 35 | } 36 | deriving (Show, Eq) 37 | 38 | data TestProtocol where 39 | -- | Idle state: server waits for ping. 40 | IdleState :: TestProtocol 41 | 42 | -- | Awaiting pong state: server has received ping, client waits for pong. 43 | AwaitingPongState :: TestProtocol 44 | 45 | -- | End state: either side has terminated the session 46 | EndState :: TestProtocol 47 | 48 | instance Protocol TestProtocol where 49 | data Message TestProtocol st st' where 50 | PingMessage :: Message TestProtocol IdleState AwaitingPongState 51 | PongMessage :: Message TestProtocol AwaitingPongState IdleState 52 | ComplexPongMessage :: Message TestProtocol AwaitingPongState IdleState 53 | EndMessage :: Message TestProtocol st EndState 54 | 55 | type StateAgency IdleState = ServerAgency 56 | type StateAgency AwaitingPongState = ClientAgency 57 | type StateAgency EndState = NobodyAgency 58 | 59 | type StateToken = STestProtocol 60 | 61 | data STestProtocol (st :: TestProtocol) where 62 | SingIdle :: STestProtocol IdleState 63 | SingAwaitingPong :: STestProtocol AwaitingPongState 64 | SingEnd :: STestProtocol EndState 65 | 66 | instance StateTokenI IdleState where stateToken = SingIdle 67 | instance StateTokenI AwaitingPongState where stateToken = SingAwaitingPong 68 | instance StateTokenI EndState where stateToken = SingEnd 69 | 70 | data TestCodec 71 | 72 | instance Codec TestCodec where 73 | type MonadEncode TestCodec = Identity 74 | type MonadDecode TestCodec = Except String 75 | 76 | instance Serializable TestCodec a where 77 | encode _ = pure (pure ()) 78 | decode _ = throwError "this is a mock codec" 79 | 80 | data PongEnum = NormalPong | ComplexPong 81 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 82 | 83 | data PingEnum = PingRequest | EndPing 84 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 85 | 86 | deriving via (ViaEnum PongEnum) 87 | instance (Codec codec, HasInfo codec (DefEnumEncoding codec)) => HasInfo codec PongEnum 88 | 89 | deriving via (ViaEnum PingEnum) 90 | instance (Codec codec, HasInfo codec (DefEnumEncoding codec)) => HasInfo codec PingEnum 91 | 92 | instance HasInfo TestCodec () where 93 | info _ _ = basicField "()" (FixedSize 0) 94 | 95 | instance HasInfo TestCodec Text where 96 | info codec _ = 97 | compoundField "Text" 98 | [ ("length", info codec (Proxy @Word32)) 99 | , ("data", basicField "UTF8 dat" (FixedSize 0)) 100 | ] 101 | 102 | instance HasInfo TestCodec a => HasInfo TestCodec [a] where 103 | info codec (_ :: Proxy [a]) = 104 | compoundField "List" 105 | [ ( "length", info codec (Proxy @Word32)) 106 | , ( "values" 107 | , listField (VarSize "length") (info codec (Proxy @a)) 108 | ) 109 | ] 110 | 111 | 112 | instance HasInfo TestCodec a => HasInfo TestCodec (Maybe a) where 113 | info codec (_ :: Proxy (Maybe a)) = 114 | compoundField "Maybe" 115 | [ ("isJust", info codec (Proxy @Word32)) 116 | , ( "value" 117 | , sumField "isJust" 118 | [ ("Nothing", info codec (Proxy @())) 119 | , ("Just", info codec (Proxy @a)) 120 | ] 121 | ) 122 | ] 123 | 124 | instance HasInfo TestCodec (Message TestProtocol IdleState AwaitingPongState) where 125 | info codec _ = infoOf "PingRequest" $ info codec (Proxy @PingEnum) 126 | 127 | instance HasInfo TestCodec (Message TestProtocol st EndState) where 128 | info codec _ = infoOf "EndPing" $ info codec (Proxy @PingEnum) 129 | 130 | instance HasInfo TestCodec Word16 where 131 | info _ _ = basicField "Word16" (FixedSize 2) 132 | 133 | instance HasInfo TestCodec Word32 where 134 | info _ _ = basicField "Word32" (FixedSize 4) 135 | 136 | instance HasInfo TestCodec Word64 where 137 | info _ _ = basicField "Word64" (FixedSize 8) 138 | 139 | $(deriveSerDoc ''TestCodec [] ''PongInfo) 140 | 141 | instance HasInfo TestCodec (Message TestProtocol AwaitingPongState IdleState) where 142 | info codec _ = 143 | compoundField "Pong" 144 | [ ("pongType", info codec (Proxy @PongEnum)) 145 | , ("pongData" 146 | , choiceField 147 | (IndexField "pongType") 148 | [ info codec (Proxy @()) 149 | , info codec (Proxy @PongInfo) 150 | ] 151 | ) 152 | ] 153 | -------------------------------------------------------------------------------- /typed-protocols-doc/test/Network/TypedProtocol/Tests/TestProtocolTH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | module Network.TypedProtocol.Tests.TestProtocolTH 15 | where 16 | 17 | import Network.TypedProtocol.Documentation.Html 18 | import Network.TypedProtocol.Documentation.Types 19 | import Network.TypedProtocol.Documentation.TH 20 | import Network.TypedProtocol.Tests.TestProtocol 21 | 22 | import Data.SerDoc.Class 23 | import Data.Text (Text) 24 | import qualified Data.Text.Lazy as LText 25 | import Text.Blaze.Html.Renderer.Text (renderHtml) 26 | import qualified Text.Blaze.Html.Renderer.Pretty as Pretty 27 | 28 | testProtocolDescription :: ProtocolDescription TestCodec 29 | testProtocolDescription = $(describeProtocol ''TestProtocol [] ''TestCodec []) 30 | 31 | testProtocolHtmlString :: String 32 | testProtocolHtmlString = 33 | Pretty.renderHtml . wrapDocument $ 34 | renderProtocolDescriptions [testProtocolDescription] 35 | 36 | testProtocolHtmlFile :: FilePath -> IO () 37 | testProtocolHtmlFile path = 38 | writeFile path testProtocolHtmlString 39 | 40 | testProtocolHtml :: Text 41 | testProtocolHtml = 42 | LText.toStrict . renderHtml . wrapDocument $ 43 | renderProtocolDescriptions [testProtocolDescription] 44 | -------------------------------------------------------------------------------- /typed-protocols-doc/typed-protocols-doc.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: typed-protocols-doc 3 | version: 0.2.0.0 4 | synopsis: Derive documentation from typed-protocols source code 5 | description: Derive documentation for protocols implemented with 6 | [typed-protocols](https://hackage.haskell.org/package/typed-protocols). 7 | license: Apache-2.0 8 | license-file: LICENSE 9 | author: Tobias Dammers 10 | maintainer: tobias@well-typed.com 11 | copyright: 2023-2025 Input Output Global Inc (IOG) 12 | category: Network 13 | build-type: Simple 14 | extra-doc-files: CHANGELOG.md 15 | NOTICE 16 | 17 | common warnings 18 | ghc-options: -Wall 19 | -Wno-unticked-promoted-constructors 20 | -Wcompat 21 | -Wincomplete-uni-patterns 22 | -Wincomplete-record-updates 23 | -Wpartial-fields 24 | -Widentities 25 | -Wredundant-constraints 26 | 27 | library 28 | import: warnings 29 | exposed-modules: Network.TypedProtocol.Documentation 30 | , Network.TypedProtocol.Documentation.Types 31 | , Network.TypedProtocol.Documentation.TH 32 | , Network.TypedProtocol.Documentation.Html 33 | , Network.TypedProtocol.Documentation.Text 34 | , Network.TypedProtocol.Documentation.GraphViz 35 | , Network.TypedProtocol.Documentation.DefaultMain 36 | -- other-modules: 37 | -- other-extensions: 38 | build-depends: base >=4.14.0.0 && <5 39 | , aeson >=2.0 && <2.3 40 | , base64-bytestring >=1.2.1.0 && <1.3 41 | , blaze-html >=0.9.1.2 && <0.10 42 | , bytestring >=0.11 && <0.13 43 | , containers >=0.6.8 && <0.8 44 | , fgl >=5.7 && <5.9 45 | , filepath >=1.4.2.2 && <1.6 46 | , graphviz >=2999.20.1 && <2999.21.0 47 | , haddock-library >=1.11.0 && <1.12 48 | , knob >=0.1 && <0.3 49 | , mtl >=2.3.1 && <2.4 50 | , optparse-applicative >=0.18.1.0 && <0.19 51 | , template-haskell >=2.13.0.0 52 | , temporary >=1.3 && <1.4 53 | , text >=1.1 && <2.2 54 | , th-abstraction >=0.6.0.0 && <0.8 55 | , time >=1.12 && <1.14 56 | , serdoc-core 57 | , typed-protocols ^>= 1.0 58 | hs-source-dirs: src 59 | default-language: GHC2021 60 | default-extensions: DataKinds 61 | LambdaCase 62 | 63 | executable typed-protocols-doc-demo 64 | import: warnings 65 | default-language: GHC2021 66 | hs-source-dirs: demo 67 | main-is: Main.hs 68 | other-modules: DemoProtocol 69 | -- other-extensions: 70 | build-depends: base >=4.14.0.0 && <5 71 | , typed-protocols 72 | , typed-protocols-doc 73 | , serdoc-core 74 | , mtl 75 | , text 76 | 77 | 78 | test-suite typed-protocols-doc-test 79 | import: warnings 80 | default-language: GHC2021 81 | type: exitcode-stdio-1.0 82 | hs-source-dirs: test 83 | main-is: Main.hs 84 | other-modules: Network.TypedProtocol.Tests.Documentation 85 | , Network.TypedProtocol.Tests.ControlProtocol 86 | , Network.TypedProtocol.Tests.TestProtocol 87 | , Network.TypedProtocol.Tests.TestProtocolTH 88 | -- other-extensions: 89 | build-depends: base >=4.14.0.0 && <5 90 | , blaze-html >=0.9.1.2 && <0.10 91 | , tasty >=1.5 && <1.6 92 | , tasty-quickcheck >=0.10.3 && <0.11 93 | , typed-protocols 94 | , typed-protocols-doc 95 | , serdoc-core 96 | , text >=1.1 && <2.2 97 | , bytestring >=0.11 && <0.13 98 | , mtl 99 | -------------------------------------------------------------------------------- /typed-protocols/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for typed-protocols 2 | 3 | ## 0.3.0.0 4 | 5 | * `AnyMessageWithAgency` pattern synonym is exported as a constructor of `AnyMessage`. 6 | * Bumped version to agree with `typed-protocols-stateful`. 7 | 8 | ## 0.2.0.0 9 | 10 | * A major redesign of `typed-protocols`. 11 | * `Protocol` class does not require to provide proof obligations for agency. 12 | Proofs are now provided by the framework for all protocols. Agency is now 13 | provided by an associated type family `StateAgency`, and evidence for it, 14 | in form of a singleton, by `StateToken` type family 15 | (similar to `Sing` from the `singletons` package). 16 | * `Peer` takes a different evidence type for agency, 17 | `Network.TypedProtocol.Peer.{Client,Server}` modules provide pattern synonyms 18 | which provide agency evidence and thus are easier to use. 19 | * One `Peer` is provided for both non- and pipelined protocol evolution. 20 | An extra parameter is added of kind `IsPipelined`. As a result 21 | `Outstanding` is now a type family rather than a type alias. 22 | * `ActiveAgency` type class is used to distinguish states in which one side 23 | has an agency (e.g. the protocol hasn't yet terminated), `nonActiveState` can 24 | be used in the same way as `Data.Void.absurd` - which is useful when writing 25 | codecs. 26 | 27 | ## 0.1.1.1 28 | * unbuildable (with `base < 0` constraint in CHaP); We cannot support 29 | `io-classes-1.{6,7}` until `Haskell.Nix` support for public sublibraries is 30 | merged. 31 | 32 | ## 0.1.0.7 -- 2023-10-20 33 | 34 | * Improved performance of `prop_codecs_splitsM` and `prop_codecs_compatM`. 35 | 36 | ## 0.1.0.5 -- 2023-03-08 37 | 38 | * Support `ghc-9.6.1`. 39 | * Use `io-classes-1.1.0.0`. 40 | 41 | [singletons-3.0.1]: https://hackage.haskell.org/package/singletons 42 | -------------------------------------------------------------------------------- /typed-protocols/NOTICE: -------------------------------------------------------------------------------- 1 | Copyright 2019-2025 Input Output Global Inc (IOG) 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | 15 | -------------------------------------------------------------------------------- /typed-protocols/README.md: -------------------------------------------------------------------------------- 1 | ../README.md -------------------------------------------------------------------------------- /typed-protocols/cborg/Network/TypedProtocol/Codec/CBOR.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.Codec.CBOR 2 | ( module Network.TypedProtocol.Codec 3 | , mkCodecCborLazyBS 4 | , mkCodecCborStrictBS 5 | , convertCborDecoderBS 6 | , convertCborDecoderLBS 7 | -- * Re-exports 8 | , CBOR.DeserialiseFailure (..) 9 | ) where 10 | 11 | import Control.Monad.Class.MonadST (MonadST (..)) 12 | import Control.Monad.ST hiding (stToIO) 13 | 14 | import Codec.CBOR.Decoding qualified as CBOR (Decoder) 15 | import Codec.CBOR.Encoding qualified as CBOR (Encoding) 16 | import Codec.CBOR.Read qualified as CBOR 17 | import Codec.CBOR.Write qualified as CBOR 18 | import Data.ByteString qualified as BS 19 | import Data.ByteString.Builder qualified as BS 20 | import Data.ByteString.Builder.Extra qualified as BS 21 | import Data.ByteString.Lazy qualified as LBS 22 | import Data.ByteString.Lazy.Internal qualified as LBS (smallChunkSize) 23 | 24 | import Network.TypedProtocol.Codec 25 | import Network.TypedProtocol.Core 26 | 27 | 28 | -- | Construct a 'Codec' for a CBOR based serialisation format, using strict 29 | -- 'BS.ByteString's. 30 | -- 31 | -- This is an adaptor between the @cborg@ library and the 'Codec' abstraction. 32 | -- 33 | -- It takes encode and decode functions for the protocol messages that use the 34 | -- CBOR library encoder and decoder. 35 | -- 36 | -- Note that this is /less/ efficient than the 'mkCodecCborLazyBS' variant 37 | -- because it has to copy and concatenate the result of the encoder (which 38 | -- natively produces chunks). 39 | -- 40 | mkCodecCborStrictBS 41 | :: forall ps m. MonadST m 42 | 43 | => (forall (st :: ps) (st' :: ps). 44 | StateTokenI st 45 | => ActiveState st 46 | => Message ps st st' -> CBOR.Encoding) 47 | -- ^ cbor encoder 48 | 49 | -> (forall (st :: ps) s. 50 | ActiveState st 51 | => StateToken st 52 | -> CBOR.Decoder s (SomeMessage st)) 53 | -- ^ cbor decoder 54 | 55 | -> Codec ps CBOR.DeserialiseFailure m BS.ByteString 56 | mkCodecCborStrictBS cborMsgEncode cborMsgDecode = 57 | Codec { 58 | encode = \msg -> convertCborEncoder cborMsgEncode msg, 59 | decode = \stok -> convertCborDecoder (cborMsgDecode stok) 60 | } 61 | where 62 | convertCborEncoder :: (a -> CBOR.Encoding) -> a -> BS.ByteString 63 | convertCborEncoder cborEncode = 64 | CBOR.toStrictByteString 65 | . cborEncode 66 | 67 | convertCborDecoder 68 | :: (forall s. CBOR.Decoder s a) 69 | -> m (DecodeStep BS.ByteString CBOR.DeserialiseFailure m a) 70 | convertCborDecoder cborDecode = 71 | convertCborDecoderBS cborDecode stToIO 72 | 73 | convertCborDecoderBS 74 | :: forall s m a. Functor m 75 | => CBOR.Decoder s a 76 | -- ^ cbor decoder 77 | -> (forall b. ST s b -> m b) 78 | -- ^ lift ST computation (e.g. 'Control.Monad.ST.stToIO', 'stToPrim', etc) 79 | -> m (DecodeStep BS.ByteString CBOR.DeserialiseFailure m a) 80 | convertCborDecoderBS cborDecode liftST = 81 | go <$> liftST (CBOR.deserialiseIncremental cborDecode) 82 | where 83 | go :: CBOR.IDecode s a 84 | -> DecodeStep BS.ByteString CBOR.DeserialiseFailure m a 85 | go (CBOR.Done trailing _ x) 86 | | BS.null trailing = DecodeDone x Nothing 87 | | otherwise = DecodeDone x (Just trailing) 88 | go (CBOR.Fail _ _ failure) = DecodeFail failure 89 | go (CBOR.Partial k) = DecodePartial (fmap go . liftST . k) 90 | 91 | 92 | -- | Construct a 'Codec' for a CBOR based serialisation format, using lazy 93 | -- 'BS.ByteString's. 94 | -- 95 | -- This is an adaptor between the @cborg@ library and the 'Codec' abstraction. 96 | -- 97 | -- It takes encode and decode functions for the protocol messages that use the 98 | -- CBOR library encoder and decoder. 99 | -- 100 | mkCodecCborLazyBS 101 | :: forall ps m. MonadST m 102 | 103 | => (forall (st :: ps) (st' :: ps). 104 | StateTokenI st 105 | => ActiveState st 106 | => Message ps st st' -> CBOR.Encoding) 107 | -- ^ cbor encoder 108 | 109 | -> (forall (st :: ps) s. 110 | ActiveState st 111 | => StateToken st 112 | -> CBOR.Decoder s (SomeMessage st)) 113 | -- ^ cbor decoder 114 | 115 | -> Codec ps CBOR.DeserialiseFailure m LBS.ByteString 116 | mkCodecCborLazyBS cborMsgEncode cborMsgDecode = 117 | Codec { 118 | encode = \msg -> convertCborEncoder cborMsgEncode msg, 119 | decode = \stok -> convertCborDecoder (cborMsgDecode stok) 120 | } 121 | where 122 | convertCborEncoder :: (a -> CBOR.Encoding) -> a -> LBS.ByteString 123 | convertCborEncoder cborEncode = 124 | toLazyByteString 125 | . CBOR.toBuilder 126 | . cborEncode 127 | 128 | convertCborDecoder 129 | :: (forall s. CBOR.Decoder s a) 130 | -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m a) 131 | convertCborDecoder cborDecode = 132 | convertCborDecoderLBS cborDecode stToIO 133 | 134 | convertCborDecoderLBS 135 | :: forall s m a. Monad m 136 | => CBOR.Decoder s a 137 | -- ^ cbor decoder 138 | -> (forall b. ST s b -> m b) 139 | -- ^ lift ST computation (e.g. 'Control.Monad.ST.stToIO', 'stToPrim', etc) 140 | -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m a) 141 | convertCborDecoderLBS cborDecode liftST = 142 | go [] =<< liftST (CBOR.deserialiseIncremental cborDecode) 143 | where 144 | -- Have to mediate between a CBOR decoder that consumes strict bytestrings 145 | -- and our choice here that consumes lazy bytestrings. 146 | go :: [BS.ByteString] -> CBOR.IDecode s a 147 | -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m a) 148 | go [] (CBOR.Done trailing _ x) 149 | | BS.null trailing = return (DecodeDone x Nothing) 150 | | otherwise = return (DecodeDone x (Just trailing')) 151 | where trailing' = LBS.fromStrict trailing 152 | go cs (CBOR.Done trailing _ x) = return (DecodeDone x (Just trailing')) 153 | where trailing' = LBS.fromChunks (trailing : cs) 154 | go _ (CBOR.Fail _ _ e) = return (DecodeFail e) 155 | 156 | -- We keep a bunch of chunks and supply the CBOR decoder with them 157 | -- until we run out, when we go get another bunch. 158 | go (c:cs) (CBOR.Partial k) = go cs =<< liftST (k (Just c)) 159 | go [] (CBOR.Partial k) = return $ DecodePartial $ \case 160 | Nothing -> go [] =<< liftST (k Nothing) 161 | Just bs -> go cs (CBOR.Partial k) 162 | where cs = LBS.toChunks bs 163 | 164 | {-# NOINLINE toLazyByteString #-} 165 | toLazyByteString :: BS.Builder -> LBS.ByteString 166 | toLazyByteString = BS.toLazyByteStringWith strategy LBS.empty 167 | where 168 | -- Buffer strategy and sizes better tuned to our network protocol situation. 169 | -- 170 | -- The LBS.smallChunkSize is 4k - heap object overheads, so that 171 | -- it does fit in a 4k overall. 172 | -- 173 | strategy = BS.untrimmedStrategy 800 LBS.smallChunkSize 174 | 175 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/Driver/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | -- @UndecidableInstances@ extensions is required for defining @Show@ instance 3 | -- of @'TraceSendRecv'@. 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | -- | Drivers for running 'Peer's with a 'Codec' and a 'Channel'. 7 | -- 8 | module Network.TypedProtocol.Driver.Simple 9 | ( -- * Introduction 10 | -- $intro 11 | -- * Normal peers 12 | runPeer 13 | , TraceSendRecv (..) 14 | , Role (..) 15 | -- * Pipelined peers 16 | , runPipelinedPeer 17 | -- * Connected peers 18 | , runConnectedPeers 19 | , runConnectedPeersPipelined 20 | , runConnectedPeersAsymmetric 21 | -- * Driver utilities 22 | -- | This may be useful if you want to write your own driver. 23 | , driverSimple 24 | , runDecoderWithChannel 25 | ) where 26 | 27 | import Network.TypedProtocol.Channel 28 | import Network.TypedProtocol.Codec 29 | import Network.TypedProtocol.Core 30 | import Network.TypedProtocol.Driver 31 | import Network.TypedProtocol.Peer 32 | 33 | import Control.Monad.Class.MonadAsync 34 | import Control.Monad.Class.MonadThrow 35 | import Control.Tracer (Tracer (..), contramap, traceWith) 36 | 37 | 38 | -- $intro 39 | -- 40 | -- A 'Peer' is a particular implementation of an agent that engages in a 41 | -- typed protocol. To actualy run one we need a source and sink for the typed 42 | -- protocol messages. These are provided by a 'Channel' and a 'Codec'. The 43 | -- 'Channel' represents one end of an untyped duplex message transport, and 44 | -- the 'Codec' handles conversion between the typed protocol messages and 45 | -- the untyped channel. 46 | -- 47 | -- So given the 'Peer' and a compatible 'Codec' and 'Channel' we can run the 48 | -- peer in some appropriate monad. The peer and codec have to agree on 49 | -- the same protocol and role in that protocol. The codec and channel have to 50 | -- agree on the same untyped medium, e.g. text or bytes. All three have to 51 | -- agree on the same monad in which they will run. 52 | -- 53 | -- This module provides drivers for normal and pipelined peers. There is 54 | -- very little policy involved here so typically it should be possible to 55 | -- use these drivers, and customise things by adjusting the peer, or codec 56 | -- or channel. 57 | -- 58 | -- It is of course possible to write custom drivers and the code for these ones 59 | -- may provide a useful starting point. The 'runDecoder' function may be a 60 | -- helpful utility for use in custom drives. 61 | -- 62 | 63 | -- | Structured 'Tracer' output for 'runPeer' and derivitives. 64 | -- 65 | data TraceSendRecv ps where 66 | TraceSendMsg :: AnyMessage ps -> TraceSendRecv ps 67 | TraceRecvMsg :: AnyMessage ps -> TraceSendRecv ps 68 | 69 | instance Show (AnyMessage ps) => Show (TraceSendRecv ps) where 70 | show (TraceSendMsg msg) = "Send " ++ show msg 71 | show (TraceRecvMsg msg) = "Recv " ++ show msg 72 | 73 | 74 | driverSimple :: forall ps pr failure bytes m. 75 | (MonadThrow m, Exception failure) 76 | => Tracer m (TraceSendRecv ps) 77 | -> Codec ps failure m bytes 78 | -> Channel m bytes 79 | -> Driver ps pr (Maybe bytes) m 80 | driverSimple tracer Codec{encode, decode} channel@Channel{send} = 81 | Driver { sendMessage, recvMessage, initialDState = Nothing } 82 | where 83 | sendMessage :: forall (st :: ps) (st' :: ps). 84 | ( StateTokenI st 85 | , ActiveState st 86 | ) 87 | => ReflRelativeAgency (StateAgency st) 88 | WeHaveAgency 89 | (Relative pr (StateAgency st)) 90 | -> Message ps st st' 91 | -> m () 92 | sendMessage !_refl msg = do 93 | send (encode msg) 94 | traceWith tracer (TraceSendMsg (AnyMessage msg)) 95 | 96 | recvMessage :: forall (st :: ps). 97 | ( StateTokenI st 98 | , ActiveState st 99 | ) 100 | => ReflRelativeAgency (StateAgency st) 101 | TheyHaveAgency 102 | (Relative pr (StateAgency st)) 103 | -> Maybe bytes 104 | -> m (SomeMessage st, Maybe bytes) 105 | recvMessage !_refl trailing = do 106 | decoder <- decode stateToken 107 | result <- runDecoderWithChannel channel trailing decoder 108 | case result of 109 | Right x@(SomeMessage msg, _trailing') -> do 110 | traceWith tracer (TraceRecvMsg (AnyMessage msg)) 111 | return x 112 | Left failure -> 113 | throwIO failure 114 | 115 | 116 | -- | Run a peer with the given channel via the given codec. 117 | -- 118 | -- This runs the peer to completion (if the protocol allows for termination). 119 | -- 120 | runPeer 121 | :: forall ps (st :: ps) pr failure bytes m a. 122 | (MonadThrow m, Exception failure) 123 | => Tracer m (TraceSendRecv ps) 124 | -> Codec ps failure m bytes 125 | -> Channel m bytes 126 | -> Peer ps pr 'NonPipelined st m a 127 | -> m (a, Maybe bytes) 128 | runPeer tracer codec channel peer = 129 | runPeerWithDriver driver peer 130 | where 131 | driver = driverSimple tracer codec channel 132 | 133 | 134 | -- | Run a pipelined peer with the given channel via the given codec. 135 | -- 136 | -- This runs the peer to completion (if the protocol allows for termination). 137 | -- 138 | -- Unlike normal peers, running pipelined peers rely on concurrency, hence the 139 | -- 'MonadSTM' constraint. 140 | -- 141 | runPipelinedPeer 142 | :: forall ps (st :: ps) pr failure bytes m a. 143 | (MonadAsync m, MonadThrow m, Exception failure) 144 | => Tracer m (TraceSendRecv ps) 145 | -> Codec ps failure m bytes 146 | -> Channel m bytes 147 | -> PeerPipelined ps pr st m a 148 | -> m (a, Maybe bytes) 149 | runPipelinedPeer tracer codec channel peer = 150 | runPipelinedPeerWithDriver driver peer 151 | where 152 | driver = driverSimple tracer codec channel 153 | 154 | 155 | -- 156 | -- Utils 157 | -- 158 | 159 | -- | Run a codec incremental decoder 'DecodeStep' against a channel. It also 160 | -- takes any extra input data and returns any unused trailing data. 161 | -- 162 | runDecoderWithChannel :: Monad m 163 | => Channel m bytes 164 | -> Maybe bytes 165 | -> DecodeStep bytes failure m a 166 | -> m (Either failure (a, Maybe bytes)) 167 | 168 | runDecoderWithChannel Channel{recv} = go 169 | where 170 | go _ (DecodeDone x trailing) = return (Right (x, trailing)) 171 | go _ (DecodeFail failure) = return (Left failure) 172 | go Nothing (DecodePartial k) = recv >>= k >>= go Nothing 173 | go (Just trailing) (DecodePartial k) = k (Just trailing) >>= go Nothing 174 | 175 | 176 | data Role = Client | Server 177 | deriving Show 178 | 179 | -- | Run two 'Peer's via a pair of connected 'Channel's and a common 'Codec'. 180 | -- 181 | -- This is useful for tests and quick experiments. 182 | -- 183 | -- The first argument is expected to create two channels that are connected, 184 | -- for example 'createConnectedChannels'. 185 | -- 186 | runConnectedPeers :: (MonadAsync m, MonadCatch m, 187 | Exception failure) 188 | => m (Channel m bytes, Channel m bytes) 189 | -> Tracer m (Role, TraceSendRecv ps) 190 | -> Codec ps failure m bytes 191 | -> Peer ps pr 'NonPipelined st m a 192 | -> Peer ps (FlipAgency pr) 'NonPipelined st m b 193 | -> m (a, b) 194 | runConnectedPeers createChannels tracer codec client server = 195 | createChannels >>= \(clientChannel, serverChannel) -> 196 | 197 | (fst <$> runPeer tracerClient codec clientChannel client) 198 | `concurrently` 199 | (fst <$> runPeer tracerServer codec serverChannel server) 200 | where 201 | tracerClient = contramap ((,) Client) tracer 202 | tracerServer = contramap ((,) Server) tracer 203 | 204 | runConnectedPeersPipelined :: (MonadAsync m, MonadCatch m, 205 | Exception failure) 206 | => m (Channel m bytes, Channel m bytes) 207 | -> Tracer m (PeerRole, TraceSendRecv ps) 208 | -> Codec ps failure m bytes 209 | -> PeerPipelined ps pr st m a 210 | -> Peer ps (FlipAgency pr) 'NonPipelined st m b 211 | -> m (a, b) 212 | runConnectedPeersPipelined createChannels tracer codec client server = 213 | createChannels >>= \(clientChannel, serverChannel) -> 214 | 215 | (fst <$> runPipelinedPeer tracerClient codec clientChannel client) 216 | `concurrently` 217 | (fst <$> runPeer tracerServer codec serverChannel server) 218 | where 219 | tracerClient = contramap ((,) AsClient) tracer 220 | tracerServer = contramap ((,) AsServer) tracer 221 | 222 | 223 | -- Run the same protocol with different codes. This is useful for testing 224 | -- 'Handshake' protocol which knows how to decode different versions. 225 | -- 226 | runConnectedPeersAsymmetric 227 | :: ( MonadAsync m 228 | , MonadMask m 229 | , Exception failure 230 | ) 231 | => m (Channel m bytes, Channel m bytes) 232 | -> Tracer m (Role, TraceSendRecv ps) 233 | -> Codec ps failure m bytes 234 | -> Codec ps failure m bytes 235 | -> PeerPipelined ps pr st m a 236 | -> Peer ps (FlipAgency pr) 'NonPipelined st m b 237 | -> m (a, b) 238 | runConnectedPeersAsymmetric createChannels tracer codec codec' client server = 239 | createChannels >>= \(clientChannel, serverChannel) -> 240 | 241 | (fst <$> runPipelinedPeer tracerClient codec clientChannel client) 242 | `concurrently` 243 | (fst <$> runPeer tracerServer codec' serverChannel server) 244 | where 245 | tracerClient = contramap ((,) Client) tracer 246 | tracerServer = contramap ((,) Server) tracer 247 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/PingPong/Client.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.PingPong.Client 2 | ( -- * Normal client 3 | PingPongClient (..) 4 | , pingPongClientPeer 5 | -- * Pipelined client 6 | , PingPongClientPipelined (..) 7 | , PingPongClientIdle (..) 8 | , pingPongClientPeerPipelined 9 | ) where 10 | 11 | import Network.TypedProtocol.Core 12 | import Network.TypedProtocol.Peer.Client 13 | import Network.TypedProtocol.PingPong.Type 14 | 15 | -- | A ping-pong client, on top of some effect 'm'. 16 | -- 17 | -- At each step the client has a choice: ping or stop. 18 | -- 19 | -- This type encodes the pattern of state transitions the client can go through. 20 | -- For the ping\/pong case this is trivial. We start from one main state, 21 | -- issue a ping and move into a state where we expect a single response, 22 | -- bringing us back to the same main state. 23 | -- 24 | -- If we had another state in which a different set of options were available 25 | -- then we would need a second type like this. The two would be mutually 26 | -- recursive if we can get in both directions, or perhaps just one way such 27 | -- as a special initialising state or special terminating state. 28 | -- 29 | data PingPongClient m a where 30 | -- | Choose to go for sending a ping message. The ping has no body so 31 | -- all we have to provide here is a continuation for the single legal 32 | -- reply message. 33 | -- 34 | SendMsgPing :: m (PingPongClient m a) -- continuation for Pong response 35 | -> PingPongClient m a 36 | 37 | -- | Choose to terminate the protocol. This is an actual but nullary message, 38 | -- we terminate with the local result value. So this ends up being much like 39 | -- 'return' in this case, but in general the termination is a message that 40 | -- can communicate final information. 41 | -- 42 | SendMsgDone :: a -> PingPongClient m a 43 | 44 | 45 | -- | Interpret a particular client action sequence into the client side of the 46 | -- 'PingPong' protocol. 47 | -- 48 | pingPongClientPeer 49 | :: Functor m 50 | => PingPongClient m a 51 | -> Client PingPong NonPipelined StIdle m a 52 | 53 | pingPongClientPeer (SendMsgDone result) = 54 | -- We do an actual transition using 'yield', to go from the 'StIdle' to 55 | -- 'StDone' state. Once in the 'StDone' state we can actually stop using 56 | -- 'done', with a return value. 57 | Yield MsgDone (Done result) 58 | 59 | pingPongClientPeer (SendMsgPing next) = 60 | 61 | -- Send our message. 62 | Yield MsgPing $ 63 | 64 | -- The type of our protocol means that we're now into the 'StBusy' state 65 | -- and the only thing we can do next is local effects or wait for a reply. 66 | -- We'll wait for a reply. 67 | Await $ \MsgPong -> 68 | 69 | -- Now in this case there is only one possible response, and we have 70 | -- one corresponding continuation 'kPong' to handle that response. 71 | -- The pong reply has no content so there's nothing to pass to our 72 | -- continuation, but if there were we would. 73 | Effect $ pingPongClientPeer <$> next 74 | 75 | 76 | -- 77 | -- Pipelined client 78 | -- 79 | 80 | -- | A ping-pong client designed for running the 'PingPong' protocol in 81 | -- a pipelined way. 82 | -- 83 | data PingPongClientPipelined c m a where 84 | -- | A 'PingPongSender', but starting with zero outstanding pipelined 85 | -- responses, and for any internal collect type @c@. 86 | PingPongClientPipelined :: 87 | PingPongClientIdle Z c m a 88 | -> PingPongClientPipelined c m a 89 | 90 | 91 | data PingPongClientIdle (n :: N) c m a where 92 | -- | Send a `Ping` message but alike in `PingPongClient` do not await for the 93 | -- response, instead supply a monadic action which will run on a received 94 | -- `Pong` message. 95 | -- 96 | SendMsgPingPipelined 97 | :: m c 98 | -> PingPongClientIdle (S n) c m a -- continuation 99 | -> PingPongClientIdle n c m a 100 | 101 | -- | Collect the result of a previous pipelined receive action. 102 | -- 103 | -- This (optionally) provides two choices: 104 | -- 105 | -- * Continue without a pipelined result 106 | -- * Continue with a pipelined result, which allows to run a monadic action 107 | -- when 'MsgPong' is received. 108 | -- 109 | -- Since presenting the first choice is optional, this allows expressing 110 | -- both a blocking collect and a non-blocking collect. This allows 111 | -- implementations to express policies such as sending a short sequence 112 | -- of messages and then waiting for all replies, but also a maximum pipelining 113 | -- policy that keeps a large number of messages in flight but collects results 114 | -- eagerly. 115 | -- 116 | CollectPipelined 117 | :: Maybe (PingPongClientIdle (S n) c m a) 118 | -> (c -> (PingPongClientIdle n c m a)) 119 | -> PingPongClientIdle (S n) c m a 120 | 121 | -- | Termination of the ping-pong protocol. 122 | -- 123 | -- Note that all pipelined results must be collected before terminating. 124 | -- 125 | SendMsgDonePipelined 126 | :: a -> PingPongClientIdle Z c m a 127 | 128 | 129 | 130 | -- | Interpret a pipelined client as a pipelined 'Peer' on the client side of 131 | -- the 'PingPong' protocol. 132 | -- 133 | pingPongClientPeerPipelined 134 | :: Functor m 135 | => PingPongClientPipelined c m a 136 | -> ClientPipelined PingPong StIdle m a 137 | pingPongClientPeerPipelined (PingPongClientPipelined peer) = 138 | ClientPipelined $ pingPongClientPeerIdle peer 139 | 140 | 141 | pingPongClientPeerIdle 142 | :: forall (n :: N) c m a. Functor m 143 | => PingPongClientIdle n c m a 144 | -> Client PingPong (Pipelined n c) StIdle m a 145 | pingPongClientPeerIdle = go 146 | where 147 | go :: forall (n' :: N). 148 | PingPongClientIdle n' c m a 149 | -> Client PingPong (Pipelined n' c) StIdle m a 150 | 151 | go (SendMsgPingPipelined receive next) = 152 | -- Pipelined yield: send `MsgPing`, immediately follow with the next step. 153 | YieldPipelined 154 | MsgPing 155 | (ReceiverAwait $ \MsgPong -> 156 | ReceiverEffect $ ReceiverDone <$> receive) 157 | (go next) 158 | 159 | go (CollectPipelined mNone collect) = 160 | Collect 161 | (go <$> mNone) 162 | (go . collect) 163 | 164 | go (SendMsgDonePipelined result) = 165 | -- Send `MsgDone` and complete the protocol 166 | Yield 167 | MsgDone 168 | (Done result) 169 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/PingPong/Codec.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.PingPong.Codec where 2 | 3 | import Network.TypedProtocol.Codec 4 | import Network.TypedProtocol.Core 5 | import Network.TypedProtocol.PingPong.Type 6 | 7 | 8 | codecPingPong 9 | :: forall m. Monad m 10 | => Codec PingPong CodecFailure m String 11 | codecPingPong = 12 | Codec{encode, decode} 13 | where 14 | encode :: forall (st :: PingPong) (st' :: PingPong). 15 | Message PingPong st st' 16 | -> String 17 | encode MsgPing = "ping\n" 18 | encode MsgDone = "done\n" 19 | encode MsgPong = "pong\n" 20 | 21 | decode :: forall (st :: PingPong). 22 | ActiveState st 23 | => StateToken st 24 | -> m (DecodeStep String CodecFailure m (SomeMessage st)) 25 | decode stok = 26 | decodeTerminatedFrame '\n' $ \str trailing -> 27 | case (stok, str) of 28 | (SingBusy, "pong") -> 29 | DecodeDone (SomeMessage MsgPong) trailing 30 | (SingIdle, "ping") -> 31 | DecodeDone (SomeMessage MsgPing) trailing 32 | (SingIdle, "done") -> 33 | DecodeDone (SomeMessage MsgDone) trailing 34 | 35 | (_ , _ ) -> DecodeFail failure 36 | where failure = CodecFailure ("unexpected server message: " ++ str) 37 | 38 | 39 | decodeTerminatedFrame :: forall m a. 40 | Monad m 41 | => Char 42 | -> (String -> Maybe String -> DecodeStep String CodecFailure m a) 43 | -> m (DecodeStep String CodecFailure m a) 44 | decodeTerminatedFrame terminator k = go [] 45 | where 46 | go :: [String] -> m (DecodeStep String CodecFailure m a) 47 | go chunks = 48 | return $ DecodePartial $ \mchunk -> 49 | case mchunk of 50 | Nothing -> return $ DecodeFail CodecFailureOutOfInput 51 | Just chunk -> 52 | case break (==terminator) chunk of 53 | (c, _:c') -> return $ k (concat (reverse (c:chunks))) 54 | (if null c' then Nothing else Just c) 55 | _ -> go (chunk : chunks) 56 | 57 | 58 | 59 | codecPingPongId 60 | :: forall m. Monad m 61 | => Codec PingPong CodecFailure m (AnyMessage PingPong) 62 | codecPingPongId = 63 | Codec{encode,decode} 64 | where 65 | encode :: forall (st :: PingPong) (st' :: PingPong) 66 | . ( StateTokenI st 67 | , ActiveState st 68 | ) 69 | => Message PingPong st st' 70 | -> AnyMessage PingPong 71 | encode msg = AnyMessage msg 72 | 73 | decode :: forall (st :: PingPong). 74 | ActiveState st 75 | => StateToken st 76 | -> m (DecodeStep (AnyMessage PingPong) CodecFailure m (SomeMessage st)) 77 | decode stok = 78 | pure $ DecodePartial $ \mb -> 79 | case mb of 80 | Nothing -> return $ DecodeFail (CodecFailure "expected more data") 81 | Just (AnyMessage msg) -> return $ 82 | case (stok, msg) of 83 | (SingBusy, MsgPong) -> 84 | DecodeDone (SomeMessage msg) Nothing 85 | (SingIdle, MsgPing) -> 86 | DecodeDone (SomeMessage msg) Nothing 87 | (SingIdle, MsgDone) -> 88 | DecodeDone (SomeMessage msg) Nothing 89 | 90 | (SingIdle, _) -> 91 | DecodeFail failure 92 | where failure = CodecFailure ("unexpected client message: " ++ show msg) 93 | (SingBusy, _) -> 94 | DecodeFail failure 95 | where failure = CodecFailure ("unexpected server message: " ++ show msg) 96 | 97 | (a@SingDone, _) -> notActiveState a 98 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/PingPong/Codec/CBOR.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.PingPong.Codec.CBOR where 2 | 3 | import Control.Monad.Class.MonadST 4 | 5 | import Data.ByteString.Lazy (ByteString) 6 | 7 | import Codec.CBOR.Decoding qualified as CBOR (Decoder, decodeWord) 8 | import Codec.CBOR.Encoding qualified as CBOR (Encoding, encodeWord) 9 | import Codec.CBOR.Read qualified as CBOR 10 | 11 | import Network.TypedProtocol.Codec 12 | import Network.TypedProtocol.Codec.CBOR 13 | import Network.TypedProtocol.Core 14 | import Network.TypedProtocol.PingPong.Type 15 | 16 | codecPingPong 17 | :: forall m. 18 | MonadST m 19 | => Codec PingPong CBOR.DeserialiseFailure m ByteString 20 | codecPingPong = mkCodecCborLazyBS encodeMsg decodeMsg 21 | where 22 | encodeMsg :: forall st st'. 23 | Message PingPong st st' 24 | -> CBOR.Encoding 25 | encodeMsg MsgPing = CBOR.encodeWord 0 26 | encodeMsg MsgPong = CBOR.encodeWord 1 27 | encodeMsg MsgDone = CBOR.encodeWord 2 28 | 29 | decodeMsg :: forall s (st :: PingPong). 30 | ActiveState st 31 | => StateToken st 32 | -> CBOR.Decoder s (SomeMessage st) 33 | decodeMsg stok = do 34 | key <- CBOR.decodeWord 35 | case (stok, key) of 36 | (SingIdle, 0) -> return $ SomeMessage MsgPing 37 | (SingBusy, 1) -> return $ SomeMessage MsgPong 38 | (SingIdle, 2) -> return $ SomeMessage MsgDone 39 | 40 | -- TODO proper exceptions 41 | (SingIdle, _) -> fail "codecPingPong.StIdle: unexpected key" 42 | (SingBusy, _) -> fail "codecPingPong.StBusy: unexpected key" 43 | (a@SingDone, _) -> notActiveState a 44 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/PingPong/Examples.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.PingPong.Examples where 2 | 3 | import Network.TypedProtocol.PingPong.Client 4 | import Network.TypedProtocol.PingPong.Server 5 | 6 | import Network.TypedProtocol.Peer.Client 7 | 8 | 9 | -- | The standard stateless ping-pong server instance. 10 | -- 11 | pingPongServerStandard 12 | :: Applicative m 13 | => PingPongServer m () 14 | pingPongServerStandard = 15 | PingPongServer { 16 | recvMsgPing = pure pingPongServerStandard, 17 | recvMsgDone = () 18 | } 19 | 20 | 21 | -- | An example ping-pong server instance that counts the number of ping 22 | -- messages. 23 | -- 24 | pingPongServerCount 25 | :: Applicative m 26 | => PingPongServer m Int 27 | pingPongServerCount = go 0 28 | where 29 | go !c = PingPongServer { 30 | recvMsgPing = pure $ go (succ c), 31 | recvMsgDone = c 32 | } 33 | 34 | 35 | -- | An example ping-pong client that sends pings as fast as possible forever‽ 36 | -- 37 | -- This may not be a good idea‼ 38 | -- 39 | pingPongClientFlood :: Applicative m => PingPongClient m a 40 | pingPongClientFlood = SendMsgPing (pure pingPongClientFlood) 41 | 42 | 43 | -- | An example ping-pong client that sends a fixed number of ping messages 44 | -- and then stops. 45 | -- 46 | pingPongClientCount :: Applicative m => Int -> PingPongClient m () 47 | pingPongClientCount 0 = SendMsgDone () 48 | pingPongClientCount n = SendMsgPing (pure (pingPongClientCount (n-1))) 49 | 50 | 51 | -- 52 | -- Pipelined examples 53 | -- 54 | 55 | -- | A pipelined ping-pong client that sends eagerly rather than waiting to 56 | -- collect any replies. This is maximum pipelining in some sense, and 57 | -- correspondingly it gives minimum choice to the environment (drivers). 58 | -- 59 | -- It returns the interleaving of ping indexes sent, and collected. 60 | -- 61 | pingPongClientPipelinedMax 62 | :: forall m. Monad m 63 | => Int 64 | -> PingPongClientPipelined Int m [Either Int Int] 65 | pingPongClientPipelinedMax c = 66 | PingPongClientPipelined (go [] Zero 0) 67 | where 68 | go :: [Either Int Int] -> Nat o -> Int 69 | -> PingPongClientIdle o Int m [Either Int Int] 70 | go acc o n | n < c 71 | = SendMsgPingPipelined 72 | (return n) 73 | (go (Left n : acc) (Succ o) (succ n)) 74 | go acc Zero _ = SendMsgDonePipelined (reverse acc) 75 | go acc (Succ o) n = CollectPipelined 76 | Nothing 77 | (\n' -> go (Right n' : acc) o n) 78 | 79 | 80 | -- | A pipelined ping-pong client that sends eagerly but always tries to 81 | -- collect any replies if they are available. This allows pipelining but 82 | -- keeps it to a minimum, and correspondingly it gives maximum choice to the 83 | -- environment (drivers). 84 | -- 85 | -- It returns the interleaving of ping indexes sent, and collected. 86 | -- 87 | pingPongClientPipelinedMin 88 | :: forall m. Monad m 89 | => Int 90 | -> PingPongClientPipelined Int m [Either Int Int] 91 | pingPongClientPipelinedMin c = 92 | PingPongClientPipelined (go [] Zero 0) 93 | where 94 | go :: [Either Int Int] -> Nat o -> Int 95 | -> PingPongClientIdle o Int m [Either Int Int] 96 | go acc (Succ o) n = CollectPipelined 97 | (if n < c then Just (ping acc (Succ o) n) 98 | else Nothing) 99 | (\n' -> go (Right n' : acc) o n) 100 | go acc Zero n | n < c 101 | = ping acc Zero n 102 | go acc Zero _ = SendMsgDonePipelined (reverse acc) 103 | 104 | ping :: [Either Int Int] -> Nat o -> Int 105 | -> PingPongClientIdle o Int m [Either Int Int] 106 | ping acc o n = SendMsgPingPipelined 107 | (return n) 108 | (go (Left n : acc) (Succ o) (succ n)) 109 | 110 | 111 | -- | A pipelined ping-pong client that sends eagerly up to some maximum limit 112 | -- of outstanding requests. It is also always ready to collect any replies if 113 | -- they are available. This allows limited pipelining and correspondingly 114 | -- limited choice to the environment (drivers). 115 | -- 116 | -- It returns the interleaving of ping indexes sent, and collected. 117 | -- 118 | pingPongClientPipelinedLimited 119 | :: forall m. Monad m 120 | => Int -> Int 121 | -> PingPongClientPipelined Int m [Either Int Int] 122 | pingPongClientPipelinedLimited omax c = 123 | PingPongClientPipelined (go [] Zero 0) 124 | where 125 | go :: [Either Int Int] -> Nat o -> Int 126 | -> PingPongClientIdle o Int m [Either Int Int] 127 | go acc (Succ o) n = CollectPipelined 128 | (if n < c && int (Succ o) < omax 129 | then Just (ping acc (Succ o) n) 130 | else Nothing) 131 | (\n' -> go (Right n' : acc) o n) 132 | go acc Zero n | n < c 133 | = ping acc Zero n 134 | go acc Zero _ = SendMsgDonePipelined (reverse acc) 135 | 136 | ping :: [Either Int Int] -> Nat o -> Int 137 | -> PingPongClientIdle o Int m [Either Int Int] 138 | ping acc o n = SendMsgPingPipelined 139 | (return n) 140 | (go (Left n : acc) (Succ o) (succ n)) 141 | 142 | -- this isn't supposed to be efficient, it's just for the example 143 | int :: Nat n -> Int 144 | int Zero = 0 145 | int (Succ n) = succ (int n) 146 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/PingPong/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Network.TypedProtocol.PingPong.Server where 4 | 5 | import Network.TypedProtocol.Core 6 | import Network.TypedProtocol.Peer.Server 7 | import Network.TypedProtocol.PingPong.Type 8 | 9 | 10 | data PingPongServer m a = PingPongServer { 11 | -- | The client sent us a ping message. We have no choices here, and 12 | -- the response is nullary, all we have are local effects. 13 | recvMsgPing :: m (PingPongServer m a) 14 | 15 | -- | The client terminated. Here we have a pure return value, but we 16 | -- could have done another action in 'm' if we wanted to. 17 | , recvMsgDone :: a 18 | } 19 | 20 | 21 | -- | Interpret a particular server action sequence into the server side of the 22 | -- 'PingPong' protocol. 23 | -- 24 | pingPongServerPeer 25 | :: Monad m 26 | => PingPongServer m a 27 | -> Server PingPong NonPipelined StIdle m a 28 | pingPongServerPeer PingPongServer{..} = 29 | 30 | -- In the 'StIdle' the server is awaiting a request message 31 | Await $ \req -> 32 | 33 | -- The client got to choose between two messages and we have to handle 34 | -- either of them 35 | case req of 36 | 37 | -- The client sent the done transition, so we're in the 'StDone' state 38 | -- so all we can do is stop using 'done', with a return value. 39 | MsgDone -> Done recvMsgDone 40 | 41 | -- The client sent us a ping request, so now we're in the 'StBusy' state 42 | -- which means it's the server's turn to send. 43 | MsgPing -> Effect $ do 44 | next <- recvMsgPing 45 | pure $ Yield MsgPong (pingPongServerPeer next) 46 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/PingPong/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Network.TypedProtocol.PingPong.Type where 4 | 5 | import Network.TypedProtocol.Core 6 | 7 | 8 | -- | The ping\/pong protocol and the states in its protocol state machine. 9 | -- 10 | -- This protocol serves as a simple example of the typed protocols framework 11 | -- to help understand the framework and as a template for writing other 12 | -- protocols. 13 | -- 14 | -- For a slightly more realistic example, see the request\/response protocol 15 | -- "Network.TypedProtocol.ResResp.Type". 16 | -- 17 | -- This declares the protocol itself. It is used both as a type level tag for 18 | -- the protocol and as the kind of the types of the states in the protocol 19 | -- state machine. That is @PingPong@ is a kind, and @StIdle@ is a type of 20 | -- that kind. 21 | -- 22 | -- If the protocol needs any type parameters (e.g. for thing that end up in 23 | -- the messages) then those type parameters go here. See the request\/response 24 | -- protocol for an example. It is parametrised over the types of the request 25 | -- and response. 26 | -- 27 | data PingPong where 28 | StIdle :: PingPong 29 | StBusy :: PingPong 30 | StDone :: PingPong 31 | 32 | data SPingPong (st :: PingPong) where 33 | SingIdle :: SPingPong StIdle 34 | SingBusy :: SPingPong StBusy 35 | SingDone :: SPingPong StDone 36 | 37 | deriving instance Show (SPingPong st) 38 | 39 | instance StateTokenI StIdle where stateToken = SingIdle 40 | instance StateTokenI StBusy where stateToken = SingBusy 41 | instance StateTokenI StDone where stateToken = SingDone 42 | 43 | instance Protocol PingPong where 44 | 45 | -- | The actual messages in our protocol. 46 | -- 47 | -- These involve transitions between different states within the 'PingPong' 48 | -- states. A ping request goes from idle to busy, and a pong response go from 49 | -- busy to idle. 50 | -- 51 | -- This example is so simple that we have all the messages directly as 52 | -- constructors within this type. In more complex cases it may be better to 53 | -- factor all (or related) requests and all responses within one case (in 54 | -- which case the state transitions may depend on the particular message via 55 | -- the usual GADT tricks). 56 | -- 57 | data Message PingPong from to where 58 | MsgPing :: Message PingPong StIdle StBusy 59 | MsgPong :: Message PingPong StBusy StIdle 60 | MsgDone :: Message PingPong StIdle StDone 61 | 62 | type StateAgency StIdle = ClientAgency 63 | type StateAgency StBusy = ServerAgency 64 | type StateAgency StDone = NobodyAgency 65 | 66 | type StateToken = SPingPong 67 | 68 | 69 | deriving instance Show (Message PingPong from to) 70 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/ReqResp/Client.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.ReqResp.Client 2 | ( -- * Normal client 3 | ReqRespClient (..) 4 | , reqRespClientPeer 5 | -- * Pipelined client 6 | , ReqRespClientPipelined (..) 7 | , reqRespClientPeerPipelined 8 | , ReqRespIdle (..) 9 | , reqRespClientPeerIdle 10 | -- * Request once 11 | , requestOnce 12 | ) where 13 | 14 | import Network.TypedProtocol.Core 15 | import Network.TypedProtocol.Peer.Client 16 | import Network.TypedProtocol.Peer.Server (Server) 17 | import Network.TypedProtocol.Proofs (connect) 18 | import Network.TypedProtocol.ReqResp.Type 19 | 20 | data ReqRespClient req resp m a where 21 | SendMsgReq :: req 22 | -> (resp -> m (ReqRespClient req resp m a)) 23 | -> ReqRespClient req resp m a 24 | 25 | SendMsgDone :: m a -> ReqRespClient req resp m a 26 | 27 | 28 | -- | Interpret a particular client action sequence into the client side of the 29 | -- 'ReqResp' protocol. 30 | -- 31 | reqRespClientPeer 32 | :: Monad m 33 | => ReqRespClient req resp m a 34 | -> Client (ReqResp req resp) NonPipelined StIdle m a 35 | 36 | reqRespClientPeer (SendMsgDone result) = 37 | -- We do an actual transition using 'yield', to go from the 'StIdle' to 38 | -- 'StDone' state. Once in the 'StDone' state we can actually stop using 39 | -- 'done', with a return value. 40 | Effect $ 41 | Yield MsgDone . Done <$> result 42 | 43 | reqRespClientPeer (SendMsgReq req next) = 44 | 45 | -- Send our message. 46 | Yield (MsgReq req) $ 47 | 48 | -- The type of our protocol means that we're now into the 'StBusy' state 49 | -- and the only thing we can do next is local effects or wait for a reply. 50 | -- We'll wait for a reply. 51 | Await $ \(MsgResp resp) -> 52 | 53 | -- Now in this case there is only one possible response, and we have 54 | -- one corresponding continuation 'kPong' to handle that response. 55 | -- The pong reply has no content so there's nothing to pass to our 56 | -- continuation, but if there were we would. 57 | Effect $ do 58 | client <- next resp 59 | pure $ reqRespClientPeer client 60 | 61 | 62 | 63 | requestOnce :: forall req resp m. 64 | Monad m 65 | => (forall x. Server (ReqResp req resp) NonPipelined StIdle m x) 66 | -> (req -> m resp) 67 | requestOnce server req = (\(resp, _, _) -> resp) 68 | <$> reqRespClientPeer client `connect` server 69 | where 70 | client :: ReqRespClient req resp m resp 71 | client = SendMsgReq req $ \resp -> pure $ SendMsgDone (pure resp) 72 | 73 | 74 | -- 75 | -- Pipelined client 76 | -- 77 | 78 | -- | A request-response client designed for running the 'ReqResp' protocol in 79 | -- a pipelined way. 80 | -- 81 | data ReqRespClientPipelined req resp m a where 82 | -- | A 'PingPongSender', but starting with zero outstanding pipelined 83 | -- responses, and for any internal collect type @c@. 84 | ReqRespClientPipelined :: 85 | ReqRespIdle req resp Z c m a 86 | -> ReqRespClientPipelined req resp m a 87 | 88 | 89 | data ReqRespIdle req resp n c m a where 90 | -- | Send a `Req` message but alike in `ReqRespClient` do not await for the 91 | -- resopnse, instead supply a monadic action which will run on a received 92 | -- `Pong` message. 93 | SendMsgReqPipelined 94 | :: req 95 | -> (resp -> m c) -- receive action 96 | -> ReqRespIdle req resp (S n) c m a -- continuation 97 | -> ReqRespIdle req resp n c m a 98 | 99 | CollectPipelined 100 | :: Maybe (ReqRespIdle req resp (S n) c m a) 101 | -> (c -> m (ReqRespIdle req resp n c m a)) 102 | -> ReqRespIdle req resp (S n) c m a 103 | 104 | -- | Termination of the req-resp protocol. 105 | SendMsgDonePipelined 106 | :: a -> ReqRespIdle req resp Z c m a 107 | 108 | 109 | -- | Interpret a pipelined client as a 'Peer' on the client side of 110 | -- the 'ReqResp' protocol. 111 | -- 112 | reqRespClientPeerPipelined 113 | :: Functor m 114 | => ReqRespClientPipelined req resp m a 115 | -> ClientPipelined (ReqResp req resp) StIdle m a 116 | reqRespClientPeerPipelined (ReqRespClientPipelined peer) = 117 | ClientPipelined $ reqRespClientPeerIdle peer 118 | 119 | 120 | reqRespClientPeerIdle 121 | :: forall req resp n c m a. 122 | Functor m 123 | => ReqRespIdle req resp n c m a 124 | -> Client (ReqResp req resp) (Pipelined n c) StIdle m a 125 | 126 | reqRespClientPeerIdle = go 127 | where 128 | go :: forall n'. 129 | ReqRespIdle req resp n' c m a 130 | -> Client (ReqResp req resp) (Pipelined n' c) StIdle m a 131 | 132 | go (SendMsgReqPipelined req receive next) = 133 | -- Pipelined yield: send `MsgReq`, immediately follow with the next step. 134 | -- Await for a response in a continuation. 135 | YieldPipelined 136 | (MsgReq req) 137 | (ReceiverAwait $ \(MsgResp resp) -> 138 | ReceiverEffect $ 139 | ReceiverDone <$> receive resp 140 | ) 141 | (go next) 142 | 143 | go (CollectPipelined mNone collect) = 144 | Collect 145 | (go <$> mNone) 146 | (\c -> Effect $ go <$> collect c) 147 | 148 | go (SendMsgDonePipelined result) = 149 | -- Send `MsgDone` and complete the protocol 150 | Yield 151 | MsgDone 152 | (Done result) 153 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/ReqResp/Codec.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.ReqResp.Codec where 2 | 3 | import Network.TypedProtocol.Codec 4 | import Network.TypedProtocol.Core 5 | import Network.TypedProtocol.PingPong.Codec (decodeTerminatedFrame) 6 | import Network.TypedProtocol.ReqResp.Type 7 | import Text.Read (readMaybe) 8 | 9 | 10 | codecReqResp :: 11 | forall req resp m 12 | . (Monad m, Show req, Show resp, Read req, Read resp) 13 | => Codec (ReqResp req resp) CodecFailure m String 14 | codecReqResp = 15 | Codec{encode, decode} 16 | where 17 | encode :: forall req' resp' 18 | (st :: ReqResp req' resp') 19 | (st' :: ReqResp req' resp') 20 | . ( Show (Message (ReqResp req' resp') st st') ) 21 | => Message (ReqResp req' resp') st st' 22 | -> String 23 | encode msg = show msg ++ "\n" 24 | 25 | decode :: forall req' resp' m' 26 | (st :: ReqResp req' resp') 27 | . (Monad m', Read req', Read resp', ActiveState st) 28 | => StateToken st 29 | -> m' (DecodeStep String CodecFailure m' (SomeMessage st)) 30 | decode stok = 31 | decodeTerminatedFrame '\n' $ \str trailing -> 32 | case (stok, break (==' ') str) of 33 | (SingIdle, ("MsgReq", str')) 34 | | Just req <- readMaybe str' 35 | -> DecodeDone (SomeMessage (MsgReq req)) trailing 36 | (SingIdle, ("MsgDone", "")) 37 | -> DecodeDone (SomeMessage MsgDone) trailing 38 | (SingBusy, ("MsgResp", str')) 39 | | Just resp <- readMaybe str' 40 | -> DecodeDone (SomeMessage (MsgResp resp)) trailing 41 | 42 | (_ , _ ) -> DecodeFail failure 43 | where failure = CodecFailure ("unexpected server message: " ++ str) 44 | 45 | 46 | codecReqRespId :: 47 | forall req resp m 48 | . (Monad m, Show req, Show resp) 49 | => Codec (ReqResp req resp) CodecFailure m (AnyMessage (ReqResp req resp)) 50 | codecReqRespId = 51 | Codec{encode, decode} 52 | where 53 | encode :: forall (st :: ReqResp req resp) 54 | (st' :: ReqResp req resp) 55 | . StateTokenI st 56 | => ActiveState st 57 | => Message (ReqResp req resp) st st' 58 | -> AnyMessage (ReqResp req resp) 59 | encode msg = AnyMessage msg 60 | 61 | decode :: forall (st :: ReqResp req resp) 62 | . ActiveState st 63 | => StateToken st 64 | -> m (DecodeStep (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)) 65 | decode stok = 66 | pure $ DecodePartial $ \mb -> 67 | case mb of 68 | Nothing -> return $ DecodeFail (CodecFailure "expected more data") 69 | Just (AnyMessage msg) -> return $ 70 | case (stok, msg) of 71 | (SingIdle, MsgReq{}) 72 | -> DecodeDone (SomeMessage msg) Nothing 73 | (SingIdle, MsgDone) 74 | -> DecodeDone (SomeMessage msg) Nothing 75 | (SingBusy, MsgResp{}) 76 | -> DecodeDone (SomeMessage msg) Nothing 77 | 78 | (SingIdle, _) -> 79 | DecodeFail failure 80 | where failure = CodecFailure ("unexpected client message: " ++ show msg) 81 | (SingBusy, _) -> 82 | DecodeFail failure 83 | where failure = CodecFailure ("unexpected server message: " ++ show msg) 84 | 85 | (a@SingDone, _) -> notActiveState a 86 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/ReqResp/Codec/CBOR.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.ReqResp.Codec.CBOR where 2 | 3 | import Control.Monad.Class.MonadST 4 | 5 | import Data.ByteString.Lazy (ByteString) 6 | 7 | import Codec.CBOR.Decoding qualified as CBOR (Decoder, decodeListLen, 8 | decodeWord) 9 | import Codec.CBOR.Encoding qualified as CBOR (Encoding, encodeListLen, 10 | encodeWord) 11 | import Codec.CBOR.Read qualified as CBOR 12 | import Codec.Serialise.Class (Serialise) 13 | import Codec.Serialise.Class qualified as CBOR 14 | 15 | import Network.TypedProtocol.Codec 16 | import Network.TypedProtocol.Codec.CBOR 17 | import Network.TypedProtocol.Core 18 | import Network.TypedProtocol.ReqResp.Type 19 | 20 | codecReqResp 21 | :: forall req resp m. 22 | ( MonadST m 23 | , Serialise req 24 | , Serialise resp 25 | ) 26 | => Codec (ReqResp req resp) CBOR.DeserialiseFailure m ByteString 27 | codecReqResp = mkCodecCborLazyBS encodeMsg decodeMsg 28 | where 29 | encodeMsg :: forall st st'. 30 | Message (ReqResp req resp) st st' 31 | -> CBOR.Encoding 32 | encodeMsg (MsgReq req) = 33 | CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> CBOR.encode req 34 | encodeMsg (MsgResp resp) = 35 | CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> CBOR.encode resp 36 | encodeMsg MsgDone = 37 | CBOR.encodeListLen 1 <> CBOR.encodeWord 2 38 | 39 | decodeMsg :: forall s (st :: ReqResp req resp). 40 | ActiveState st 41 | => StateToken st 42 | -> CBOR.Decoder s (SomeMessage st) 43 | decodeMsg stok = do 44 | _ <- CBOR.decodeListLen 45 | key <- CBOR.decodeWord 46 | case (stok, key) of 47 | (SingIdle, 0) -> SomeMessage . MsgReq <$> CBOR.decode 48 | (SingBusy, 1) -> SomeMessage . MsgResp <$> CBOR.decode 49 | (SingIdle, 2) -> return $ SomeMessage MsgDone 50 | 51 | -- TODO proper exceptions 52 | (SingIdle, _) -> fail "codecReqResp.StIdle: unexpected key" 53 | (SingBusy, _) -> fail "codecReqResp.StBusy: unexpected key" 54 | (a@SingDone, _) -> notActiveState a 55 | 56 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/ReqResp/Examples.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.ReqResp.Examples where 2 | 3 | import Network.TypedProtocol.ReqResp.Client 4 | import Network.TypedProtocol.ReqResp.Server 5 | 6 | import Network.TypedProtocol.Peer.Client 7 | 8 | -- | An example request\/response client which ignores received responses. 9 | -- 10 | reqRespClient :: Monad m 11 | => [req] 12 | -> ReqRespClient req resp m () 13 | reqRespClient = go 14 | where 15 | go [] = SendMsgDone (pure ()) 16 | go (req:reqs) = SendMsgReq req (\_resp -> return (go reqs)) 17 | 18 | 19 | -- | A request\/response server instance that computes a 'Data.List.mapAccumL' 20 | -- over the stream of requests. 21 | -- 22 | reqRespServerMapAccumL :: Monad m 23 | => (acc -> req -> m (acc, resp)) 24 | -> acc 25 | -> ReqRespServer req resp m acc 26 | reqRespServerMapAccumL f !acc = 27 | ReqRespServer { 28 | recvMsgReq = \req -> do (acc', resp) <- f acc req 29 | return (resp, reqRespServerMapAccumL f acc'), 30 | recvMsgDone = pure acc 31 | } 32 | 33 | 34 | -- | An example request\/response client that sends the given list of requests 35 | -- and collects the list of responses. 36 | -- 37 | reqRespClientMap :: Monad m 38 | => [req] 39 | -> ReqRespClient req resp m [resp] 40 | reqRespClientMap = go [] 41 | where 42 | go resps [] = SendMsgDone (pure $ reverse resps) 43 | go resps (req:reqs) = 44 | SendMsgReq req $ \resp -> 45 | return (go (resp:resps) reqs) 46 | 47 | -- 48 | -- Pipelined example 49 | -- 50 | 51 | -- | An example request\/response client that sends the given list of requests 52 | -- and collects the list of responses. 53 | -- 54 | -- It is pipelined and tries to collect any replies if they are available. 55 | -- This allows pipelining but keeps it to a minimum, and correspondingly it 56 | -- gives maximum choice to the environment (drivers). 57 | -- 58 | -- In theory, with enough and large enough requests and responses, this should 59 | -- be able to saturate any channel of any bandwidth and latency, because it 60 | -- should be able to have both peers send essentially continuously. 61 | -- 62 | reqRespClientMapPipelined :: forall req resp m. 63 | Monad m 64 | => [req] 65 | -> ReqRespClientPipelined req resp m [resp] 66 | reqRespClientMapPipelined reqs0 = 67 | ReqRespClientPipelined (go [] Zero reqs0) 68 | where 69 | go :: [resp] -> Nat o -> [req] -> ReqRespIdle req resp o resp m [resp] 70 | go resps Zero reqs = 71 | case reqs of 72 | [] -> SendMsgDonePipelined (reverse resps) 73 | req:reqs' -> sendReq resps Zero req reqs' 74 | 75 | go resps (Succ o) reqs = 76 | CollectPipelined 77 | (case reqs of 78 | [] -> Nothing 79 | req:reqs' -> Just (sendReq resps (Succ o) req reqs')) 80 | (\resp -> return $ go (resp:resps) o reqs) 81 | 82 | sendReq :: [resp] -> Nat o -> req -> [req] 83 | -> ReqRespIdle req resp o resp m [resp] 84 | sendReq resps o req reqs' = 85 | SendMsgReqPipelined req 86 | (\resp -> return resp) 87 | (go resps (Succ o) reqs') 88 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/ReqResp/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Network.TypedProtocol.ReqResp.Server where 6 | 7 | import Network.TypedProtocol.Core 8 | import Network.TypedProtocol.Peer.Server 9 | import Network.TypedProtocol.ReqResp.Type 10 | 11 | 12 | data ReqRespServer req resp m a = ReqRespServer { 13 | -- | The client sent us a ping message. We have no choices here, and 14 | -- the response is nullary, all we have are local effects. 15 | recvMsgReq :: req -> m (resp, ReqRespServer req resp m a) 16 | 17 | -- | The client terminated. Here we have a pure return value, but we 18 | -- could have done another action in 'm' if we wanted to. 19 | , recvMsgDone :: m a 20 | } 21 | 22 | 23 | -- | Interpret a particular server action sequence into the server side of the 24 | -- 'ReqResp' protocol. 25 | -- 26 | reqRespServerPeer 27 | :: Monad m 28 | => ReqRespServer req resp m a 29 | -> Server (ReqResp req resp) NonPipelined StIdle m a 30 | reqRespServerPeer ReqRespServer{..} = 31 | 32 | -- In the 'StIdle' the server is awaiting a request message 33 | Await $ \msg -> 34 | 35 | -- The client got to choose between two messages and we have to handle 36 | -- either of them 37 | case msg of 38 | 39 | -- The client sent the done transition, so we're in the 'StDone' state 40 | -- so all we can do is stop using 'done', with a return value. 41 | MsgDone -> Effect $ Done <$> recvMsgDone 42 | 43 | -- The client sent us a ping request, so now we're in the 'StBusy' state 44 | -- which means it's the server's turn to send. 45 | MsgReq req -> Effect $ do 46 | (resp, next) <- recvMsgReq req 47 | pure $ Yield (MsgResp resp) (reqRespServerPeer next) 48 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/ReqResp/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Network.TypedProtocol.ReqResp.Type where 4 | 5 | import Network.TypedProtocol.Core 6 | 7 | 8 | data ReqResp req resp where 9 | StIdle :: ReqResp req resp 10 | StBusy :: ReqResp req resp 11 | StDone :: ReqResp req resp 12 | 13 | data SReqResp (st :: ReqResp req resp) where 14 | SingIdle :: SReqResp StIdle 15 | SingBusy :: SReqResp StBusy 16 | SingDone :: SReqResp StDone 17 | 18 | deriving instance Show (SReqResp st) 19 | 20 | instance StateTokenI StIdle where 21 | stateToken = SingIdle 22 | instance StateTokenI StBusy where 23 | stateToken = SingBusy 24 | instance StateTokenI StDone where 25 | stateToken = SingDone 26 | 27 | 28 | instance Protocol (ReqResp req resp) where 29 | 30 | data Message (ReqResp req resp) from to where 31 | MsgReq :: req -> Message (ReqResp req resp) StIdle StBusy 32 | MsgResp :: resp -> Message (ReqResp req resp) StBusy StIdle 33 | MsgDone :: Message (ReqResp req resp) StIdle StDone 34 | 35 | type StateAgency StIdle = ClientAgency 36 | type StateAgency StBusy = ServerAgency 37 | type StateAgency StDone = NobodyAgency 38 | 39 | type StateToken = SReqResp 40 | 41 | 42 | deriving instance (Show req, Show resp) 43 | => Show (Message (ReqResp req resp) from to) 44 | 45 | deriving instance (Eq req, Eq resp) 46 | => Eq (Message (ReqResp req resp) from to) 47 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/ReqResp2/Client.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.ReqResp2.Client where 2 | 3 | import Network.TypedProtocol.ReqResp2.Type 4 | 5 | import Network.TypedProtocol.Core 6 | import Network.TypedProtocol.Peer.Client 7 | 8 | 9 | reqResp2Client :: forall req resp m. 10 | () 11 | => [Either req req] 12 | -> Client (ReqResp2 req resp) (Pipelined Z (Either resp resp)) StIdle m [Either resp resp] 13 | reqResp2Client = send Zero 14 | where 15 | -- pipeline all the requests, either through `MsgReq` or `MsgReq'`. 16 | send :: forall (n :: N). 17 | Nat n 18 | -> [Either req req] -- requests to send 19 | -> Client (ReqResp2 req resp) (Pipelined n (Either resp resp)) StIdle m [Either resp resp] 20 | 21 | send !n (Left req : reqs) = 22 | YieldPipelined (MsgReq req) receiver (send (Succ n) reqs) 23 | 24 | send !n (Right req : reqs) = 25 | YieldPipelined (MsgReq' req) receiver' (send (Succ n) reqs) 26 | 27 | send !n [] = collect n [] 28 | 29 | 30 | receiver :: Receiver (ReqResp2 req resp) StBusy StIdle m (Either resp resp) 31 | receiver = ReceiverAwait (\(MsgResp resp) -> ReceiverDone (Left resp)) 32 | 33 | 34 | receiver' :: Receiver (ReqResp2 req resp) StBusy' StIdle m (Either resp resp) 35 | receiver' = ReceiverAwait (\(MsgResp' resp) -> ReceiverDone (Right resp)) 36 | 37 | 38 | -- collect all the responses 39 | collect :: Nat n 40 | -> [Either resp resp] -- all the responses received so far 41 | -> Client (ReqResp2 req resp) (Pipelined n (Either resp resp)) StIdle m [Either resp resp] 42 | 43 | collect Zero !resps = Yield MsgDone (Done (reverse resps)) 44 | 45 | collect (Succ n) !resps = 46 | Collect Nothing $ \c -> collect n (c : resps) 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/ReqResp2/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Network.TypedProtocol.ReqResp2.Type where 4 | 5 | import Network.TypedProtocol.Core 6 | 7 | 8 | data ReqResp2 req resp where 9 | StIdle :: ReqResp2 req resp 10 | StBusy :: ReqResp2 req resp 11 | StBusy' :: ReqResp2 req resp 12 | StDone :: ReqResp2 req resp 13 | 14 | data SReqResp2 (st :: ReqResp2 req resp) where 15 | SingIdle :: SReqResp2 StIdle 16 | SingBusy :: SReqResp2 StBusy 17 | SingBusy' :: SReqResp2 StBusy' 18 | SingDone :: SReqResp2 StDone 19 | 20 | deriving instance Show (SReqResp2 st) 21 | 22 | instance StateTokenI StIdle where 23 | stateToken = SingIdle 24 | instance StateTokenI StBusy where 25 | stateToken = SingBusy 26 | instance StateTokenI StBusy' where 27 | stateToken = SingBusy' 28 | instance StateTokenI StDone where 29 | stateToken = SingDone 30 | 31 | 32 | instance Protocol (ReqResp2 req resp) where 33 | 34 | data Message (ReqResp2 req resp) from to where 35 | MsgReq :: req -> Message (ReqResp2 req resp) StIdle StBusy 36 | MsgResp :: resp -> Message (ReqResp2 req resp) StBusy StIdle 37 | 38 | MsgReq' :: req -> Message (ReqResp2 req resp) StIdle StBusy' 39 | MsgResp' :: resp -> Message (ReqResp2 req resp) StBusy' StIdle 40 | 41 | MsgDone :: Message (ReqResp2 req resp) StIdle StDone 42 | 43 | type StateAgency StIdle = ClientAgency 44 | type StateAgency StBusy = ServerAgency 45 | type StateAgency StBusy' = ServerAgency 46 | type StateAgency StDone = NobodyAgency 47 | 48 | type StateToken = SReqResp2 49 | 50 | 51 | deriving instance (Show req, Show resp) 52 | => Show (Message (ReqResp2 req resp) from to) 53 | 54 | deriving instance (Eq req, Eq resp) 55 | => Eq (Message (ReqResp2 req resp) from to) 56 | 57 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/Stateful/ReqResp/Client.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.Stateful.ReqResp.Client 2 | ( ReqRespClient (..) 3 | , reqRespClientPeer 4 | ) where 5 | 6 | import Data.Typeable 7 | import Network.TypedProtocol.Stateful.Peer.Client 8 | import Network.TypedProtocol.Stateful.ReqResp.Type 9 | 10 | data ReqRespClient req m a where 11 | SendMsgReq :: Typeable resp 12 | => req resp 13 | -> (resp -> m (ReqRespClient req m a)) 14 | -> ReqRespClient req m a 15 | 16 | SendMsgDone :: a 17 | -> ReqRespClient req m a 18 | 19 | 20 | reqRespClientPeer 21 | :: Monad m 22 | => ReqRespClient req m a 23 | -> Client (ReqResp req) StIdle State m a 24 | 25 | reqRespClientPeer (SendMsgDone a) = 26 | Yield StateIdle StateDone MsgDone (Done a) 27 | 28 | reqRespClientPeer (SendMsgReq req next) = 29 | Yield StateIdle (StateBusy req) 30 | (MsgReq req) $ 31 | Await $ \_ (MsgResp resp) -> 32 | let client = next resp 33 | in ( Effect $ reqRespClientPeer <$> client 34 | , StateIdle 35 | ) 36 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/Stateful/ReqResp/Codec.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.Stateful.ReqResp.Codec where 2 | 3 | import Data.Kind (Type) 4 | import Data.Singletons.Decide 5 | import Data.Typeable 6 | import Network.TypedProtocol.Core 7 | import Network.TypedProtocol.PingPong.Codec (decodeTerminatedFrame) 8 | import Network.TypedProtocol.Stateful.Codec 9 | import Network.TypedProtocol.Stateful.ReqResp.Type 10 | 11 | data Some (f :: k -> Type) where 12 | Some :: Typeable a => f a -> Some f 13 | 14 | 15 | -- | Codec polymorphic in the RPC (e.g. `req` type) 16 | -- 17 | codecReqResp 18 | :: forall req m. Monad m 19 | => (forall resp. req resp -> String) 20 | -- ^ encode `req resp` 21 | -> (String -> Maybe (Some req)) 22 | -- ^ decode `req resp` 23 | -> (forall resp. req resp -> resp -> String) 24 | -- ^ encode resp 25 | -> (forall resp. req resp -> String -> Maybe resp) 26 | -- ^ decode resp 27 | -> Codec (ReqResp req) CodecFailure State m String 28 | codecReqResp encodeReq decodeReq encodeResp decodeResp = 29 | Codec { encode, decode } 30 | where 31 | encode :: State st 32 | -> Message (ReqResp req) st st' 33 | -> String 34 | encode _ (MsgReq req) = "MsgReq " ++ encodeReq req ++ "\n" 35 | encode _ MsgDone = "MsgDone\n" 36 | encode (StateBusy req) (MsgResp resp) = "MsgResp " ++ encodeResp req resp ++ "\n" 37 | 38 | decode :: forall (st :: ReqResp req). 39 | ActiveState st 40 | => StateToken st 41 | -> State st 42 | -> m (DecodeStep String CodecFailure m (SomeMessage st)) 43 | decode stok state = 44 | decodeTerminatedFrame '\n' $ \str trailing -> 45 | case (stok, state, break (==' ') str) of 46 | (SingIdle, StateIdle, ("MsgReq", str')) 47 | | Just (Some req) <- decodeReq str' 48 | -> DecodeDone (SomeMessage (MsgReq req)) trailing 49 | (SingIdle, StateIdle, ("MsgDone", "")) 50 | -> DecodeDone (SomeMessage MsgDone) trailing 51 | (SingBusy, StateBusy req, ("MsgResp", str')) 52 | -- note that we need `req` to decode response of the given type 53 | | Just resp <- decodeResp req str' 54 | -> DecodeDone (SomeMessage (MsgResp resp)) trailing 55 | (_, _, _) -> DecodeFail failure 56 | where failure = CodecFailure ("unexpected server message: " ++ str) 57 | 58 | 59 | data Bytes where 60 | Bytes :: Message (ReqResp FileAPI) st st' -> Bytes 61 | 62 | -- | An identity codec which wraps messages into `AnyMessage`. 63 | -- 64 | codecReqRespId 65 | :: forall m. 66 | Applicative m 67 | => (forall (res1 :: Type) (res2 :: Type). 68 | (Typeable res1, Typeable res2) 69 | => Proxy res1 70 | -> Proxy res2 71 | -> Maybe (res1 :~: res2) 72 | ) 73 | -> Codec FileRPC String State m Bytes 74 | codecReqRespId eqRespTypes = Codec { encode, decode } 75 | where 76 | encode _ = Bytes 77 | 78 | decode :: forall (st :: ReqResp FileAPI). 79 | ActiveState st 80 | => StateToken st 81 | -> State st 82 | -> m (DecodeStep Bytes String m (SomeMessage st)) 83 | decode stok state = pure $ DecodePartial $ \bytes -> pure $ 84 | case (stok, state, bytes) of 85 | (SingIdle, StateIdle, Just (Bytes msg@MsgDone)) 86 | -> DecodeDone (SomeMessage msg) Nothing 87 | (SingIdle, StateIdle, Just (Bytes msg@MsgReq{})) 88 | -> DecodeDone (SomeMessage msg) Nothing 89 | (SingBusy, StateBusy req, Just (Bytes msg@MsgResp{})) 90 | -- the codec needs to verify that response type of `req` and `msg` agrees 91 | | Just Refl <- eqRespTypes (reqRespType req) (msgRespType msg) 92 | -> DecodeDone (SomeMessage msg) Nothing 93 | 94 | (SingDone, _, _) -> notActiveState stok 95 | (_, _, Nothing) -> DecodeFail "no bytes" 96 | (_, _, _) -> DecodeFail "no matching message" 97 | 98 | msgRespType :: forall resp. Message (ReqResp FileAPI) (StBusy resp) StIdle 99 | -> Proxy resp 100 | msgRespType (MsgResp _) = Proxy 101 | 102 | reqRespType :: forall resp. FileAPI resp -> Proxy resp 103 | reqRespType _ = Proxy 104 | 105 | 106 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/Stateful/ReqResp/Examples.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.Stateful.ReqResp.Examples where 2 | 3 | import Network.TypedProtocol.Stateful.ReqResp.Server 4 | import Network.TypedProtocol.Stateful.ReqResp.Type 5 | 6 | 7 | fileRPCServer :: Monad m 8 | => (forall resp. FileAPI resp -> m resp) 9 | -- ^ execute `FileAPI` locally 10 | -> ReqRespServer FileAPI m () 11 | fileRPCServer run = ReqRespServer { 12 | reqRespServerDone = (), 13 | reqRespHandleReq = \req -> do 14 | resp <- run req 15 | return (resp, fileRPCServer run) 16 | } 17 | 18 | -- | Example of a file API 19 | -- 20 | simpleFileAPI :: Monad m => FileAPI resp -> m resp 21 | simpleFileAPI (ReadFile filepath) = return filepath 22 | simpleFileAPI (WriteFile _ _) = return () 23 | 24 | simpleFileRPCServer :: Monad m => ReqRespServer FileAPI m () 25 | simpleFileRPCServer = fileRPCServer simpleFileAPI 26 | 27 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/Stateful/ReqResp/Server.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.Stateful.ReqResp.Server 2 | ( ReqRespServer (..) 3 | , reqRespServerPeer 4 | ) where 5 | 6 | import Data.Typeable 7 | import Network.TypedProtocol.Stateful.Peer.Server 8 | import Network.TypedProtocol.Stateful.ReqResp.Type 9 | 10 | 11 | data ReqRespServer req m a = ReqRespServer { 12 | reqRespServerDone :: a, 13 | reqRespHandleReq :: forall resp. Typeable resp => req resp -> m (resp, ReqRespServer req m a) 14 | } 15 | 16 | reqRespServerPeer :: Functor m 17 | => ReqRespServer req m a 18 | -> Server (ReqResp req) StIdle State m a 19 | reqRespServerPeer ReqRespServer { reqRespServerDone = a, 20 | reqRespHandleReq = k } = 21 | Await $ \_ -> \case 22 | MsgDone -> (Done a, StateDone) 23 | MsgReq req -> 24 | ( Effect $ 25 | (\(resp, k') -> Yield (StateBusy req) StateIdle (MsgResp resp) (reqRespServerPeer k')) 26 | <$> k req 27 | , StateBusy req 28 | ) 29 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/Stateful/ReqResp/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | -- | An RPC protocol which in which request type determines respond time. 4 | -- Unlike in the `Network.TypedProtocol.ReqResp.Type` where `req` and `resp` 5 | -- types where statically defined, here the respond type is dynamically 6 | -- determined by the type of request. 7 | -- 8 | module Network.TypedProtocol.Stateful.ReqResp.Type where 9 | 10 | import Data.Kind (Type) 11 | import Data.Typeable 12 | import Network.TypedProtocol.Core 13 | 14 | 15 | type ReqResp :: (Type -> Type) -> Type 16 | data ReqResp req where 17 | StIdle :: ReqResp req 18 | StBusy :: res 19 | -> ReqResp req 20 | StDone :: ReqResp req 21 | 22 | type SReqResp :: ReqResp req -> Type 23 | data SReqResp st where 24 | SingIdle :: SReqResp StIdle 25 | SingBusy :: SReqResp (StBusy res :: ReqResp req) 26 | SingDone :: SReqResp StDone 27 | 28 | deriving instance Show (SReqResp st) 29 | 30 | instance StateTokenI StIdle where stateToken = SingIdle 31 | instance StateTokenI (StBusy res) where stateToken = SingBusy 32 | instance StateTokenI StDone where stateToken = SingDone 33 | 34 | 35 | instance Protocol (ReqResp req) where 36 | 37 | -- Messages for the `ReqResp` protocol. 38 | -- 39 | -- Typeable constraint is used to support 40 | -- `Network.TypeProtocol.Stateful.ReqResp.Codec.codecReqRespId' - an 41 | -- efficient encoder / decoder useful for testing purposes. 42 | -- 43 | data Message (ReqResp req) from to where 44 | MsgReq :: Typeable resp 45 | => req resp -- ^ request which expects `resp` as a result, `resp` is 46 | -- promoted to the state `StBusy` state. 47 | -> Message (ReqResp req) StIdle (StBusy resp) 48 | MsgResp :: Typeable resp 49 | => resp -- ^ respond 50 | -> Message (ReqResp req) (StBusy resp) StIdle 51 | MsgDone :: Message (ReqResp req) StIdle StDone 52 | 53 | type StateAgency StIdle = ClientAgency 54 | type StateAgency (StBusy _) = ServerAgency 55 | type StateAgency StDone = NobodyAgency 56 | 57 | type StateToken = SReqResp 58 | 59 | 60 | -- deriving instance Show req 61 | -- => Show (Message (ReqResp req) from to) 62 | -- 63 | -- deriving instance Eq req 64 | -- => Eq (Message (ReqResp req) from to) 65 | 66 | type State :: ReqResp req -> Type 67 | data State st where 68 | StateIdle :: State StIdle 69 | -- fancy type signature is needed to help GHC infer that when pattern 70 | -- matching on `StateBusy resp` then `resp :: Type` 71 | StateBusy :: forall (req :: Type -> Type) 72 | (result :: Type). 73 | Typeable result 74 | => req result 75 | -> State (StBusy result :: ReqResp req) 76 | StateDone :: State StDone 77 | 78 | -- 79 | -- A simple example RPC 80 | -- 81 | 82 | -- | An example RPC, e.g. the `req` type. 83 | -- 84 | type FileAPI :: Type -> Type 85 | data FileAPI result where 86 | ReadFile :: FilePath -> FileAPI String 87 | -- read a file 88 | 89 | WriteFile :: FilePath -> String -> FileAPI () 90 | -- write to a file 91 | -- TODO: input-output-hk/typed-protocols#57 92 | 93 | type FileRPC = ReqResp FileAPI 94 | -------------------------------------------------------------------------------- /typed-protocols/examples/Network/TypedProtocol/Trans/Wedge.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Network.TypedProtocol.Trans.Wedge where 5 | 6 | import Network.TypedProtocol.Core 7 | 8 | import Network.TypedProtocol.Peer.Client qualified as Client 9 | import Network.TypedProtocol.PingPong.Type qualified as PingPong 10 | 11 | 12 | -- | A [wedge](https://hackage.haskell.org/package/smash-0.1.2/docs/Data-Wedge.html) 13 | -- sum of two protocols. 14 | -- 15 | -- One can interleave both protocols using protocol pipelining. Termination 16 | -- must be done by terminating one of the protocols. 17 | -- 18 | data Wedge ps (stIdle :: ps) ps' (stIdle' :: ps') where 19 | StIdle :: Wedge ps stIdle ps' stIdle' 20 | StFst :: ps -> Wedge ps stIdle ps' stIdle' 21 | StSnd :: ps' -> Wedge ps stIdle ps' stIdle' 22 | 23 | 24 | data SingWedge (st :: Wedge ps (stIdle :: ps) ps' (stIdle' :: ps')) where 25 | SingStIdle :: SingWedge StIdle 26 | SingStFst :: StateToken st 27 | -> SingWedge (StFst st) 28 | SingStSnd :: StateToken st' 29 | -> SingWedge (StSnd st') 30 | 31 | instance Show (SingWedge StIdle) where 32 | show SingStIdle = "SingStIdle" 33 | instance Show (StateToken st) => Show (SingWedge (StFst st)) where 34 | show (SingStFst s) = "SingStFst " ++ show s 35 | instance Show (StateToken st) => Show (SingWedge (StSnd st)) where 36 | show (SingStSnd s) = "SingStSnd " ++ show s 37 | 38 | instance StateTokenI StIdle where 39 | stateToken = SingStIdle 40 | instance StateTokenI st => StateTokenI (StFst st) where 41 | stateToken = SingStFst (stateToken @st) 42 | instance StateTokenI st => StateTokenI (StSnd st) where 43 | stateToken = SingStSnd (stateToken @st) 44 | 45 | 46 | -- | A Singleton type which allows to pick the starting protocol state. 47 | -- 48 | data SingStart (st :: Wedge ps stIdle ps' stIdle') where 49 | AtFst :: SingStart (StFst stIdle) 50 | AtSnd :: SingStart (StSnd stIdle) 51 | 52 | 53 | -- Note: This does not require @(Protocol ps, Protocol ps')@, ghc is not 54 | -- requiring class constraints for associated type families / data types the 55 | -- same way as for terms. 56 | -- 57 | instance Protocol (Wedge ps (stIdle :: ps) ps' (stIdle' :: ps')) where 58 | 59 | data Message (Wedge ps (stIdle :: ps) ps' (stIdle' :: ps')) from to where 60 | -- | Signal that starts one of the protocols. 61 | -- 62 | MsgStart :: SingStart st 63 | -> Message (Wedge ps stIdle ps' stIdle') 64 | StIdle st 65 | 66 | -- | Embed any @ps@ message. 67 | -- 68 | MsgFst :: Message ps st st' 69 | -> Message (Wedge ps stIdle ps' stIdle') 70 | (StFst st) (StFst st') 71 | 72 | 73 | -- | Embed any @ps'@ message. 74 | MsgSnd :: Message ps' st st' 75 | -> Message (Wedge ps stIdle ps' stIdle') 76 | (StSnd st) (StSnd st') 77 | 78 | -- | Switch from @ps@ to @ps'@. 79 | -- 80 | MsgFstToSnd :: Message (Wedge ps stIdle ps' stIdle') 81 | (StFst stIdle) (StSnd stIdle') 82 | 83 | -- | Switch from @ps'@ to @ps@. 84 | -- 85 | MsgSndToFst :: Message (Wedge ps stIdle ps' stIdle') 86 | (StSnd stIdle') (StFst stIdle) 87 | 88 | 89 | type StateAgency StIdle = ClientAgency 90 | type StateAgency (StFst st) = StateAgency st 91 | type StateAgency (StSnd st) = StateAgency st 92 | 93 | type StateToken = SingWedge 94 | 95 | 96 | type PingPong2 = Wedge PingPong.PingPong PingPong.StIdle 97 | PingPong.PingPong PingPong.StIdle 98 | 99 | 100 | pingPong2Client :: Client.Client PingPong2 NonPipelined StIdle m () 101 | pingPong2Client = 102 | Client.Yield (MsgStart AtFst) 103 | $ Client.Yield (MsgFst PingPong.MsgPing) 104 | $ Client.Await $ \(MsgFst PingPong.MsgPong) -> 105 | Client.Yield MsgFstToSnd 106 | $ Client.Yield (MsgSnd PingPong.MsgPing) 107 | $ Client.Await $ \(MsgSnd PingPong.MsgPong) -> 108 | -- terminate, through the second protocol 109 | Client.Yield (MsgSnd PingPong.MsgDone) 110 | $ Client.Done () 111 | 112 | 113 | pingPong2Client' :: forall m. Client.Client PingPong2 (Pipelined Client.Z ()) StIdle m () 114 | pingPong2Client' = 115 | -- 116 | -- Pipeline first protocol 117 | -- 118 | 119 | Client.YieldPipelined (MsgStart AtFst) 120 | (Client.ReceiverDone ()) 121 | $ Client.YieldPipelined (MsgFst PingPong.MsgPing) 122 | (Client.ReceiverAwait (\(MsgFst PingPong.MsgPong) -> Client.ReceiverDone ())) 123 | 124 | -- 125 | -- Pipeline second protocol 126 | -- 127 | 128 | $ Client.YieldPipelined MsgFstToSnd 129 | (Client.ReceiverDone ()) 130 | $ Client.YieldPipelined (MsgSnd PingPong.MsgPing) 131 | (Client.ReceiverAwait (\(MsgSnd PingPong.MsgPong) -> Client.ReceiverDone ())) 132 | 133 | -- 134 | -- Collect responses from the first protocol 135 | -- 136 | 137 | $ Client.Collect Nothing $ \() -> -- collect transition pushed by `MsgStartFst` 138 | Client.Collect Nothing $ \() -> -- collect reply received with `MsgFst MsgPong` 139 | 140 | -- 141 | -- Collect responses from the second protocol 142 | -- 143 | 144 | Client.Collect Nothing $ \() -> -- collect transition pushed by MsgFstToSnd 145 | Client.Collect Nothing $ \() -> -- collect reply received with `MsgSnd MsgPong` 146 | 147 | -- 148 | -- Terminate the protocol 149 | -- 150 | 151 | Client.Yield (MsgSnd PingPong.MsgDone) 152 | $ Client.Done () 153 | -------------------------------------------------------------------------------- /typed-protocols/src/Network/TypedProtocol.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | This package defines the typed protocol framework. This module re-exports 3 | -- the public API. 4 | -- 5 | module Network.TypedProtocol 6 | ( -- * Introduction 7 | -- $intro 8 | -- * Defining and implementing protocols 9 | -- $defining 10 | module Network.TypedProtocol.Core 11 | -- ** Protocol proofs and tests 12 | -- $tests 13 | , module Network.TypedProtocol.Proofs 14 | -- * Running protocols 15 | -- $running 16 | , module Network.TypedProtocol.Driver 17 | ) where 18 | 19 | import Network.TypedProtocol.Core 20 | import Network.TypedProtocol.Driver 21 | import Network.TypedProtocol.Proofs 22 | 23 | 24 | -- $intro 25 | -- 26 | -- The typed protocol framework is used to define, test and execute protocols. 27 | -- 28 | -- It guarantees: 29 | -- 30 | -- * agreement on which messages can be sent and received; 31 | -- * the absence of race conditions; and 32 | -- * the absence of deadlock. 33 | -- 34 | -- The trade-off to achieve these guarantees is that it places constraints on 35 | -- the kinds of protocol that can be expressed. In particular it requires that 36 | -- protocols be defined as a state transition system. It requires for each 37 | -- protocol state that exactly one of the two peers be able to send and the 38 | -- other must be ready to receive. 39 | -- 40 | -- This means it is not possible to express protocols such as TCP where there 41 | -- are protocol states where a single peer can both send and receive, however 42 | -- it is suitable for most application-level protocols. In particular many 43 | -- application-level protocols are completely in-order and synchronous. That 44 | -- said, in many (but not all) cases it is possible to pipeline these protocols 45 | -- so that network latency can be hidden and full use made of the available 46 | -- bandwidth. Special support is provided to run protocols in a pipelined way, 47 | -- without having to change the protocol definition. 48 | -- 49 | -- The protocols in this framework assume an underlying \"reliable ordered\" 50 | -- connection. A \"reliable ordered\" connection is a term of art meaning one 51 | -- where the receiving end receives any prefix of the messages sent by the 52 | -- sending end. It is not reliable in the colloquial sense as it does not 53 | -- ensure that anything actually arrives, only that /if/ any message arrives, 54 | -- all the previous messages did too, and that they arrive in the order in 55 | -- which they were sent. 56 | -- 57 | -- The framework also provides: 58 | -- 59 | -- * an abstraction for untyped channels; 60 | -- * a codec abstraction for encoding and decoding protocol messages; and 61 | -- * drivers for running protocol peers with a channel and a codec. 62 | 63 | 64 | -- $defining 65 | -- 66 | -- The "Network.TypedProtocol.Core" module defines the core of the system. 67 | -- 68 | -- Start reading here to understand: 69 | -- 70 | -- * how to define new protocols; or 71 | -- * to write peers that engage in a protocol. 72 | -- 73 | -- Typed protocol messages need to be converted to and from untyped 74 | -- serialised forms to send over a transport channel. So part of defining a new 75 | -- protocol is to define the message encoding and the codec for doing the 76 | -- encoding and decoding. This is somewhat (but not significantly) more complex 77 | -- than defining normal data type serialisation because of the need to decode 78 | -- typed protocol messages. The "Network.TypedProtocol.Codec" module provides 79 | -- the codec abstraction to capture this. 80 | 81 | 82 | -- $tests 83 | -- 84 | -- There are a few proofs about the framework that we can state and implement 85 | -- as Haskell functions (using GADTs and evaluation). A couple of these proofs 86 | -- rely on a few lemmas that should be proved for each protocol. The 87 | -- "Network.TypedProtocol.Proofs" module describes these proof and provides 88 | -- the infrastructure for the simple lemmas that need to be implemented for 89 | -- each protocol. 90 | -- 91 | -- This module also provides utilities helpful for testing protocols. 92 | 93 | 94 | -- $running 95 | -- 96 | -- Typed protocols need to be able to send messages over untyped transport 97 | -- channels. The "Network.TypedProtocol.Channel" module provides such an 98 | -- abstraction. You can use existing example implementations of this interface 99 | -- or define your own to run over other transports. 100 | -- 101 | -- Given a protocol peer, and a channel and a codec we can run the protocol 102 | -- peer so that it engages in the protocol sending and receiving messages 103 | -- over the channel. The "Network.TypedProtocol.Driver" module provides drivers 104 | -- for normal and pipelined peers. 105 | 106 | 107 | -- $pipelining 108 | -- Protocol pipelining is a technique to make effective use of network 109 | -- resources. 110 | -- 111 | -- <> 112 | -- 113 | -- As in the above diagram, instead of sending a request and waiting for the 114 | -- response before sending the next request, pipelining involves sending all 115 | -- three requests back-to-back and waiting for the three replies. The server 116 | -- still simply processes the requests in order and the replies come back in 117 | -- the same order as the requests were made. 118 | -- 119 | -- Not only does this save network latency, one round trip versus three in 120 | -- the diagram above, but it also makes effective use of the bandwidth by 121 | -- sending requests and replies back-to-back. 122 | -- 123 | -- In the example in the diagram it stops after three requests, but such a 124 | -- pattern can go on indefinately with messages going in both directions, 125 | -- which can saturate the available bandwidth. 126 | -- 127 | -- For many (but not all) protocols that can be defined in the @typed-protocol@ 128 | -- framework it is possible to take the protocol, without changing the 129 | -- protocol's state machine, and to engage in the protocol in a pipelined way. 130 | -- Only the pipelined client has to be written specially. The server side can 131 | -- be used unaltered and can be used with either pipelined or non-pipelined 132 | -- clients. 133 | 134 | 135 | -------------------------------------------------------------------------------- /typed-protocols/src/Network/TypedProtocol/Lemmas.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 4 | {-# HLINT ignore "Use camelCase" #-} 5 | 6 | -- | The module contains exclusion lemmas which are proven using ad absurdum: 7 | -- 8 | -- * it's impossible for both client and server have agency 9 | -- * it's impossible for either side to be in a terminal state (no agency) and 10 | -- the other side have agency 11 | -- 12 | module Network.TypedProtocol.Lemmas where 13 | 14 | import Data.Kind (Type) 15 | import Network.TypedProtocol.Core 16 | 17 | 18 | -- $about 19 | -- 20 | -- Typed languages such as Haskell can embed proofs. In total languages this 21 | -- is straightforward: a value inhabiting a type is a proof of the property 22 | -- corresponding to the type. 23 | -- 24 | -- In languages like Haskell that have ⊥ as a value of every type, things 25 | -- are slightly more complicated. We have to demonstrate that the value that 26 | -- inhabits the type of interest is not ⊥ which we can do by evaluation. 27 | -- 28 | -- This idea crops up frequently in advanced type level programming in Haskell. 29 | -- For example @Refl@ proofs that two types are equal have to have a runtime 30 | -- representation that is evaluated to demonstrate it is not ⊥ before it 31 | -- can be relied upon. 32 | -- 33 | -- The proofs here are about the nature of typed protocols in this framework. 34 | -- The 'connect' and 'connectPipelined' proofs rely on a few internal lemmas. 35 | 36 | -- | An evidence that both relative agencies are equal to 'NobodyHasAgency'. 37 | -- 38 | type ReflNobodyHasAgency :: RelativeAgency -> RelativeAgency -> Type 39 | data ReflNobodyHasAgency ra ra' where 40 | ReflNobodyHasAgency :: ReflNobodyHasAgency 41 | NobodyHasAgency 42 | NobodyHasAgency 43 | 44 | 45 | -- | A proof that if both @Relative pr a@ and @Relative (FlipAgency pr) a@ are 46 | -- equal then nobody has agency. In particular this lemma excludes the 47 | -- possibility that client and server has agency at the same state. 48 | -- 49 | exclusionLemma_ClientAndServerHaveAgency 50 | :: forall (pr :: PeerRole) (a :: Agency) 51 | (ra :: RelativeAgency). 52 | SingPeerRole pr 53 | -> ReflRelativeAgency a ra (Relative pr a) 54 | -- ^ evidence that `ra` is equal to `Relative pr a`, e.g. that client has 55 | -- agency 56 | -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) 57 | -- ^ evidence that `ra` is equal to `Relative (FlipAgency pr) a`, e.g. that 58 | -- the server has agency 59 | -> ReflNobodyHasAgency (Relative pr a) 60 | (Relative (FlipAgency pr) a) 61 | -- ^ derived evidence that nobody has agency in that case 62 | exclusionLemma_ClientAndServerHaveAgency 63 | SingAsClient ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency 64 | exclusionLemma_ClientAndServerHaveAgency 65 | SingAsServer ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency 66 | 67 | exclusionLemma_ClientAndServerHaveAgency 68 | SingAsClient ReflClientAgency x = case x of {} 69 | exclusionLemma_ClientAndServerHaveAgency 70 | SingAsServer ReflClientAgency x = case x of {} 71 | exclusionLemma_ClientAndServerHaveAgency 72 | SingAsClient ReflServerAgency x = case x of {} 73 | exclusionLemma_ClientAndServerHaveAgency 74 | SingAsServer ReflServerAgency x = case x of {} 75 | 76 | 77 | -- | A proof that if one side has terminated, then the other side terminated as 78 | -- well. 79 | -- 80 | terminationLemma_1 81 | :: SingPeerRole pr 82 | -> ReflRelativeAgency a ra (Relative pr a) 83 | -> ReflRelativeAgency a NobodyHasAgency (Relative (FlipAgency pr) a) 84 | -> ReflNobodyHasAgency (Relative pr a) 85 | (Relative (FlipAgency pr) a) 86 | terminationLemma_1 87 | SingAsClient ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency 88 | terminationLemma_1 89 | SingAsServer ReflNobodyAgency ReflNobodyAgency = ReflNobodyHasAgency 90 | terminationLemma_1 SingAsClient ReflClientAgency x = case x of {} 91 | terminationLemma_1 SingAsClient ReflServerAgency x = case x of {} 92 | terminationLemma_1 SingAsServer ReflClientAgency x = case x of {} 93 | terminationLemma_1 SingAsServer ReflServerAgency x = case x of {} 94 | 95 | 96 | -- | Internal; only need to formulate auxiliary lemmas in the proof of 97 | -- 'terminationLemma_2'. 98 | -- 99 | type FlipRelAgency :: RelativeAgency -> RelativeAgency 100 | type family FlipRelAgency ra where 101 | FlipRelAgency WeHaveAgency = TheyHaveAgency 102 | FlipRelAgency TheyHaveAgency = WeHaveAgency 103 | FlipRelAgency NobodyHasAgency = NobodyHasAgency 104 | 105 | 106 | -- | Similar to 'terminationLemma_1'. 107 | -- 108 | -- Note: this could be proven the same way 'terminationLemma_1' is proved, but 109 | -- instead we use two lemmas to reduce the assumptions (arguments) and we apply 110 | -- 'terminationLemma_1'. 111 | -- 112 | terminationLemma_2 113 | :: SingPeerRole pr 114 | -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) 115 | -> ReflRelativeAgency a NobodyHasAgency (Relative pr a) 116 | -> ReflNobodyHasAgency (Relative (FlipAgency pr) a) 117 | (Relative pr a) 118 | 119 | terminationLemma_2 singPeerRole refl refl' = 120 | case terminationLemma_1 singPeerRole 121 | (lemma_flip singPeerRole refl) 122 | (lemma_flip' singPeerRole refl') 123 | of x@ReflNobodyHasAgency -> x 124 | -- note: if we'd swap arguments of the returned @ReflNobodyHasAgency@ type, 125 | -- we wouldn't need to pattern match on the result. But in this form the 126 | -- lemma is a symmetric version of 'terminationLemma_1'. 127 | where 128 | lemma_flip 129 | :: SingPeerRole pr 130 | -> ReflRelativeAgency a ra (Relative (FlipAgency pr) a) 131 | -> ReflRelativeAgency a (FlipRelAgency ra) (Relative pr a) 132 | 133 | lemma_flip' 134 | :: SingPeerRole pr 135 | -> ReflRelativeAgency a ra (Relative pr a) 136 | -> ReflRelativeAgency a (FlipRelAgency ra) (Relative (FlipAgency pr) a) 137 | 138 | -- both lemmas are identity functions: 139 | lemma_flip SingAsClient ReflClientAgency = ReflClientAgency 140 | lemma_flip SingAsClient ReflServerAgency = ReflServerAgency 141 | lemma_flip SingAsClient ReflNobodyAgency = ReflNobodyAgency 142 | lemma_flip SingAsServer ReflClientAgency = ReflClientAgency 143 | lemma_flip SingAsServer ReflServerAgency = ReflServerAgency 144 | lemma_flip SingAsServer ReflNobodyAgency = ReflNobodyAgency 145 | 146 | lemma_flip' SingAsClient ReflClientAgency = ReflClientAgency 147 | lemma_flip' SingAsClient ReflServerAgency = ReflServerAgency 148 | lemma_flip' SingAsClient ReflNobodyAgency = ReflNobodyAgency 149 | lemma_flip' SingAsServer ReflClientAgency = ReflClientAgency 150 | lemma_flip' SingAsServer ReflServerAgency = ReflServerAgency 151 | lemma_flip' SingAsServer ReflNobodyAgency = ReflNobodyAgency 152 | -------------------------------------------------------------------------------- /typed-protocols/src/Network/TypedProtocol/Peer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | 3 | -- | Protocol EDSL. 4 | -- 5 | module Network.TypedProtocol.Peer 6 | ( Peer (..) 7 | , PeerPipelined (..) 8 | , Receiver (..) 9 | , Outstanding 10 | , N (..) 11 | , Nat (Zero, Succ) 12 | , natToInt 13 | , unsafeIntToNat 14 | ) where 15 | 16 | import Data.Kind (Type) 17 | 18 | import Network.TypedProtocol.Core as Core 19 | 20 | -- | A description of a peer that engages in a protocol. 21 | -- 22 | -- __Note__: You should use pattern synonyms exposed in 23 | -- "Network.TypedProtocol.Peer.Client" and "Network.TypedProtocol.Peer.Server", 24 | -- however here we provide in-depth documentation. 25 | -- 26 | -- The protocol describes what messages peers /may/ send or /must/ accept. 27 | -- A particular peer implementation decides what to actually do within the 28 | -- constraints of the protocol. 29 | -- 30 | -- Peers engage in a protocol in either the client or server role. Of course 31 | -- the client role can only interact with the serve role for the same protocol 32 | -- and vice versa. 33 | -- 34 | -- 'Peer' has several type arguments: 35 | -- 36 | -- * the protocol itself; 37 | -- * the client\/server role; 38 | -- * whether the peer is using pipelining or not, if pipelined it holds the 39 | -- depth of pipelining and a type used to collect data from pipelined 40 | -- transitions; 41 | -- * the current protocol state; 42 | -- * the monad in which the peer operates (e.g. 'IO'); 43 | -- * the type of the final result once the peer terminates. 44 | -- 45 | -- For example: 46 | -- 47 | -- > pingPongClientExample :: Peer PingPong AsClient (Pipelined Z Int) StIdle IO () 48 | -- > pingPongServerExample :: Peer PingPong AsServer NonPipeliend StIdle IO Int 49 | -- 50 | -- The actions that a non-pipelining peer can take are: 51 | -- 52 | -- * to perform local monadic effects 53 | -- * to terminate with a result (but only in a terminal protocol state) 54 | -- * to send a message (but only in a protocol state in which we have agency) 55 | -- * to wait to receive a message (but only in a protocol state in which the 56 | -- other peer has agency) 57 | -- 58 | -- In addition a pipelining peer can: 59 | -- 60 | -- * pipeline a message, which requires upfront declaration at which state we 61 | -- continue at and passing a receiver which will run in parallel. When 62 | -- receiver terminates it pushes the result into the pipelining queue. 63 | -- * collect a response from the pipelining queue. 64 | -- 65 | -- The 'Yield', 'Await', 'Done', 'YieldPipelined', 'Collect', 66 | -- constructors require to provide an evidence that the 67 | -- peer has agency in the current state. The types guarantee that it is not 68 | -- possible to supply incorrect evidence, however the 69 | -- pattern synonyms exposed in "Network.TypedProtocol.Peer.Client" and 70 | -- "Network.TypedProtocol.Peer.Client" supply this evidence for you, and hence 71 | -- are easier to use and let you avoid some kinds of type errors. 72 | -- 73 | -- __NOTE__: 74 | -- one should not allocate resources within a `Peer` since there's no way to 75 | -- safely clean-up resources in case of an asynchronous exception. The proper 76 | -- way to allocate resources is to call 77 | -- `Network.TypedProtocol.Driver.runPeerWithDriver` (or `runPeer`, 78 | -- `runPipelinedPeer`) within a `Control.Exception.bracket`. 79 | -- 80 | type Peer :: forall ps 81 | -> PeerRole 82 | -> IsPipelined 83 | -> ps 84 | -> (Type -> Type) 85 | -- ^ monad's kind 86 | -> Type 87 | -> Type 88 | data Peer ps pr pl st m a where 89 | 90 | -- | Perform a local monadic effect and then continue. 91 | -- 92 | -- Example: 93 | -- 94 | -- > Effect $ do 95 | -- > ... -- actions in the monad 96 | -- > return $ ... -- another Peer value 97 | -- 98 | Effect 99 | :: forall ps pr pl st m a. 100 | m (Peer ps pr pl st m a) 101 | -- ^ monadic continuation 102 | -> Peer ps pr pl st m a 103 | 104 | -- | Send a message to the other peer and then continue. This takes the 105 | -- message and the continuation. It also requires evidence that we have 106 | -- agency for this protocol state and thus are allowed to send messages. 107 | -- 108 | -- Example: 109 | -- 110 | -- > Yield ReflClientAgency MsgPing $ ... 111 | -- 112 | Yield 113 | :: forall ps pr pl (st :: ps) (st' :: ps) m a. 114 | ( StateTokenI st 115 | , StateTokenI st' 116 | , ActiveState st 117 | , Outstanding pl ~ Z 118 | ) 119 | => WeHaveAgencyProof pr st 120 | -- ^ agency proof 121 | -> Message ps st st' 122 | -- ^ protocol message 123 | -> Peer ps pr pl st' m a 124 | -- ^ continuation 125 | -> Peer ps pr pl st m a 126 | 127 | -- | Waits to receive a message from the other peer and then continues. 128 | -- This takes the continuation that is supplied with the received message. It 129 | -- also requires evidence that the other peer has agency for this protocol 130 | -- state and thus we are expected to wait to receive messages. 131 | -- 132 | -- Note that the continuation that gets supplied with the message must be 133 | -- prepared to deal with /any/ message that is allowed in /this/ protocol 134 | -- state. This is why the continuation /must/ be polymorphic in the target 135 | -- state of the message (the third type argument of 'Message'). 136 | -- 137 | -- Example: 138 | -- 139 | -- > Await ReflClientAgency $ \msg -> 140 | -- > case msg of 141 | -- > MsgDone -> ... 142 | -- > MsgPing -> ... 143 | -- 144 | Await 145 | :: forall ps pr pl (st :: ps) m a. 146 | ( StateTokenI st 147 | , ActiveState st 148 | , Outstanding pl ~ Z 149 | ) 150 | => TheyHaveAgencyProof pr st 151 | -- ^ agency proof 152 | -> (forall (st' :: ps). Message ps st st' 153 | -> Peer ps pr pl st' m a) 154 | -- ^ continuation 155 | -> Peer ps pr pl st m a 156 | 157 | -- | Terminate with a result. A state token must be provided from the 158 | -- 'NobodyHasAgency' states, to show that this is a state in which we can 159 | -- terminate. 160 | -- 161 | -- Example: 162 | -- 163 | -- > Yield ReflClientAgency 164 | -- > MsgDone 165 | -- > (Done ReflNobodyAgency TokDone result) 166 | -- 167 | Done 168 | :: forall ps pr pl (st :: ps) m a. 169 | ( StateTokenI st 170 | , StateAgency st ~ NobodyAgency 171 | , Outstanding pl ~ Z 172 | ) 173 | => NobodyHasAgencyProof pr st 174 | -- ^ (no) agency proof 175 | -> a 176 | -- ^ returned value 177 | -> Peer ps pr pl st m a 178 | 179 | -- 180 | -- Pipelining primitives 181 | -- 182 | 183 | -- | Pipelined send. We statically decide from which state we continue (the 184 | -- `st''` state here), the gap (between `st'` and `st''`) must be fulfilled 185 | -- by 'Receiver' which runs will run in parallel. 186 | -- 187 | YieldPipelined 188 | :: forall ps pr (st :: ps) (st' :: ps) c n st'' m a. 189 | ( StateTokenI st 190 | , StateTokenI st' 191 | , ActiveState st 192 | ) 193 | => WeHaveAgencyProof pr st 194 | -- ^ agency proof 195 | -> Message ps st st' 196 | -- ^ protocol message 197 | -> Receiver ps pr st' st'' m c 198 | -- ^ receiver 199 | -> Peer ps pr (Pipelined (S n) c) st'' m a 200 | -- ^ continuation from state `st''` 201 | -> Peer ps pr (Pipelined n c) st m a 202 | 203 | -- | Collect results returned by a `Receiver`. Results are collected in the 204 | -- first-in-first-out way. 205 | -- 206 | Collect 207 | :: forall ps pr c n st m a. 208 | ( StateTokenI st 209 | , ActiveState st 210 | ) 211 | => Maybe (Peer ps pr (Pipelined (S n) c) st m a) 212 | -- ^ continuation, executed if no message has arrived so far 213 | -> (c -> Peer ps pr (Pipelined n c) st m a) 214 | -- ^ continuation 215 | -> Peer ps pr (Pipelined (S n) c) st m a 216 | 217 | deriving instance Functor m => Functor (Peer ps pr pl st m) 218 | 219 | 220 | -- | Receiver. It is limited to only awaiting for messages and running monadic 221 | -- computations. This means that one can only pipeline messages if they can be 222 | -- connected by state transitions which all have remote agency. 223 | -- 224 | -- The receiver runs in parallel, see `runPipelinedPeerWithDriver`. This makes 225 | -- pipelining quite effective, since the receiver callbacks are called in 226 | -- a separate thread which can effectively use CPU cache and can avoids 227 | -- unnecessary context switches. 228 | -- 229 | type Receiver :: forall ps 230 | -> PeerRole 231 | -> ps 232 | -- ^ initial state 233 | -> ps 234 | -- ^ final state 235 | -> (Type -> Type) 236 | -- ^ monad 237 | -> Type 238 | -- ^ returned type by the receiver 239 | -> Type 240 | data Receiver ps pr st stdone m c where 241 | 242 | -- | Execute a monadic computation. 243 | -- 244 | ReceiverEffect :: m (Receiver ps pr st stdone m c) 245 | -> Receiver ps pr st stdone m c 246 | 247 | -- | Return value. 248 | -- 249 | ReceiverDone :: c -> Receiver ps pr stdone stdone m c 250 | 251 | -- | Await for for a remote transition. 252 | -- 253 | ReceiverAwait :: ( StateTokenI st 254 | , ActiveState st 255 | ) 256 | => TheyHaveAgencyProof pr st 257 | -> (forall st'. Message ps st st' 258 | -> Receiver ps pr st' stdone m c) 259 | -> Receiver ps pr st stdone m c 260 | 261 | deriving instance Functor m => Functor (Receiver ps pr st stdone m) 262 | 263 | -- | A description of a peer that engages in a protocol in a pipelined fashion. 264 | -- 265 | -- This type is useful for wrapping pipelined peers to hide information which 266 | -- is only relevant in peer lift. It is expected by 267 | -- `Network.TypedProtocol.Driver.runPeerPipelinedWithDriver`. 268 | -- 269 | data PeerPipelined ps pr (st :: ps) m a where 270 | PeerPipelined :: { runPeerPipelined :: Peer ps pr (Pipelined Z c) st m a } 271 | -> PeerPipelined ps pr st m a 272 | 273 | deriving instance Functor m => Functor (PeerPipelined ps pr st m) 274 | -------------------------------------------------------------------------------- /typed-protocols/src/Network/TypedProtocol/Peer/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | -- | Bidirectional patterns for @'Peer' ps 'AsClient'@. The advantage of 4 | -- these patterns is that they automatically provide the 'ReflRelativeAgency' 5 | -- evidence. 6 | -- 7 | module Network.TypedProtocol.Peer.Client 8 | ( -- * Client type alias and its pattern synonyms 9 | Client 10 | , pattern Effect 11 | , pattern Yield 12 | , pattern Await 13 | , pattern Done 14 | , pattern YieldPipelined 15 | , pattern Collect 16 | -- * Receiver type alias and its pattern synonyms 17 | , Receiver 18 | , pattern ReceiverEffect 19 | , pattern ReceiverAwait 20 | , pattern ReceiverDone 21 | -- * ClientPipelined type alias and its pattern synonym 22 | , ClientPipelined 23 | , TP.PeerPipelined (ClientPipelined, runClientPipelined) 24 | -- * re-exports 25 | , IsPipelined (..) 26 | , Outstanding 27 | , N (..) 28 | , Nat (..) 29 | ) where 30 | 31 | import Data.Kind (Type) 32 | 33 | import Network.TypedProtocol.Core 34 | import Network.TypedProtocol.Peer (Peer) 35 | import Network.TypedProtocol.Peer qualified as TP 36 | 37 | 38 | type Client :: forall ps 39 | -> IsPipelined 40 | -> ps 41 | -> (Type -> Type) 42 | -> Type 43 | -> Type 44 | type Client ps pl st m a = Peer ps AsClient pl st m a 45 | 46 | 47 | -- | A description of a peer that engages in a protocol in a pipelined fashion. 48 | -- 49 | type ClientPipelined ps st m a = TP.PeerPipelined ps AsClient st m a 50 | 51 | pattern ClientPipelined :: forall ps st m a. 52 | () 53 | => forall c. 54 | () 55 | => Client ps (Pipelined Z c) st m a 56 | -> ClientPipelined ps st m a 57 | pattern ClientPipelined { runClientPipelined } = TP.PeerPipelined runClientPipelined 58 | 59 | {-# COMPLETE ClientPipelined #-} 60 | 61 | -- | Client role pattern for 'TP.Effect'. 62 | -- 63 | pattern Effect :: forall ps pl st m a. 64 | m (Client ps pl st m a) 65 | -- ^ monadic continuation 66 | -> Client ps pl st m a 67 | pattern Effect mclient = TP.Effect mclient 68 | 69 | 70 | -- | Client role pattern for 'TP.Yield' 71 | -- 72 | pattern Yield :: forall ps pl st m a. 73 | () 74 | => forall st'. 75 | ( StateTokenI st 76 | , StateTokenI st' 77 | , StateAgency st ~ ClientAgency 78 | , Outstanding pl ~ Z 79 | ) 80 | => Message ps st st' 81 | -- ^ protocol message 82 | -> Client ps pl st' m a 83 | -- ^ continuation 84 | -> Client ps pl st m a 85 | pattern Yield msg k = TP.Yield ReflClientAgency msg k 86 | 87 | 88 | -- | Client role pattern for 'TP.Await' 89 | -- 90 | pattern Await :: forall ps pl st m a. 91 | () 92 | => ( StateTokenI st 93 | , StateAgency st ~ ServerAgency 94 | , Outstanding pl ~ Z 95 | ) 96 | => (forall st'. Message ps st st' 97 | -> Client ps pl st' m a) 98 | -- ^ continuation 99 | -> Client ps pl st m a 100 | pattern Await k = TP.Await ReflServerAgency k 101 | 102 | 103 | -- | Client role pattern for 'TP.Done' 104 | -- 105 | pattern Done :: forall ps pl st m a. 106 | () 107 | => ( StateTokenI st 108 | , StateAgency st ~ NobodyAgency 109 | , Outstanding pl ~ Z 110 | ) 111 | => a 112 | -- ^ protocol return value 113 | -> Client ps pl st m a 114 | pattern Done a = TP.Done ReflNobodyAgency a 115 | 116 | 117 | -- | Client role pattern for 'TP.YieldPipelined' 118 | -- 119 | pattern YieldPipelined :: forall ps st n c m a. 120 | () 121 | => forall st' st''. 122 | ( StateTokenI st 123 | , StateTokenI st' 124 | , StateAgency st ~ ClientAgency 125 | ) 126 | => Message ps st st' 127 | -- ^ pipelined message 128 | -> Receiver ps st' st'' m c 129 | -> Client ps (Pipelined (S n) c) st'' m a 130 | -- ^ continuation 131 | -> Client ps (Pipelined n c) st m a 132 | pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflClientAgency msg receiver k 133 | 134 | 135 | -- | Client role pattern for 'TP.Collect' 136 | -- 137 | pattern Collect :: forall ps st n c m a. 138 | () 139 | => ( StateTokenI st 140 | , ActiveState st 141 | ) 142 | => Maybe (Client ps (Pipelined (S n) c) st m a) 143 | -- ^ continuation, executed if no message has arrived so far 144 | -> (c -> Client ps (Pipelined n c) st m a) 145 | -- ^ continuation 146 | -> Client ps (Pipelined (S n) c) st m a 147 | pattern Collect k' k = TP.Collect k' k 148 | 149 | {-# COMPLETE Effect, Yield, Await, Done, YieldPipelined, Collect #-} 150 | 151 | 152 | type Receiver ps st stdone m c = TP.Receiver ps AsClient st stdone m c 153 | 154 | pattern ReceiverEffect :: forall ps st stdone m c. 155 | m (Receiver ps st stdone m c) 156 | -> Receiver ps st stdone m c 157 | pattern ReceiverEffect k = TP.ReceiverEffect k 158 | 159 | pattern ReceiverAwait :: forall ps st stdone m c. 160 | () 161 | => ( StateTokenI st 162 | , ActiveState st 163 | , StateAgency st ~ ServerAgency 164 | ) 165 | => (forall st'. Message ps st st' 166 | -> Receiver ps st' stdone m c 167 | ) 168 | -> Receiver ps st stdone m c 169 | pattern ReceiverAwait k = TP.ReceiverAwait ReflServerAgency k 170 | 171 | pattern ReceiverDone :: forall ps stdone m c. 172 | c 173 | -> Receiver ps stdone stdone m c 174 | pattern ReceiverDone c = TP.ReceiverDone c 175 | 176 | {-# COMPLETE ReceiverEffect, ReceiverAwait, ReceiverDone #-} 177 | -------------------------------------------------------------------------------- /typed-protocols/src/Network/TypedProtocol/Peer/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | -- | Bidirectional patterns for @'Peer' ps 'AsServer'@. The advantage of 5 | -- these patterns is that they automatically provide the 'ReflRelativeAgency' 6 | -- evidence. 7 | -- 8 | module Network.TypedProtocol.Peer.Server 9 | ( -- * Server type alias and its pattern synonyms 10 | Server 11 | , pattern Effect 12 | , pattern Yield 13 | , pattern Await 14 | , pattern Done 15 | , pattern YieldPipelined 16 | , pattern Collect 17 | -- * Receiver type alias and its pattern synonyms 18 | , Receiver 19 | , pattern ReceiverEffect 20 | , pattern ReceiverAwait 21 | , pattern ReceiverDone 22 | -- * ServerPipelined type alias and its pattern synonym 23 | , ServerPipelined 24 | , TP.PeerPipelined (ServerPipelined, runServerPipelined) 25 | -- * re-exports 26 | , IsPipelined (..) 27 | , Outstanding 28 | , N (..) 29 | , Nat (..) 30 | ) where 31 | 32 | import Data.Kind (Type) 33 | 34 | import Network.TypedProtocol.Core 35 | import Network.TypedProtocol.Peer (Peer) 36 | import Network.TypedProtocol.Peer qualified as TP 37 | 38 | 39 | type Server :: forall ps 40 | -> IsPipelined 41 | -> ps 42 | -> (Type -> Type) 43 | -> Type 44 | -> Type 45 | type Server ps pl st m a = Peer ps AsServer pl st m a 46 | 47 | 48 | -- | A description of a peer that engages in a protocol in a pipelined fashion. 49 | -- 50 | type ServerPipelined ps st m a = TP.PeerPipelined ps AsServer st m a 51 | 52 | pattern ServerPipelined :: forall ps st m a. 53 | () 54 | => forall c. 55 | () 56 | => Server ps (Pipelined Z c) st m a 57 | -> ServerPipelined ps st m a 58 | pattern ServerPipelined { runServerPipelined } = TP.PeerPipelined runServerPipelined 59 | 60 | {-# COMPLETE ServerPipelined #-} 61 | 62 | 63 | -- | Server role pattern for 'TP.Effect'. 64 | -- 65 | pattern Effect :: forall ps pl st m a. 66 | m (Server ps pl st m a) 67 | -- ^ monadic continuation 68 | -> Server ps pl st m a 69 | pattern Effect mclient = TP.Effect mclient 70 | 71 | 72 | -- | Server role pattern for 'TP.Yield' 73 | -- 74 | pattern Yield :: forall ps pl st m a. 75 | () 76 | => forall st'. 77 | ( StateTokenI st 78 | , StateTokenI st' 79 | , StateAgency st ~ ServerAgency 80 | , Outstanding pl ~ Z 81 | ) 82 | => Message ps st st' 83 | -- ^ protocol message 84 | -> Server ps pl st' m a 85 | -- ^ continuation 86 | -> Server ps pl st m a 87 | pattern Yield msg k = TP.Yield ReflServerAgency msg k 88 | 89 | 90 | -- | Server role pattern for 'TP.Await' 91 | -- 92 | pattern Await :: forall ps pl st m a. 93 | () 94 | => ( StateTokenI st 95 | , StateAgency st ~ ClientAgency 96 | , Outstanding pl ~ Z 97 | ) 98 | => (forall st'. Message ps st st' 99 | -> Server ps pl st' m a) 100 | -- ^ continuation 101 | -> Server ps pl st m a 102 | pattern Await k = TP.Await ReflClientAgency k 103 | 104 | 105 | -- | Server role pattern for 'TP.Done' 106 | -- 107 | pattern Done :: forall ps pl st m a. 108 | () 109 | => ( StateTokenI st 110 | , StateAgency st ~ NobodyAgency 111 | , Outstanding pl ~ Z 112 | ) 113 | => a 114 | -- ^ protocol return value 115 | -> Server ps pl st m a 116 | pattern Done a = TP.Done ReflNobodyAgency a 117 | 118 | 119 | -- | Server role pattern for 'TP.YieldPipelined' 120 | -- 121 | pattern YieldPipelined :: forall ps st n c m a. 122 | () 123 | => forall st' st''. 124 | ( StateTokenI st 125 | , StateTokenI st' 126 | , StateAgency st ~ ServerAgency 127 | ) 128 | => Message ps st st' 129 | -- ^ pipelined message 130 | -> Receiver ps st' st'' m c 131 | -> Server ps (Pipelined (S n) c) st'' m a 132 | -- ^ continuation 133 | -> Server ps (Pipelined n c) st m a 134 | pattern YieldPipelined msg receiver k = TP.YieldPipelined ReflServerAgency msg receiver k 135 | 136 | 137 | -- | Server role pattern for 'TP.Collect' 138 | -- 139 | pattern Collect :: forall ps st n c m a. 140 | () 141 | => ( StateTokenI st 142 | , ActiveState st 143 | ) 144 | => Maybe (Server ps (Pipelined (S n) c) st m a) 145 | -- ^ continuation, executed if no message has arrived so far 146 | -> (c -> Server ps (Pipelined n c) st m a) 147 | -- ^ continuation 148 | -> Server ps (Pipelined (S n) c) st m a 149 | pattern Collect k' k = TP.Collect k' k 150 | 151 | 152 | {-# COMPLETE Effect, Yield, Await, Done, YieldPipelined, Collect #-} 153 | 154 | 155 | type Receiver ps st stdone m c = TP.Receiver ps AsServer st stdone m c 156 | 157 | pattern ReceiverEffect :: forall ps st stdone m c. 158 | m (Receiver ps st stdone m c) 159 | -> Receiver ps st stdone m c 160 | pattern ReceiverEffect k = TP.ReceiverEffect k 161 | 162 | pattern ReceiverAwait :: forall ps st stdone m c. 163 | () 164 | => ( StateTokenI st 165 | , ActiveState st 166 | , StateAgency st ~ ClientAgency 167 | ) 168 | => (forall st'. Message ps st st' 169 | -> Receiver ps st' stdone m c 170 | ) 171 | -> Receiver ps st stdone m c 172 | pattern ReceiverAwait k = TP.ReceiverAwait ReflClientAgency k 173 | 174 | pattern ReceiverDone :: forall ps stdone m c. 175 | c 176 | -> Receiver ps stdone stdone m c 177 | pattern ReceiverDone c = TP.ReceiverDone c 178 | 179 | {-# COMPLETE ReceiverEffect, ReceiverAwait, ReceiverDone #-} 180 | -------------------------------------------------------------------------------- /typed-protocols/src/Network/TypedProtocol/Proofs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuantifiedConstraints #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | -- This is already implied by the -Wall in the .cabal file, but lets just be 5 | -- completely explicit about it too, since we rely on the completeness 6 | -- checking in the cases below for the completeness of our proofs. 7 | {-# OPTIONS_GHC -Wincomplete-patterns #-} 8 | 9 | -- | Proofs and helpful testing utilities. 10 | -- 11 | module Network.TypedProtocol.Proofs 12 | ( -- * Connect proofs 13 | connect 14 | , connectPipelined 15 | , TerminalStates (..) 16 | -- * Pipelining proofs 17 | -- | Additional proofs specific to the pipelining features 18 | , forgetPipelined 19 | , promoteToPipelined 20 | -- ** Pipeline proof helpers 21 | , Queue (..) 22 | , enqueue 23 | -- ** Auxiliary functions 24 | , pipelineInterleaving 25 | ) where 26 | 27 | import Data.Singletons 28 | import Network.TypedProtocol.Core 29 | import Network.TypedProtocol.Lemmas 30 | import Network.TypedProtocol.Peer 31 | 32 | 33 | -- | The 'connect' function takes two peers that agree on a protocol and runs 34 | -- them in lock step, until (and if) they complete. 35 | -- 36 | -- The 'connect' function serves a few purposes. 37 | -- 38 | -- * The fact we can define this function at at all proves some minimal 39 | -- sanity property of the typed protocol framework. 40 | -- 41 | -- * It demonstrates that all protocols defined in the framework can be run 42 | -- with synchronous communication rather than requiring buffered communication. 43 | -- 44 | -- * It is useful for testing peer implementations against each other in a 45 | -- minimalistic setting. 46 | -- 47 | connect 48 | :: forall ps (pr :: PeerRole) (initSt :: ps) m a b. 49 | (Monad m, SingI pr) 50 | => Peer ps pr NonPipelined initSt m a 51 | -- ^ a peer 52 | -> Peer ps (FlipAgency pr) NonPipelined initSt m b 53 | -- ^ a peer with flipped agency 54 | -> m (a, b, TerminalStates ps) 55 | -- ^ peers results and an evidence of their termination 56 | connect = go 57 | where 58 | singPeerRole :: Sing pr 59 | singPeerRole = sing 60 | 61 | go :: forall (st :: ps). 62 | Peer ps pr NonPipelined st m a 63 | -> Peer ps (FlipAgency pr) NonPipelined st m b 64 | -> m (a, b, TerminalStates ps) 65 | go (Done ReflNobodyAgency a) (Done ReflNobodyAgency b) = 66 | return (a, b, terminals) 67 | where 68 | terminals :: TerminalStates ps 69 | terminals = TerminalStates (stateToken :: StateToken st) 70 | (stateToken :: StateToken st) 71 | 72 | go (Effect a ) b = a >>= \a' -> go a' b 73 | go a (Effect b) = b >>= \b' -> go a b' 74 | go (Yield _ msg a) (Await _ b) = go a (b msg) 75 | go (Await _ a) (Yield _ msg b) = go (a msg) b 76 | 77 | -- By appealing to the proofs about agency for this protocol we can 78 | -- show that these other cases are impossible 79 | go (Yield reflA _ _) (Yield reflB _ _) = 80 | case exclusionLemma_ClientAndServerHaveAgency singPeerRole reflA reflB of 81 | ReflNobodyHasAgency -> case reflA of {} 82 | 83 | go (Await reflA _) (Await reflB _) = 84 | case exclusionLemma_ClientAndServerHaveAgency singPeerRole reflA reflB of 85 | ReflNobodyHasAgency -> case reflA of {} 86 | 87 | go (Done reflA _) (Yield reflB _ _) = 88 | case terminationLemma_2 singPeerRole reflB reflA of 89 | ReflNobodyHasAgency -> case reflB of {} 90 | 91 | go (Done reflA _) (Await reflB _) = 92 | case terminationLemma_2 singPeerRole reflB reflA of 93 | ReflNobodyHasAgency -> case reflB of {} 94 | 95 | go (Yield reflA _ _) (Done reflB _) = 96 | case terminationLemma_1 singPeerRole reflA reflB of 97 | ReflNobodyHasAgency -> case reflA of {} 98 | 99 | go (Await reflA _) (Done reflB _) = 100 | case terminationLemma_1 singPeerRole reflA reflB of 101 | ReflNobodyHasAgency -> case reflA of {} 102 | 103 | 104 | -- | The terminal states for the protocol. Used in 'connect' and 105 | -- 'connectPipelined' to return the states in which the peers terminated. 106 | -- 107 | data TerminalStates ps where 108 | TerminalStates 109 | :: forall ps (st :: ps). 110 | (StateAgency st ~ NobodyAgency) 111 | => StateToken st 112 | -- ^ state termination evidence for the first peer 113 | -> StateToken st 114 | -- ^ state termination evidence for the second peer 115 | -> TerminalStates ps 116 | 117 | -- 118 | -- Remove Pipelining 119 | -- 120 | 121 | 122 | -- | A size indexed queue. This is useful for proofs, including 123 | -- 'connectPipelined' but also as so-called @direct@ functions for running a 124 | -- client and server wrapper directly against each other. 125 | -- 126 | data Queue (n :: N) a where 127 | EmptyQ :: Queue Z a 128 | ConsQ :: a -> Queue n a -> Queue (S n) a 129 | 130 | -- | At an element to the end of a 'Queue'. This is not intended to be 131 | -- efficient. It is only for proofs and tests. 132 | -- 133 | enqueue :: a -> Queue n a -> Queue (S n) a 134 | enqueue a EmptyQ = ConsQ a EmptyQ 135 | enqueue a (ConsQ b q) = ConsQ b (enqueue a q) 136 | 137 | 138 | -- | Proof that we have a total conversion from pipelined peers to regular 139 | -- peers. This is a sanity property that shows that pipelining did not give 140 | -- us extra expressiveness or to break the protocol state machine. 141 | -- 142 | forgetPipelined 143 | :: forall ps (pr :: PeerRole) (st :: ps) m a. 144 | Functor m 145 | => [Bool] 146 | -- ^ interleaving choices for pipelining allowed by `Collect` primitive. False 147 | -- values or `[]` give no pipelining. 148 | -> PeerPipelined ps pr st m a 149 | -> Peer ps pr NonPipelined st m a 150 | forgetPipelined cs0 (PeerPipelined peer) = goSender EmptyQ cs0 peer 151 | where 152 | goSender :: forall st' n c. 153 | Queue n c 154 | -> [Bool] 155 | -> Peer ps pr ('Pipelined n c) st' m a 156 | -> Peer ps pr 'NonPipelined st' m a 157 | 158 | goSender EmptyQ _cs (Done refl k) = Done refl k 159 | goSender q cs (Effect k) = Effect (goSender q cs <$> k) 160 | goSender q cs (Yield refl m k) = Yield refl m (goSender q cs k) 161 | goSender q cs (Await refl k) = Await refl (goSender q cs <$> k) 162 | goSender q cs (YieldPipelined refl m r k) = Yield refl m (goReceiver q cs k r) 163 | goSender q (True:cs') (Collect (Just k) _) = goSender q cs' k 164 | goSender (ConsQ x q) (_:cs) (Collect _ k) = goSender q cs (k x) 165 | goSender (ConsQ x q) cs@[] (Collect _ k) = goSender q cs (k x) 166 | 167 | goReceiver :: forall stCurrent stNext n c. 168 | Queue n c 169 | -> [Bool] 170 | -> Peer ps pr ('Pipelined (S n) c) stNext m a 171 | -> Receiver ps pr stCurrent stNext m c 172 | -> Peer ps pr 'NonPipelined stCurrent m a 173 | 174 | goReceiver q cs s (ReceiverDone x) = goSender (enqueue x q) cs s 175 | goReceiver q cs s (ReceiverEffect k) = Effect (goReceiver q cs s <$> k) 176 | goReceiver q cs s (ReceiverAwait refl k) = Await refl (goReceiver q cs s . k) 177 | 178 | 179 | -- | Promote a peer to a pipelined one. 180 | -- 181 | -- This is a right inverse of `forgetPipelined`, e.g. 182 | -- 183 | -- >>> forgetPipelined . promoteToPipelined = id 184 | -- 185 | promoteToPipelined 186 | :: forall ps (pr :: PeerRole) st m a. 187 | Functor m 188 | => Peer ps pr NonPipelined st m a 189 | -- ^ a peer 190 | -> PeerPipelined ps pr st m a 191 | -- ^ a pipelined peer 192 | promoteToPipelined p = PeerPipelined (go p) 193 | where 194 | go :: forall st' c. 195 | Peer ps pr NonPipelined st' m a 196 | -> Peer ps pr (Pipelined Z c) st' m a 197 | go (Effect k) = Effect $ go <$> k 198 | go (Yield refl msg k) = Yield refl msg (go k) 199 | go (Await refl k) = Await refl (go . k) 200 | go (Done refl k) = Done refl k 201 | 202 | 203 | -- | Analogous to 'connect' but also for pipelined peers. 204 | -- 205 | -- Since pipelining allows multiple possible interleavings, we provide a 206 | -- @[Bool]@ parameter to control the choices. Each @True@ will trigger picking 207 | -- the first choice in the @SenderCollect@ construct (if possible), leading 208 | -- to more results outstanding. This can also be interpreted as a greater 209 | -- pipeline depth, or more messages in-flight. 210 | -- 211 | -- This can be exercised using a QuickCheck style generator. 212 | -- 213 | connectPipelined 214 | :: forall ps (pr :: PeerRole) 215 | (st :: ps) m a b. 216 | (Monad m, SingI pr) 217 | => [Bool] 218 | -- ^ an interleaving 219 | -> PeerPipelined ps pr st m a 220 | -- ^ a pipelined peer 221 | -> Peer ps (FlipAgency pr) NonPipelined st m b 222 | -- ^ a non-pipelined peer with fliped agency 223 | -> m (a, b, TerminalStates ps) 224 | -- ^ peers results and an evidence of their termination 225 | connectPipelined csA a b = 226 | connect (forgetPipelined csA a) b 227 | 228 | -- | A reference specification for interleaving of requests and responses 229 | -- with pipelining, where the environment can choose whether a response is 230 | -- available yet. 231 | -- 232 | -- This also supports bounded choice where the maximum number of outstanding 233 | -- in-flight responses is limited. 234 | -- 235 | pipelineInterleaving :: Int -- ^ Bound on outstanding responses 236 | -> [Bool] -- ^ Pipelining choices 237 | -> [req] -> [resp] -> [Either req resp] 238 | pipelineInterleaving omax cs0 reqs0 resps0 = 239 | go 0 cs0 (zip [0 :: Int ..] reqs0) 240 | (zip [0 :: Int ..] resps0) 241 | where 242 | go o (c:cs) reqs@((reqNo, req) :reqs') 243 | resps@((respNo,resp):resps') 244 | | respNo == reqNo = Left req : go (o+1) (c:cs) reqs' resps 245 | | c && o < omax = Left req : go (o+1) cs reqs' resps 246 | | otherwise = Right resp : go (o-1) cs reqs resps' 247 | 248 | go o [] reqs@((reqNo, req) :reqs') 249 | resps@((respNo,resp):resps') 250 | | respNo == reqNo = Left req : go (o+1) [] reqs' resps 251 | | otherwise = Right resp : go (o-1) [] reqs resps' 252 | 253 | go _ _ [] resps = map (Right . snd) resps 254 | go _ _ (_:_) [] = error "pipelineInterleaving: not enough responses" 255 | -------------------------------------------------------------------------------- /typed-protocols/stateful-cborg/Network/TypedProtocol/Stateful/Codec/CBOR.hs: -------------------------------------------------------------------------------- 1 | module Network.TypedProtocol.Stateful.Codec.CBOR 2 | ( module Network.TypedProtocol.Stateful.Codec 3 | , DeserialiseFailure 4 | , mkCodecCborLazyBS 5 | , mkCodecCborStrictBS 6 | ) where 7 | 8 | import Control.Monad.Class.MonadST (MonadST (..)) 9 | 10 | import Codec.CBOR.Decoding qualified as CBOR (Decoder) 11 | import Codec.CBOR.Encoding qualified as CBOR (Encoding) 12 | import Codec.CBOR.Read qualified as CBOR 13 | import Codec.CBOR.Write qualified as CBOR 14 | import Data.ByteString qualified as BS 15 | import Data.ByteString.Builder qualified as BS 16 | import Data.ByteString.Builder.Extra qualified as BS 17 | import Data.ByteString.Lazy qualified as LBS 18 | import Data.ByteString.Lazy.Internal qualified as LBS (smallChunkSize) 19 | 20 | import Network.TypedProtocol.Codec.CBOR (DeserialiseFailure, 21 | convertCborDecoderBS, convertCborDecoderLBS) 22 | import Network.TypedProtocol.Core 23 | import Network.TypedProtocol.Stateful.Codec 24 | 25 | 26 | -- | Construct a 'Codec' for a CBOR based serialisation format, using strict 27 | -- 'BS.ByteString's. 28 | -- 29 | -- This is an adaptor between the @cborg@ library and the 'Codec' abstraction. 30 | -- 31 | -- It takes encode and decode functions for the protocol messages that use the 32 | -- CBOR library encoder and decoder. 33 | -- 34 | -- Note that this is /less/ efficient than the 'mkCodecCborLazyBS' variant 35 | -- because it has to copy and concatenate the result of the encoder (which 36 | -- natively produces chunks). 37 | -- 38 | mkCodecCborStrictBS 39 | :: forall ps f m. MonadST m 40 | 41 | => (forall (st :: ps) (st' :: ps). 42 | StateTokenI st 43 | =>ActiveState st 44 | => f st -> Message ps st st' -> CBOR.Encoding) 45 | -- ^ cbor encoder 46 | 47 | -> (forall (st :: ps) s. 48 | ActiveState st 49 | => StateToken st 50 | -> f st 51 | -> CBOR.Decoder s (SomeMessage st)) 52 | -- ^ cbor decoder 53 | 54 | -> Codec ps DeserialiseFailure f m BS.ByteString 55 | mkCodecCborStrictBS cborMsgEncode cborMsgDecode = 56 | Codec { 57 | encode = \f msg -> convertCborEncoder (cborMsgEncode f) msg, 58 | decode = \stok f -> convertCborDecoder (cborMsgDecode stok f) 59 | } 60 | where 61 | convertCborEncoder :: (a -> CBOR.Encoding) -> a -> BS.ByteString 62 | convertCborEncoder cborEncode = 63 | CBOR.toStrictByteString 64 | . cborEncode 65 | 66 | convertCborDecoder 67 | :: (forall s. CBOR.Decoder s a) 68 | -> m (DecodeStep BS.ByteString DeserialiseFailure m a) 69 | convertCborDecoder cborDecode = 70 | convertCborDecoderBS cborDecode stToIO 71 | 72 | -- | Construct a 'Codec' for a CBOR based serialisation format, using lazy 73 | -- 'BS.ByteString's. 74 | -- 75 | -- This is an adaptor between the @cborg@ library and the 'Codec' abstraction. 76 | -- 77 | -- It takes encode and decode functions for the protocol messages that use the 78 | -- CBOR library encoder and decoder. 79 | -- 80 | mkCodecCborLazyBS 81 | :: forall ps f m. MonadST m 82 | 83 | => (forall (st :: ps) (st' :: ps). 84 | StateTokenI st 85 | => ActiveState st 86 | => f st 87 | -> Message ps st st' -> CBOR.Encoding) 88 | -- ^ cbor encoder 89 | 90 | -> (forall (st :: ps) s. 91 | ActiveState st 92 | => StateToken st 93 | -> f st 94 | -> CBOR.Decoder s (SomeMessage st)) 95 | -- ^ cbor decoder 96 | 97 | -> Codec ps CBOR.DeserialiseFailure f m LBS.ByteString 98 | mkCodecCborLazyBS cborMsgEncode cborMsgDecode = 99 | Codec { 100 | encode = \f msg -> convertCborEncoder (cborMsgEncode f) msg, 101 | decode = \stok f -> convertCborDecoder (cborMsgDecode stok f) 102 | } 103 | where 104 | convertCborEncoder :: (a -> CBOR.Encoding) -> a -> LBS.ByteString 105 | convertCborEncoder cborEncode = 106 | toLazyByteString 107 | . CBOR.toBuilder 108 | . cborEncode 109 | 110 | convertCborDecoder 111 | :: (forall s. CBOR.Decoder s a) 112 | -> m (DecodeStep LBS.ByteString CBOR.DeserialiseFailure m a) 113 | convertCborDecoder cborDecode = 114 | convertCborDecoderLBS cborDecode stToIO 115 | 116 | {-# NOINLINE toLazyByteString #-} 117 | toLazyByteString :: BS.Builder -> LBS.ByteString 118 | toLazyByteString = BS.toLazyByteStringWith strategy LBS.empty 119 | where 120 | -- Buffer strategy and sizes better tuned to our network protocol situation. 121 | -- 122 | -- The LBS.smallChunkSize is 4k - heap object overheads, so that 123 | -- it does fit in a 4k overall. 124 | -- 125 | strategy = BS.untrimmedStrategy 800 LBS.smallChunkSize 126 | 127 | -------------------------------------------------------------------------------- /typed-protocols/stateful/Network/TypedProtocol.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | This package defines the typed protocol framework. This module re-exports 3 | -- the public API. 4 | -- 5 | module Network.TypedProtocol 6 | ( -- * Introduction 7 | -- $intro 8 | -- * Defining and implementing protocols 9 | -- $defining 10 | module Network.TypedProtocol.Core 11 | -- ** Protocol proofs and tests 12 | -- $tests 13 | , module Network.TypedProtocol.Proofs 14 | -- * Running protocols 15 | -- $running 16 | , module Network.TypedProtocol.Driver 17 | ) where 18 | 19 | import Network.TypedProtocol.Core 20 | import Network.TypedProtocol.Driver 21 | import Network.TypedProtocol.Proofs 22 | 23 | 24 | -- $intro 25 | -- 26 | -- The typed protocol framework is used to define, test and execute protocols. 27 | -- 28 | -- It guarantees: 29 | -- 30 | -- * agreement on which messages can be sent and received; 31 | -- * the absence of race conditions; and 32 | -- * the absence of deadlock. 33 | -- 34 | -- The trade-off to achieve these guarantees is that it places constraints on 35 | -- the kinds of protocol that can be expressed. In particular it requires that 36 | -- protocols be defined as a state transition system. It requires for each 37 | -- protocol state that exactly one of the two peers be able to send and the 38 | -- other must be ready to receive. 39 | -- 40 | -- This means it is not possible to express protocols such as TCP where there 41 | -- are protocol states where a single peer can both send and receive, however 42 | -- it is suitable for most application-level protocols. In particular many 43 | -- application-level protocols are completely in-order and synchronous. That 44 | -- said, in many (but not all) cases it is possible to pipeline these protocols 45 | -- so that network latency can be hidden and full use made of the available 46 | -- bandwidth. Special support is provided to run protocols in a pipelined way, 47 | -- without having to change the protocol definition. 48 | -- 49 | -- The protocols in this framework assume an underlying \"reliable ordered\" 50 | -- connection. A \"reliable ordered\" connection is a term of art meaning one 51 | -- where the receiving end receives any prefix of the messages sent by the 52 | -- sending end. It is not reliable in the colloquial sense as it does not 53 | -- ensure that anything actually arrives, only that /if/ any message arrives, 54 | -- all the previous messages did too, and that they arrive in the order in 55 | -- which they were sent. 56 | -- 57 | -- The framework also provides: 58 | -- 59 | -- * an abstraction for untyped channels; 60 | -- * a codec abstraction for encoding and decoding protocol messages; and 61 | -- * drivers for running protocol peers with a channel and a codec. 62 | 63 | 64 | -- $defining 65 | -- 66 | -- The "Network.TypedProtocol.Core" module defines the core of the system. 67 | -- 68 | -- Start reading here to understand: 69 | -- 70 | -- * how to define new protocols; or 71 | -- * to write peers that engage in a protocol. 72 | -- 73 | -- Typed protocol messages need to be converted to and from untyped 74 | -- serialised forms to send over a transport channel. So part of defining a new 75 | -- protocol is to define the message encoding and the codec for doing the 76 | -- encoding and decoding. This is somewhat (but not significantly) more complex 77 | -- than defining normal data type serialisation because of the need to decode 78 | -- typed protocol messages. The "Network.TypedProtocol.Codec" module provides 79 | -- the codec abstraction to capture this. 80 | 81 | 82 | -- $tests 83 | -- 84 | -- There are a few proofs about the framework that we can state and implement 85 | -- as Haskell functions (using GADTs and evaluation). A couple of these proofs 86 | -- rely on a few lemmas that should be proved for each protocol. The 87 | -- "Network.TypedProtocol.Proofs" module describes these proof and provides 88 | -- the infrastructure for the simple lemmas that need to be implemented for 89 | -- each protocol. 90 | -- 91 | -- This module also provides utilities helpful for testing protocols. 92 | 93 | 94 | -- $running 95 | -- 96 | -- Typed protocols need to be able to send messages over untyped transport 97 | -- channels. The "Network.TypedProtocol.Channel" module provides such an 98 | -- abstraction. You can use existing example implementations of this interface 99 | -- or define your own to run over other transports. 100 | -- 101 | -- Given a protocol peer, and a channel and a codec we can run the protocol 102 | -- peer so that it engages in the protocol sending and receiving messages 103 | -- over the channel. The "Network.TypedProtocol.Driver" module provides drivers 104 | -- for normal and pipelined peers. 105 | 106 | 107 | -- $pipelining 108 | -- Protocol pipelining is a technique to make effective use of network 109 | -- resources. 110 | -- 111 | -- <> 112 | -- 113 | -- As in the above diagram, instead of sending a request and waiting for the 114 | -- response before sending the next request, pipelining involves sending all 115 | -- three requests back-to-back and waiting for the three replies. The server 116 | -- still simply processes the requests in order and the replies come back in 117 | -- the same order as the requests were made. 118 | -- 119 | -- Not only does this save network latency, one round trip versus three in 120 | -- the diagram above, but it also makes effective use of the bandwidth by 121 | -- sending requests and replies back-to-back. 122 | -- 123 | -- In the example in the diagram it stops after three requests, but such a 124 | -- pattern can go on indefinately with messages going in both directions, 125 | -- which can saturate the available bandwidth. 126 | -- 127 | -- For many (but not all) protocols that can be defined in the @typed-protocol@ 128 | -- framework it is possible to take the protocol, without changing the 129 | -- protocol's state machine, and to engage in the protocol in a pipelined way. 130 | -- Only the pipelined client has to be written specially. The server side can 131 | -- be used unaltered and can be used with either pipelined or non-pipelined 132 | -- clients. 133 | 134 | 135 | -------------------------------------------------------------------------------- /typed-protocols/stateful/Network/TypedProtocol/Stateful/Driver.hs: -------------------------------------------------------------------------------- 1 | -- | Actions for running 'Peer's with a 'Driver'. This module should be 2 | -- imported qualified. 3 | -- 4 | module Network.TypedProtocol.Stateful.Driver 5 | ( -- * DriverIngerface 6 | Driver (..) 7 | -- * Running a peer 8 | , runPeerWithDriver 9 | -- * Re-exports 10 | , SomeMessage (..) 11 | , DecodeStep (..) 12 | ) where 13 | 14 | import Control.Monad.Class.MonadSTM 15 | 16 | import Data.Kind (Type) 17 | 18 | import Network.TypedProtocol.Codec (DecodeStep (..), SomeMessage (..)) 19 | import Network.TypedProtocol.Core 20 | import Network.TypedProtocol.Stateful.Peer 21 | 22 | data Driver ps (pr :: PeerRole) bytes failure dstate f m = 23 | Driver { 24 | -- | Send a message. 25 | -- 26 | sendMessage :: forall (st :: ps) (st' :: ps). 27 | StateTokenI st 28 | => StateTokenI st' 29 | => ActiveState st 30 | => ReflRelativeAgency (StateAgency st) 31 | WeHaveAgency 32 | (Relative pr (StateAgency st)) 33 | -> f st 34 | -- local state associated to protocol state `st`; 35 | -- local state should not be sent to the remote side. 36 | -- However it provide extra context for the encoder. 37 | -- 38 | -- TODO: input-output-hk/typed-protocols#57 39 | -> Message ps st st' 40 | -- message to send 41 | -- 42 | -- TODO: input-output-hk/typed-protocols#57 43 | -> m () 44 | 45 | , -- | Receive a message, a blocking action which reads from the network 46 | -- and runs the incremental decoder until a full message is decoded. 47 | -- 48 | recvMessage :: forall (st :: ps). 49 | StateTokenI st 50 | => ActiveState st 51 | => ReflRelativeAgency (StateAgency st) 52 | TheyHaveAgency 53 | (Relative pr (StateAgency st)) 54 | -> f st 55 | -- local state which provides extra context for the 56 | -- decoder. 57 | -- 58 | -- TODO: input-output-hk/typed-protocols#57 59 | -> dstate 60 | -- decoder state, e.g. bytes left from decoding of 61 | -- a previous message. 62 | -- 63 | -- TODO: input-output-hk/typed-protocols#57 64 | -> m (SomeMessage st, dstate) 65 | 66 | , -- | Initial decoder state. 67 | -- 68 | initialDState :: dstate 69 | } 70 | 71 | 72 | -- 73 | -- Running peers 74 | -- 75 | 76 | -- | Run a peer with the given driver. 77 | -- 78 | -- This runs the peer to completion (if the protocol allows for termination). 79 | -- 80 | -- NOTE: this function threads local state (i.e. `f`) through evolution of 81 | -- a protocol (i.e. `Peer`). 82 | -- 83 | runPeerWithDriver 84 | :: forall ps (st :: ps) pr bytes failure dstate (f :: ps -> Type) m a. 85 | MonadSTM m 86 | => Driver ps pr bytes failure dstate f m 87 | -> f st 88 | -> Peer ps pr st f m a 89 | -> m (a, dstate) 90 | runPeerWithDriver Driver{ sendMessage 91 | , recvMessage 92 | , initialDState 93 | } = 94 | go initialDState 95 | where 96 | go :: forall st'. 97 | dstate 98 | -> f st' 99 | -> Peer ps pr st' f m a 100 | -> m (a, dstate) 101 | go !dstate !f (Effect k) = k >>= go dstate f 102 | 103 | go !dstate _ (Done _ x) = return (x, dstate) 104 | 105 | go !dstate _ (Yield refl !f !f' msg k) = do 106 | sendMessage refl f msg 107 | go dstate f' k 108 | 109 | go !dstate !f (Await refl k) = do 110 | (SomeMessage msg, dstate') <- recvMessage refl f dstate 111 | case k f msg of 112 | (k', f') -> go dstate' f' k' 113 | -------------------------------------------------------------------------------- /typed-protocols/stateful/Network/TypedProtocol/Stateful/Peer.hs: -------------------------------------------------------------------------------- 1 | -- TODO: the 'Functor' instance of 'Peer' is undecidable 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | -- | Protocol stateful EDSL. 5 | -- 6 | -- __Note__: 'Network.TypedProtocol.Peer.Client.Client' and 7 | -- 'Network.TypedProtocol.Peer.Server.Server' patterns are easier to use. 8 | -- 9 | module Network.TypedProtocol.Stateful.Peer (Peer (..)) where 10 | 11 | import Data.Kind (Type) 12 | 13 | import Network.TypedProtocol.Core as Core 14 | 15 | 16 | -- | A description of a peer that engages in a protocol. 17 | -- 18 | -- The protocol describes what messages peers /may/ send or /must/ accept. 19 | -- A particular peer implementation decides what to actually do within the 20 | -- constraints of the protocol. 21 | -- 22 | -- Peers engage in a protocol in either the client or server role. Of course 23 | -- the client role can only interact with the serve role for the same protocol 24 | -- and vice versa. 25 | -- 26 | -- 'Peer' has several type arguments: 27 | -- 28 | -- * the protocol itself; 29 | -- * the client\/server role; 30 | -- * the current protocol state; 31 | -- * the local state type; 32 | -- * the monad in which the peer operates; and 33 | -- * the type of any final result once the peer terminates. 34 | -- 35 | -- For example: 36 | -- 37 | -- > reqRespClientExample :: Peer (ReqResp FileAPI) AsClient StIdle State m () 38 | -- > reqRespServerExample :: Peer (ReqResp FileAPI) AsServer StIdle State m Int 39 | -- 40 | -- The actions that a peer can take are: 41 | -- 42 | -- * perform a local monadic effect, 43 | -- * terminate with a result (but only in a terminal protocol state), 44 | -- * send a message (but only in a protocol state in which we have agency), 45 | -- * wait to receive a message (but only in a protocol state in which the 46 | -- other peer has agency). 47 | -- 48 | -- The 'Yield', 'Await' and 'Done' constructors require to provide an evidence 49 | -- that the appropriate peer has agency. This information is supplied using 50 | -- one of the constructors of 'ReflRelativeAgency'. 51 | -- 52 | -- While this evidence must be provided, the types guarantee that it is not 53 | -- possible to supply incorrect evidence. The 54 | -- 'Network.TypedProtocol.Peer.Client' or 'Network.TypedProtocol.Peer.Server' 55 | -- pattern synonyms provide this evidence automatically. 56 | -- 57 | -- __NOTE__: 58 | -- one should not allocate resources within a `Peer` since there's no way to 59 | -- safely clean-up resources in case of an asynchronous exception. The proper 60 | -- way to allocate resources is to call 61 | -- `Network.TypedProtocol.Stateful.Driver.runPeerWithDriver` within 62 | -- a `Control.Exception.bracket`. 63 | -- 64 | -- __TODO__: 65 | -- We are not exposing pipelined version, since it is not possible to write 66 | -- a driver & proofs in a type safe which take into account the state when the 67 | -- peer type only tracks depth of pipelining rather than pipelined transitions. 68 | -- 69 | type Peer :: forall ps 70 | -> PeerRole 71 | -> ps 72 | -> (ps -> Type) 73 | -- ^ protocol state 74 | -> (Type -> Type) 75 | -- ^ monad's kind 76 | -> Type 77 | -> Type 78 | data Peer ps pr st f m a where 79 | 80 | -- | Perform a local monadic effect and then continue. 81 | -- 82 | -- Example: 83 | -- 84 | -- > Effect $ do 85 | -- > ... -- actions in the monad 86 | -- > return $ ... -- another Peer value 87 | -- 88 | Effect 89 | :: forall ps pr st f m a. 90 | m (Peer ps pr st f m a) 91 | -- ^ monadic continuation 92 | -> Peer ps pr st f m a 93 | 94 | -- | Send a message to the other peer and then continue. The constructor 95 | -- requires evidence that we have agency for this protocol state and thus are 96 | -- allowed to send messages. It takes local state associated to the source 97 | -- and target protocol state of the message that is sent. This state is only 98 | -- maintained locally, never shared remotely. It also takes the message and 99 | -- the continuation. It also requires evidence that we have agency for this 100 | -- protocol state and thus are allowed to send messages. 101 | -- 102 | -- Example: 103 | -- 104 | -- > Yield ReflClientAgency (StateBusy (ReadFile /etc/os-release)) 105 | -- > StateIdle 106 | -- > $ MsgResp "..." 107 | -- 108 | Yield 109 | :: forall ps pr (st :: ps) (st' :: ps) f m a. 110 | ( StateTokenI st 111 | , StateTokenI st' 112 | , ActiveState st 113 | ) 114 | => WeHaveAgencyProof pr st 115 | -- ^ agency singleton 116 | -> f st 117 | -- ^ associated local state to the source protocol state 'st' 118 | -> f st' 119 | -- ^ associated local state to the target protocol state `st'` 120 | -> Message ps st st' 121 | -- ^ protocol message 122 | -> Peer ps pr st' f m a 123 | -- ^ continuation 124 | -> Peer ps pr st f m a 125 | 126 | -- | Waits to receive a message from the other peer and then continues. 127 | -- This takes the continuation that is supplied with the received message. It 128 | -- also requires evidence that the other peer has agency for this protocol 129 | -- state and thus we are expected to wait to receive messages. 130 | -- 131 | -- Note that the continuation that gets supplied with the message must be 132 | -- prepared to deal with /any/ message that is allowed in /this/ protocol 133 | -- state. This is why the continuation /must/ be polymorphic in the target 134 | -- state of the message (the third type argument of 'Message'). 135 | -- 136 | -- Example: 137 | -- 138 | -- > Await ReflClientAgency $ \f msg -> 139 | -- > case (f, msg) of 140 | -- > (StateBusy (ReadFile path), MsgResp resp) -> 141 | -- > ( _continuation 142 | -- > , StateIdle 143 | -- > ) 144 | -- 145 | -- 146 | Await 147 | :: forall ps pr (st :: ps) f m a. 148 | ( StateTokenI st 149 | , ActiveState st 150 | ) 151 | => TheyHaveAgencyProof pr st 152 | -- ^ agency singleton 153 | -> (forall (st' :: ps). 154 | f st 155 | -- associated local state to the source protocol state 'st' 156 | -- 157 | -- TODO: input-output-hk/typed-protocols#57 158 | -> Message ps st st' 159 | -> ( Peer ps pr st' f m a 160 | , f st' 161 | ) 162 | -- continuation and associated local state to the target protocol 163 | -- state `st'` 164 | -- 165 | -- NOTE: the API is limited to pure transition of local state e.g. 166 | -- `f st -> Message ps st st' -> f st'`, 167 | -- see https://github.com/input-output-hk/typed-protocols/discussions/63 168 | -- 169 | -- TODO: input-output-hk/typed-protocols#57 170 | ) 171 | -- ^ continuation 172 | -> Peer ps pr st f m a 173 | 174 | -- | Terminate with a result. A state token must be provided from the 175 | -- 'NobodyHasAgency' states, to show that this is a state in which we can 176 | -- terminate. 177 | -- 178 | -- Example: 179 | -- 180 | -- > Yield ReflClientAgency 181 | -- > MsgDone 182 | -- > (Done ReflNobodyAgency TokDone result) 183 | -- 184 | Done 185 | :: forall ps pr (st :: ps) f m a. 186 | ( StateTokenI st 187 | , StateAgency st ~ NobodyAgency 188 | ) 189 | => NobodyHasAgencyProof pr st 190 | -- ^ (no) agency proof 191 | -> a 192 | -- ^ returned value 193 | -> Peer ps pr st f m a 194 | 195 | deriving instance Functor m => Functor (Peer ps pr st f m) 196 | -------------------------------------------------------------------------------- /typed-protocols/stateful/Network/TypedProtocol/Stateful/Peer/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | -- | Bidirectional patterns for @'Peer' ps 'AsClient'@. The advantage of 4 | -- these patterns is that they automatically provide the 'RelativeAgencyEq' 5 | -- singleton. 6 | -- 7 | module Network.TypedProtocol.Stateful.Peer.Client 8 | ( -- * Client type alias and its pattern synonyms 9 | Client 10 | , pattern Effect 11 | , pattern Yield 12 | , pattern Await 13 | , pattern Done 14 | ) where 15 | 16 | import Data.Kind (Type) 17 | 18 | import Network.TypedProtocol.Core 19 | import Network.TypedProtocol.Stateful.Peer (Peer) 20 | import Network.TypedProtocol.Stateful.Peer qualified as TP 21 | 22 | 23 | type Client :: forall ps 24 | -> ps 25 | -> (ps -> Type) 26 | -> (Type -> Type) 27 | -> Type 28 | -> Type 29 | type Client ps st f m a = Peer ps AsClient st f m a 30 | 31 | 32 | -- | Client role pattern for 'TP.Effect'. 33 | -- 34 | pattern Effect :: forall ps st f m a. 35 | m (Client ps st f m a) 36 | -- ^ monadic continuation 37 | -> Client ps st f m a 38 | pattern Effect mclient = TP.Effect mclient 39 | 40 | 41 | -- | Client role pattern for 'TP.Yield' 42 | -- 43 | pattern Yield :: forall ps st f m a. 44 | () 45 | => forall st'. 46 | ( StateTokenI st 47 | , StateTokenI st' 48 | , StateAgency st ~ ClientAgency 49 | ) 50 | => f st 51 | -> f st' 52 | -> Message ps st st' 53 | -- ^ protocol message 54 | -> Client ps st' f m a 55 | -- ^ continuation 56 | -> Client ps st f m a 57 | pattern Yield f f' msg k = TP.Yield ReflClientAgency f f' msg k 58 | 59 | 60 | -- | Client role pattern for 'TP.Await' 61 | -- 62 | pattern Await :: forall ps st f m a. 63 | () 64 | => ( StateTokenI st 65 | , StateAgency st ~ ServerAgency 66 | ) 67 | => (forall st'. 68 | f st 69 | -> Message ps st st' 70 | -> ( Client ps st' f m a 71 | , f st' 72 | ) 73 | ) 74 | -- ^ continuation 75 | -> Client ps st f m a 76 | pattern Await k = TP.Await ReflServerAgency k 77 | 78 | 79 | -- | Client role pattern for 'TP.Done' 80 | -- 81 | pattern Done :: forall ps st f m a. 82 | () 83 | => ( StateTokenI st 84 | , StateAgency st ~ NobodyAgency 85 | ) 86 | => a 87 | -- ^ protocol return value 88 | -> Client ps st f m a 89 | pattern Done a = TP.Done ReflNobodyAgency a 90 | 91 | 92 | {-# COMPLETE Effect, Yield, Await, Done #-} 93 | -------------------------------------------------------------------------------- /typed-protocols/stateful/Network/TypedProtocol/Stateful/Peer/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | -- | Bidirectional patterns for @'Peer' ps 'AsServer'@. The advantage of 4 | -- these patterns is that they automatically provide the 'RelativeAgencyEq' 5 | -- singleton. 6 | -- 7 | module Network.TypedProtocol.Stateful.Peer.Server 8 | ( -- * Server type alias and its pattern synonyms 9 | Server 10 | , pattern Effect 11 | , pattern Yield 12 | , pattern Await 13 | , pattern Done 14 | ) where 15 | 16 | import Data.Kind (Type) 17 | 18 | import Network.TypedProtocol.Core 19 | import Network.TypedProtocol.Stateful.Peer (Peer) 20 | import Network.TypedProtocol.Stateful.Peer qualified as TP 21 | 22 | 23 | type Server :: forall ps 24 | -> ps 25 | -> (ps -> Type) 26 | -> (Type -> Type) 27 | -> Type 28 | -> Type 29 | type Server ps st f m a = Peer ps AsServer st f m a 30 | 31 | 32 | -- | Server role pattern for 'TP.Effect'. 33 | -- 34 | pattern Effect :: forall ps st f m a. 35 | m (Server ps st f m a) 36 | -- ^ monadic continuation 37 | -> Server ps st f m a 38 | pattern Effect mclient = TP.Effect mclient 39 | 40 | 41 | -- | Server role pattern for 'TP.Yield' 42 | -- 43 | pattern Yield :: forall ps st f m a. 44 | () 45 | => forall st'. 46 | ( StateTokenI st 47 | , StateTokenI st' 48 | , StateAgency st ~ ServerAgency 49 | ) 50 | => f st 51 | -> f st' 52 | -> Message ps st st' 53 | -- ^ protocol message 54 | -> Server ps st' f m a 55 | -- ^ continuation 56 | -> Server ps st f m a 57 | pattern Yield f f' msg k = TP.Yield ReflServerAgency f f' msg k 58 | 59 | 60 | -- | Server role pattern for 'TP.Await' 61 | -- 62 | pattern Await :: forall ps st f m a. 63 | () 64 | => ( StateTokenI st 65 | , StateAgency st ~ ClientAgency 66 | ) 67 | => (forall st'. 68 | f st 69 | -> Message ps st st' 70 | -> ( Server ps st' f m a 71 | , f st' 72 | ) 73 | ) 74 | -- ^ continuation 75 | -> Server ps st f m a 76 | pattern Await k = TP.Await ReflClientAgency k 77 | 78 | 79 | -- | Server role pattern for 'TP.Done' 80 | -- 81 | pattern Done :: forall ps st f m a. 82 | () 83 | => ( StateTokenI st 84 | , StateAgency st ~ NobodyAgency 85 | ) 86 | => a 87 | -- ^ protocol return value 88 | -> Server ps st f m a 89 | pattern Done a = TP.Done ReflNobodyAgency a 90 | 91 | {-# COMPLETE Effect, Yield, Await, Done #-} 92 | -------------------------------------------------------------------------------- /typed-protocols/stateful/Network/TypedProtocol/Stateful/Proofs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | -- This is already implied by the -Wall in the .cabal file, but lets just be 4 | -- completely explicit about it too, since we rely on the completeness 5 | -- checking in the cases below for the completeness of our proofs. 6 | {-# OPTIONS_GHC -Wincomplete-patterns #-} 7 | 8 | -- | Proofs about the typed protocol framework. 9 | -- 10 | -- It also provides helpful testing utilities. 11 | -- 12 | module Network.TypedProtocol.Stateful.Proofs 13 | ( connect 14 | , TerminalStates (..) 15 | , removeState 16 | ) where 17 | 18 | import Control.Monad.Class.MonadSTM 19 | 20 | import Data.Kind (Type) 21 | import Data.Singletons 22 | 23 | import Network.TypedProtocol.Core 24 | import Network.TypedProtocol.Peer 25 | import Network.TypedProtocol.Proofs (TerminalStates (..)) 26 | import Network.TypedProtocol.Proofs qualified as TP 27 | import Network.TypedProtocol.Stateful.Peer qualified as ST 28 | 29 | 30 | 31 | -- | Remove state for non-pipelined peers. 32 | -- 33 | -- TODO: There's a difficulty to write `removeState` for pipelined peers which 34 | -- is type safe. The `Peer` doesn't track all pipelined transitions, just the 35 | -- depth of pipelining, so we cannot push `f st` to a queue which type is 36 | -- linked to `Peer`. For a similar reason there's no way to write 37 | -- `forgetPipelined` function. 38 | -- 39 | -- However, this is possible if `Peer` tracks all transitions. 40 | -- 41 | removeState 42 | :: Functor m 43 | => f st 44 | -> ST.Peer ps pr st f m a 45 | -> Peer ps pr NonPipelined st m a 46 | removeState = go 47 | where 48 | go 49 | :: forall ps (pr :: PeerRole) 50 | (st :: ps) 51 | (f :: ps -> Type) 52 | m a. 53 | Functor m 54 | => f st 55 | -> ST.Peer ps pr st f m a 56 | -> Peer ps pr NonPipelined st m a 57 | go f (ST.Effect k) = Effect (go f <$> k) 58 | go _ (ST.Yield refl _f f' msg k) = Yield refl msg (go f' k) 59 | go f (ST.Await refl k) = Await refl $ \msg -> 60 | case k f msg of 61 | (k', f') -> go f' k' 62 | go _ (ST.Done refl a) = Done refl a 63 | 64 | 65 | connect 66 | :: forall ps (pr :: PeerRole) 67 | (st :: ps) 68 | (f :: ps -> Type) 69 | m a b. 70 | (MonadSTM m, SingI pr) 71 | => f st 72 | -> ST.Peer ps pr st f m a 73 | -> ST.Peer ps (FlipAgency pr) st f m b 74 | -> m (a, b, TerminalStates ps) 75 | connect f a b = TP.connect (removeState f a) (removeState f b) 76 | -------------------------------------------------------------------------------- /typed-protocols/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty 4 | 5 | import Network.TypedProtocol.PingPong.Tests qualified as PingPong 6 | import Network.TypedProtocol.ReqResp.Tests qualified as ReqResp 7 | 8 | main :: IO () 9 | main = defaultMain tests 10 | 11 | tests :: TestTree 12 | tests = 13 | testGroup "typed-protocols" 14 | [ PingPong.tests 15 | , ReqResp.tests 16 | ] 17 | 18 | -------------------------------------------------------------------------------- /typed-protocols/typed-protocols.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.4 2 | name: typed-protocols 3 | version: 1.0.0.0 4 | synopsis: A framework for strongly typed protocols 5 | description: A robust session type framework which supports protocol pipelining. 6 | license: Apache-2.0 7 | license-files: 8 | LICENSE 9 | NOTICE 10 | copyright: 2019-2025 Input Output Global Inc (IOG) 11 | author: Alexander Vieth, Duncan Coutts, Marcin Szamotulski 12 | maintainer: alex@well-typed.com, duncan@well-typed.com, marcin.szamotulski@iohk.io 13 | category: Control 14 | build-type: Simple 15 | tested-with: GHC == {9.6, 9.8, 9.10, 9.12} 16 | extra-doc-files: CHANGELOG.md 17 | README.md 18 | 19 | library 20 | exposed-modules: Network.TypedProtocol 21 | , Network.TypedProtocol.Core 22 | , Network.TypedProtocol.Peer 23 | , Network.TypedProtocol.Peer.Client 24 | , Network.TypedProtocol.Peer.Server 25 | , Network.TypedProtocol.Codec 26 | , Network.TypedProtocol.Driver 27 | , Network.TypedProtocol.Proofs 28 | other-modules: Network.TypedProtocol.Lemmas 29 | build-depends: base >=4.12 && <4.22, 30 | io-classes:io-classes ^>= 1.8, 31 | singletons ^>= 3.0 32 | 33 | hs-source-dirs: src 34 | default-language: GHC2021 35 | default-extensions: DataKinds 36 | GADTs 37 | LambdaCase 38 | ghc-options: -Wall 39 | -Wno-unticked-promoted-constructors 40 | -Wcompat 41 | -Wincomplete-uni-patterns 42 | -Wincomplete-record-updates 43 | -Wpartial-fields 44 | -Widentities 45 | -Wredundant-constraints 46 | 47 | library cborg 48 | visibility: public 49 | exposed-modules: Network.TypedProtocol.Codec.CBOR 50 | 51 | build-depends: base, 52 | bytestring >=0.10 && <0.13, 53 | cborg >=0.2.1 && <0.3, 54 | singletons, 55 | primitive, 56 | 57 | io-classes:io-classes, 58 | typed-protocols:typed-protocols 59 | 60 | hs-source-dirs: cborg 61 | default-language: GHC2021 62 | default-extensions: LambdaCase 63 | ghc-options: -Wall 64 | -Wno-unticked-promoted-constructors 65 | -Wcompat 66 | -Wincomplete-uni-patterns 67 | -Wincomplete-record-updates 68 | -Wpartial-fields 69 | -Widentities 70 | -Wredundant-constraints 71 | 72 | library stateful 73 | visibility: public 74 | exposed-modules: Network.TypedProtocol.Stateful.Peer 75 | , Network.TypedProtocol.Stateful.Peer.Client 76 | , Network.TypedProtocol.Stateful.Peer.Server 77 | , Network.TypedProtocol.Stateful.Driver 78 | , Network.TypedProtocol.Stateful.Proofs 79 | , Network.TypedProtocol.Stateful.Codec 80 | build-depends: base, 81 | singletons, 82 | io-classes:io-classes, 83 | typed-protocols:typed-protocols 84 | 85 | hs-source-dirs: stateful 86 | default-language: GHC2021 87 | default-extensions: DataKinds 88 | GADTs 89 | ImportQualifiedPost 90 | ghc-options: -Wall 91 | -Wno-unticked-promoted-constructors 92 | -Wcompat 93 | -Wincomplete-uni-patterns 94 | -Wincomplete-record-updates 95 | -Wpartial-fields 96 | -Widentities 97 | -Wredundant-constraints 98 | 99 | library stateful-cborg 100 | visibility: public 101 | exposed-modules: Network.TypedProtocol.Stateful.Codec.CBOR 102 | 103 | build-depends: base, 104 | bytestring, 105 | cborg, 106 | singletons, 107 | 108 | io-classes:io-classes, 109 | typed-protocols:{typed-protocols,cborg,stateful} 110 | 111 | hs-source-dirs: stateful-cborg 112 | default-language: GHC2021 113 | default-extensions: ImportQualifiedPost 114 | ghc-options: -Wall 115 | -Wno-unticked-promoted-constructors 116 | -Wcompat 117 | -Wincomplete-uni-patterns 118 | -Wincomplete-record-updates 119 | -Wpartial-fields 120 | -Widentities 121 | -Wredundant-constraints 122 | 123 | library examples 124 | visibility: public 125 | exposed-modules: Network.TypedProtocol.Channel 126 | , Network.TypedProtocol.Driver.Simple 127 | 128 | , Network.TypedProtocol.PingPong.Type 129 | , Network.TypedProtocol.PingPong.Client 130 | , Network.TypedProtocol.PingPong.Server 131 | , Network.TypedProtocol.PingPong.Codec 132 | , Network.TypedProtocol.PingPong.Codec.CBOR 133 | , Network.TypedProtocol.PingPong.Examples 134 | 135 | , Network.TypedProtocol.ReqResp.Type 136 | , Network.TypedProtocol.ReqResp.Client 137 | , Network.TypedProtocol.ReqResp.Server 138 | , Network.TypedProtocol.ReqResp.Codec 139 | , Network.TypedProtocol.ReqResp.Codec.CBOR 140 | , Network.TypedProtocol.ReqResp.Examples 141 | 142 | , Network.TypedProtocol.ReqResp2.Type 143 | , Network.TypedProtocol.ReqResp2.Client 144 | 145 | , Network.TypedProtocol.Stateful.ReqResp.Type 146 | , Network.TypedProtocol.Stateful.ReqResp.Client 147 | , Network.TypedProtocol.Stateful.ReqResp.Server 148 | , Network.TypedProtocol.Stateful.ReqResp.Codec 149 | , Network.TypedProtocol.Stateful.ReqResp.Examples 150 | 151 | , Network.TypedProtocol.Trans.Wedge 152 | build-depends: base, 153 | bytestring, 154 | cborg, 155 | serialise, 156 | singletons, 157 | contra-tracer, 158 | io-classes:{io-classes, si-timers}, 159 | network, 160 | time, 161 | typed-protocols:{typed-protocols,cborg,stateful} 162 | 163 | hs-source-dirs: examples 164 | default-language: GHC2021 165 | default-extensions: DataKinds 166 | GADTs 167 | LambdaCase 168 | ghc-options: -Wall 169 | -Wno-unticked-promoted-constructors 170 | -Wcompat 171 | -Wincomplete-uni-patterns 172 | -Wincomplete-record-updates 173 | -Wpartial-fields 174 | -Widentities 175 | -Wredundant-constraints 176 | 177 | test-suite test 178 | type: exitcode-stdio-1.0 179 | main-is: Main.hs 180 | hs-source-dirs: test 181 | default-language: GHC2021 182 | default-extensions: GADTs 183 | LambdaCase 184 | other-modules: Network.TypedProtocol.PingPong.Tests 185 | , Network.TypedProtocol.ReqResp.Tests 186 | build-depends: base 187 | , bytestring 188 | , contra-tracer 189 | , typed-protocols:{typed-protocols,cborg,examples} 190 | , io-classes:{io-classes,si-timers} 191 | , io-sim 192 | , QuickCheck 193 | , tasty 194 | , tasty-quickcheck 195 | 196 | if !os(windows) 197 | build-depends: directory 198 | , network 199 | , unix 200 | 201 | ghc-options: -rtsopts 202 | -Wall 203 | -Wno-unticked-promoted-constructors 204 | -Wno-orphans 205 | --------------------------------------------------------------------------------