├── .dir-locals.el ├── .github ├── CODEOWNERS ├── CONTRIBUTING.md └── workflows │ ├── ci.yaml │ └── release.yaml ├── .gitignore ├── .stylish-haskell.yaml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── app └── Main.hs ├── cabal.project ├── cabal.project.freeze ├── docs ├── Part01SMTesting.md ├── Part02ConcurrentSMTesting.md ├── Part03SMContractTesting.md └── Part04FaultInjection.md ├── images ├── concurrent_counter.svg ├── concurrent_counter_get_1_3.svg ├── concurrent_counter_get_3_3.svg ├── coverage.svg ├── generator.svg ├── part2-history-from-sequence-diagram.svg ├── part2-sequence-diagram.svg ├── part3-sm-model-fake-small.jpg ├── part3-sm-model-fake.svg ├── part3-sm-model-small.jpg ├── part3-sm-model.svg ├── part3-web-service-with-interface-small.jpg ├── part3-web-service-with-interface.svg ├── part3-web-service-with-queue-small.jpg ├── part3-web-service-with-queue.svg ├── part4-invoke-ok-fail-info.svg ├── part4-seq-diagram.svg ├── part4-sm-model-with-fi.svg ├── part5-data-store.svg ├── part5-real-event-loop.excalidraw ├── part5-real-event-loop.svg ├── part5-simulation-event-loop.excalidraw ├── part5-simulation-event-loop.svg ├── regression.svg ├── shrinking-small.jpg ├── shrinking.svg ├── sm-testing-small.jpg ├── sm-testing.svg └── under_construction.gif ├── property-based-testing-stateful-systems-tutorial.cabal ├── shell.nix ├── src ├── Part01SMTesting.lhs ├── Part02ConcurrentSMTesting.lhs ├── Part03 │ ├── Queue.hs │ ├── QueueInterface.hs │ ├── QueueTest.hs │ ├── Service.hs │ └── ServiceTest.hs ├── Part03SMContractTesting.lhs ├── Part04 │ ├── CRC32.hs │ ├── FSFI.hs │ └── LineariseWithFault.hs └── Part04FaultInjection.lhs └── tools ├── generate_changelog.hs └── generate_markdown.sh /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ((haskell-cabal-mode 2 | (eval . 3 | (add-hook 'before-save-hook 4 | (lambda () (haskell-mode-buffer-apply-command "cabal-fmt")) nil t)))) 5 | -------------------------------------------------------------------------------- /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | # These owners will be the default owners for everything in the repo. Unless a 2 | # later match takes precedence, These users will be requested for review when 3 | # someone opens a pull request. 4 | 5 | * @stevana @Danten 6 | -------------------------------------------------------------------------------- /.github/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | ## Before making a change 4 | 5 | * Please open issue before embarking on a big change, in order to avoid 6 | unnecessary or duplicate work. 7 | 8 | ## Before making a pull request 9 | 10 | * We roughly follow the conventional commit message 11 | [format](https://www.conventionalcommits.org/en/v1.0.0/), please have a look 12 | at `git log` and try to mimic along (we make use of the format when generating 13 | the changelog, see "making a new release" below); 14 | 15 | * If the change involves changes to the markdown, then it could be useful to 16 | preview generated HTML with `tools/generate_markdown.sh --preview-html`. Note 17 | that the generated HTML isn't styled, so it won't be looking as nice as once 18 | uploaded to GitHub, but still useful for checking the formatting; 19 | 20 | * Please check the GitHub actions CI configuration in 21 | [`.github/workflows/ci.yaml`](./workflows/ci.yaml) for which steps and checks 22 | are done as part of CI and try to make them part of your development workflow. 23 | The [`act`](https://github.com/nektos/act) tool could be useful for running 24 | all of CI locally as a final check before pushing your branch. 25 | 26 | ## Making a new release 27 | 28 | To create a new release do the following steps: 29 | 30 | ```bash 31 | export NEW_VERSION=X.Y.Z # Try to follow semantic versioning. 32 | 33 | export LAST_VERSION="$(git tag | sort | tail -1)" 34 | ./tools/generate_changelog.hs "${LAST_VERSION}" | \ 35 | sed "s/\[HEAD\]/\[v${NEW_VERSION}\]/" | \ 36 | sed "s/\.\.\.HEAD/...v${NEW_VERSION}/" > /tmp/NEW_CHANGELOG.md 37 | cat CHANGELOG.md >> /tmp/NEW_CHANGELOG.md 38 | mv /tmp/NEW_CHANGELOG.md CHANGELOG.md 39 | 40 | git diff # Check that everything looks alright. 41 | git checkout -b update-changelog-"${NEW_VERSION}" 42 | git add CHANGELOG.md 43 | git commit -m "docs: update changelog for release v${NEW_VERSION}" 44 | gh pr create # Or `git push` and create a PR via the web UI. 45 | 46 | # Merge the PR. 47 | 48 | git checkout main 49 | git pull 50 | git branch -d update-changelog-"${NEW_VERSION}" 51 | 52 | git tag -a "v${NEW_VERSION}" -m "tag: v${NEW_VERSION}" 53 | git push origin "v${NEW_VERSION}" 54 | ``` 55 | 56 | Upon pushing the tag the 57 | [`.github/workflows/release.yaml`](./workflows/release.yaml) workflow will kick 58 | off and upload the build artifacts to the releases page. 59 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | # Based on https://kodimensional.dev/github-actions 2 | 3 | name: CI 4 | 5 | on: 6 | workflow_dispatch: 7 | pull_request: 8 | types: [synchronize, opened, reopened] 9 | push: 10 | branches: [main] 11 | schedule: 12 | # Additionally run once per week (At 00:00 on Sunday) to maintain cache. 13 | - cron: '0 0 * * 0' 14 | 15 | jobs: 16 | cabal: 17 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 18 | runs-on: ${{ matrix.os }} 19 | strategy: 20 | matrix: 21 | os: [ubuntu-latest] 22 | cabal: ["3.6.2.0"] 23 | ghc: 24 | - "9.0.2" 25 | 26 | steps: 27 | - uses: actions/checkout@v3 28 | 29 | - uses: haskell/actions/setup@v2 30 | id: setup-haskell-cabal 31 | name: Setup Haskell 32 | with: 33 | ghc-version: ${{ matrix.ghc }} 34 | cabal-version: ${{ matrix.cabal }} 35 | 36 | - name: Configure 37 | run: | 38 | cabal configure --enable-tests --enable-benchmarks \ 39 | --test-show-details=direct --write-ghc-environment-files=always 40 | 41 | - uses: actions/cache@v3 42 | name: Cache ~/.cabal/store 43 | with: 44 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 45 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 46 | 47 | - name: Install dependencies 48 | run: | 49 | cabal build all --only-dependencies 50 | 51 | - name: Build 52 | run: | 53 | cabal build all 54 | 55 | - name: Test 56 | run: | 57 | cabal test all 58 | -------------------------------------------------------------------------------- /.github/workflows/release.yaml: -------------------------------------------------------------------------------- 1 | # Based on https://vrom911.github.io/blog/github-actions-releases 2 | # See also: https://teddit.net/r/haskell/comments/yngcnu/anyone_have_an_uptodate_github_action_config_that/ 3 | 4 | name: Release 5 | 6 | on: 7 | # Trigger the workflow on the new 'v*' tag created. 8 | push: 9 | tags: 10 | - "v*" 11 | 12 | jobs: 13 | create_release: 14 | name: Create Github release 15 | runs-on: ubuntu-latest 16 | steps: 17 | - name: Check out code 18 | uses: actions/checkout@v3 19 | 20 | - name: Create release 21 | id: create_release 22 | uses: actions/create-release@v1.1.4 23 | env: 24 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 25 | with: 26 | tag_name: ${{ github.ref }} 27 | release_name: Release ${{ github.ref }} 28 | draft: true 29 | prerelease: false 30 | 31 | build_artifact: 32 | needs: [create_release] 33 | name: ${{ matrix.os }}/GHC ${{ matrix.ghc }}/${{ github.ref }} 34 | runs-on: ${{ matrix.os }} 35 | strategy: 36 | matrix: 37 | os: [ubuntu-latest, macos-latest] 38 | ghc: 39 | - "9.0.2" 40 | cabal: ["3.6.2.0"] 41 | 42 | steps: 43 | - name: Check out code 44 | uses: actions/checkout@v3 45 | 46 | - name: Set tag name 47 | uses: olegtarasov/get-tag@v2.1.2 48 | id: tag 49 | with: 50 | tagRegex: "v(.*)" 51 | 52 | - name: Setup Haskell 53 | uses: haskell/actions/setup@v2.0.1 54 | id: setup-haskell-cabal 55 | with: 56 | ghc-version: ${{ matrix.ghc }} 57 | cabal-version: ${{ matrix.cabal }} 58 | 59 | - name: Cache ~/.cabal/store 60 | uses: actions/cache@v3.0.11 61 | with: 62 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 63 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 64 | 65 | - name: Build binary 66 | run: | 67 | mkdir dist 68 | cabal install exe:part5 --install-method=copy --overwrite-policy=always --installdir=dist 69 | mv dist/part5 part5-${{ steps.tag.outputs.tag }}-${{ runner.os }}-ghc-${{ matrix.ghc }} 70 | 71 | # - name: Upload release asset 72 | # uses: softprops/action-gh-release@v1 73 | # with: 74 | # files: part5-${{ steps.tag.outputs.tag }}-${{ runner.os }}-ghc-${{ matrix.ghc }} 75 | # env: 76 | # GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 77 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | cabal.project.local* 3 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - imports: 3 | align: none 4 | list_align: with_module_name 5 | pad_module_names: false 6 | long_list_align: new_line_multiline 7 | empty_list_align: inherit 8 | list_padding: 7 # length "import " 9 | separate_lists: false 10 | space_surround: false 11 | - language_pragmas: 12 | style: vertical 13 | align: false 14 | remove_redundant: true 15 | - simple_align: 16 | cases: false 17 | top_level_patterns: false 18 | records: false 19 | - trailing_whitespace: {} 20 | 21 | # You need to put any language extensions that's enabled for the entire project 22 | # here. 23 | language_extensions: [] 24 | 25 | columns: 72 26 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Symbiont Inc; 2023 Stevan Andjelkovic, Daniel Gustafsson. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a 6 | copy of this software and associated documentation files (the 7 | "Software"), to deal in the Software without restriction, including 8 | without limitation the rights to use, copy, modify, merge, publish, 9 | distribute, sublicense, and/or sell copies of the Software, and to 10 | permit persons to whom the Software is furnished to do so, subject to 11 | the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included 14 | in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 17 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 20 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 21 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 22 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Property-based testing stateful systems: a tutorial 2 | ================================================================ 3 | 4 | [![GitHub 5 | CI](https://github.com/stevana/property-based-testing-stateful-systems-tutorial/workflows/CI/badge.svg)](https://github.com/stevana/property-based-testing-stateful-systems-tutorial/actions) 6 | [![Hackage](https://img.shields.io/hackage/v/property-based-testing-stateful-systems-tutorial.svg)](https://hackage.haskell.org/package/property-based-testing-stateful-systems-tutorial) 7 | 8 | Property-based testing (PBT), i.e. generating random inputs and checking some 9 | property of the output, of pure programs is an established practice by now. It's 10 | taught in introductory university classes and it's part of test suites in 11 | industry. 12 | 13 | Most real world programs are not pure though, they are stateful. While it's 14 | often possible to structure your program in such a way that the impure stuff is 15 | done in `main`, e.g. read the contents of a file, and then passed on to a pure 16 | function, e.g. a parser, it's not always possible. Consider a long-running 17 | program that interacts with the filesystem and with other programs over the 18 | network, e.g. some kind of web service or a distributed database. It's difficult 19 | to split such a program up into doing a little bit of impure stuff at the start, 20 | then hand it over to a pure function (which we can apply PBT on). 21 | 22 | Given this it's perhaps a bit surprising that there are relatively few resources 23 | about applying PBT to stateful systems. This repository is an attempt to close 24 | that gap and try to make PBT stateful systems more common. 25 | 26 | The goals we'd like to achieve are: 27 | 28 | - Show how to test stateful (i.e. impure/monadic) programs using 29 | property-based testing; 30 | 31 | - Show how we can do concurrent testing to help uncover problems such as race 32 | conditions; 33 | 34 | - Show how we can build bigger systems in a modular way by applying the 35 | property-based testing equivalent of integration and contract tests; 36 | 37 | - Show how to use fault injection and so called simulation testing to 38 | "end-to-end" test distributed systems; 39 | 40 | - Introduce the reader to related work and open problems in the area along the 41 | way. 42 | 43 | In the interest of brevity, we assume that the reader already has: 44 | 45 | - Enough familiarity with Haskell to be able to read simple programs, for 46 | example if you can follow along in the *Learn You a Haskell for Great Good!* 47 | [tutorial](http://learnyouahaskell.com/chapters), then you should be fine; 48 | 49 | - Some experience with property-based testing of non-stateful (i.e. pure) 50 | programs. For example as explained in the official QuickCheck 51 | [manual](http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html) or in the 52 | following 53 | [tutorial](https://begriffs.com/posts/2017-01-14-design-use-quickcheck.html); 54 | 55 | - Basic knowledge of state machines (i.e. 56 | [Mealy](https://en.wikipedia.org/wiki/Mealy_machine) / [Moore 57 | machines](https://en.wikipedia.org/wiki/Moore_machine) and 58 | [transducers](https://en.wikipedia.org/wiki/Finite-state_transducer)). 59 | 60 | Other than that this tutorial is striving to be as self-contained as possibly as 61 | well as accessible to non-Haskell programmers. 62 | 63 | Structure 64 | --------- 65 | 66 | The tutorial is split up into five parts (so far), and each part has the 67 | following structure: 68 | 69 | - Motivation: explains why we are doing what we are about to do; 70 | - Plan: how we will do it; 71 | - Code: a concrete implementation of the idea (in case you get stuck when trying 72 | to implement it yourself); 73 | - Discussion: common questions or objections; 74 | - Exercises: things the authors were to lazy to do, but they know how to; 75 | - Problems: things the authors don't know how to do (yet); 76 | - See also: links to further reading about the topic or related topics; 77 | - Summary: the most important take away. 78 | 79 | The parts build upon each other. We start by modelling and testing a simple 80 | counter using a state machine in part 1, we then reuse the same state machine 81 | model to test the counter for thread-safety using linearisability in part 2. In 82 | part 3 we will implement a queue and a web service that uses said queue, the 83 | state machine model for the queue and the real implementation of the queue will 84 | be contract tested to ensure that the model is faithful to the implementation, 85 | subsequently while testing the web service we will use the model in place of the 86 | real queue. In part 4 we introduce fault injection to the queue allowing us to 87 | test how the web service performs when its dependency fails. Finally, in part 5, 88 | we combine all the above ideas in what, sometimes is called simulation testing, 89 | to test a distributed system that uses replicated state machines. 90 | 91 | Table of contents 92 | ----------------- 93 | 94 | 1. [State machine testing](./docs/Part01SMTesting.md#readme) 95 | 2. [Concurrent state machine testing with 96 | linearisability](./docs/Part02ConcurrentSMTesting.md#readme) 97 | 3. [Integration tests against state machine fakes and consumer-driven contract 98 | tests for the fakes](./docs/Part03SMContractTesting.md#readme) 99 | 4. [Fault-injection](./docs/Part04FaultInjection.md#readme) 100 | 5. Simulation testing 101 | 102 | Usage 103 | ----- 104 | 105 | This repository contains literate Haskell code in `src`. If you want to interact 106 | with it, install [`ghcup`](https://www.haskell.org/ghcup/install/) and then type 107 | `cabal repl`. Alternatively, if you are using the 108 | [`nix`](https://nixos.org/download.html) package manager, then running 109 | `nix-shell` in the root directory should give you the right `ghc` version and 110 | all other dependencies you might need. 111 | 112 | The literate code is transformed into markdown using 113 | [`pandoc`](https://pandoc.org/) in 114 | [`tools/generate_markdown.sh`](./tools/generate_markdown.sh) and the markdown is 115 | put inside the [`docs`](./docs) directory for easier browsing. 116 | 117 | The following is a link to the [first part](./docs/Part01SMTesting.md#readme) of the 118 | generate markdown, at the end it will link to the second part and so on. Or you 119 | can use the table of contents above or the `docs` directory to jump to desired 120 | part straight away. 121 | 122 | Contributing 123 | ------------ 124 | 125 | Any feedback, suggestions for improvement or questions are most welcome via the 126 | issue tracker! 127 | 128 | See the [`CONTRIBUTING.md`](./.github/CONTRIBUTING.md) file for more detailed 129 | guidelines regarding contributing. 130 | 131 | License 132 | ------- 133 | 134 | See the [`LICENSE`](./LICENSE) file. 135 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Part05.LibMain (libMain) 4 | 5 | main :: IO () 6 | main = libMain 7 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | with-compiler: ghc-9.0.2 4 | 5 | reject-unconstrained-dependencies: all 6 | 7 | constraints: QuickCheck +old-random 8 | 9 | package property-based-testing-stateful-systems-tutorial 10 | 11 | allow-older: * 12 | allow-newer: * 13 | -------------------------------------------------------------------------------- /docs/Part03SMContractTesting.md: -------------------------------------------------------------------------------- 1 | # Integration tests against state machine fakes and consumer-driven contract tests for the fakes 2 | 3 | ## Motivation 4 | 5 | So far we have seen how to test a single component sequentially ([part 1](./Part01SMTesting.md#readme)) and concurrently ([part 2](./Part02ConcurrentSMTesting.md#readme)). Most systems are composed of several components however, and the global correctness of the composed system doesn’t follow from the local correctness of its components, a typical problem being that the two components that are meant to talk to each other make wrong assumptions about each other’s API. 6 | 7 | The usual solution to this problem is to add so called integration tests which deploy both components and perform some kind of interaction that exercises the API between the components to ensure that the assumptions are correct. Whenever some component needs to be deployed it will slow down the test and most likely introduce some flakiness related to deployment, e.g. some port is in use already, or not yet available to be used, or docker registry is temporarily down, or some other http request that is involved during deployment fails, etc. 8 | 9 | In order to avoid having slow and flaky integration tests, the standard solution is to mock out all the dependencies of the software under test (SUT). This works, however it introduces a new problem: what if the mocks are incorrect (i.e. they encode the same false assumptions of the consumed API). A solution to this problem is to write so called (consumer-driven) contract tests which verify that the mock is faithful to the real component. Unfortunately this solution doesn’t seem to be standard in our industry. Mocks are fairly common, but contract tests not so much so. This has led to mocks sometimes being called useless, because people have been bitten by mocks being wrong (because they didn’t have contract tests). 10 | 11 | In our case, since we got an executable state machine model, we effectively already got something that is better than a mock: a fake. Furthermore we have already seen how to ensure that such a state machine model is faithful to the real component, i.e. we already know how to do contract tests. So in this part we will merely make these things more explicit and glue them together to get fast and deterministic integration tests. 12 | 13 | ## Plan 14 | 15 | Imagine our system consists of two components: *A* and *B*, where *A* depends on *B*. We then proceed as follows: 16 | 17 | 1. Following the pattern from part 1 and 2: make a state machine (SM) model of the dependency *B*, use SM testing to ensure that the model is faithful to the real implementation of *B* (these tests are our contract tests); 18 | 19 | 2. Turn the SM model of *B* into a fake and use it in-place of the real implementation of *B* inside the real implementation of *A*; 20 | 21 | 3. Repeat the first step for component *A*. Note that while testing *A* we will not be using the real component *B* but rather a fake of it, this gives us possibly faster and more deterministic integration tests. 22 | 23 | ## How it works 24 | 25 | The SUT of the day is a web service which queues up client requests and has a worker that processes the queue and replies to the clients. 26 | 27 | 28 | 29 | Imagine if this queue is a separate process. This makes it a bit annoying to test because we need to deploy the queue first, make sure it’s ready for work before we start testing the web service. 30 | 31 | One way around the above problem is to implement the web service against an *interface* of the queue rather than the queue itself. We can then implement this interface using the real queue but also a fake queue which lives in the same process as the web service hence avoiding deploying the queue before testing. Depending if we deploy the web service in “production” or for “testing” we choose the between the two implementations of the interface. 32 | 33 | 34 | 35 | The problem of this approach is: how do we know that the fake queue is faithful to the real queue implementation? We would need to test this somehow! (These tests are usually called contract tests.) 36 | 37 | Let’s take a step back and recall what we are doing when we are state machine testing. We ensure that the state machine model is faithful to the SUT. 38 | 39 | 40 | 41 | Assuming we have a state machine model of the queue which we know is faithful to the real queue, is there a way to turn this model into a fake and hence solve our problem? 42 | 43 | Yes! It’s quite simple, merely create a wrapper around the state machine model which has a variable with the current state. Initialise this current state with the initial model, and every time we get an input, read the state, apply the state machine function, update the state variable. 44 | 45 | (Note that the model isn’t a fake because it doesn’t have the same in- and outputs – that’s what the wrapper fixes.) 46 | 47 | 48 | 49 | Let’s zoom out a bit and contemplate the general picture. Our queue can be thought of as a producer of the interface, while the web service is consumer of it. 50 | 51 | Interface 52 | | 53 | Consumer | Producer 54 | | 55 | ----------> x--------> 56 | | 57 | Integration | Contract tests 58 | tests | 59 | 60 | When we integration test our web service against the fake queue we are doing, what is sometimes called, “collaboration tests”, while when we are ensuring that the fake queue is faithful to the real queue we are doing contract tests. 61 | 62 | The above relations between consumers and producers of interfaces can be generalised from one-to-one relations, as in the web service and queue example, to many-to-many relations and we can also nest them, i.e. a producer can in turn be a consumer. The kind of testing we’ve talked about generalised to these contexts as well and done in “layers”, starting with the bottom layer and going up. 63 | 64 | Almost done! We’ve seen that the job of contract tests are to ensure the accuracy of the fakes you use of other components in your fast and deterministic integration tests. We use the term *consumer-driven* contract tests if the consumer of the faked API writes the contract test inside the test-suite of the producer. 65 | 66 | For example, if component *A* and *B* are developed in different repos or by different teams, then the consumer of the API (in our case *A* consumes *B*’s API) should write the contract test (hence *consumer-driven*). 67 | 68 | That way: 69 | 70 | 1. the fake of the consumed API is more to encode the assumptions that the consumer makes; 71 | 72 | 2. if the implementation of the consumed API changes in a way that break the contract test that ensures that the fake is faithfully with regards to the real implementation, then the developers of the consumed API will get a failing test and thus a warning about the fact that some assumptions of the consumer might have been broken. 73 | 74 | So with other words, consumer-driven is just a policy about who writes which contract tests and where those tests are supposed to live, and by following this policy we are more likely to catch if a producer of an API makes a change that will break the interaction between the consumer and the producer. 75 | 76 | ## Code 77 | 78 | 83 | 84 | In order to save space we won’t include all code here, but rather link to the relevant modules. 85 | 86 | Let’s start with our dependency, the [queue](../src/Part03/Queue.hs): 87 | 88 | ``` haskell 89 | import Part03.Queue () 90 | ``` 91 | 92 | The queue is [tested](../src/Part03/QueueTest.hs) using a state machine model like we did in part 1 och 2: 93 | 94 | ``` haskell 95 | import Part03.QueueTest () 96 | ``` 97 | 98 | So far nothing new, except for terminology: because the state machine model will later become our fake, we call the tests that check that the model is faithful to the real queue: *contract tests*. 99 | 100 | Next lets have a look at the web services which depends on the queue. In order for us to be able to swap between the fake and the real queue implementation we first specify a queue [interface](../src/Part03/QueueInterface.hs): 101 | 102 | ``` haskell 103 | import Part03.QueueInterface () 104 | ``` 105 | 106 | Our [web service](../src/Part03/Service.hs) is implemented against the interface: 107 | 108 | ``` haskell 109 | import Part03.Service () 110 | ``` 111 | 112 | Notice how simple it’s to implement a fake queue from the state machine model (we only need a mutable variable, this is the wrapper we talked about above in the “how it works” section). Also notice that in, e.g., `main` we can select which implementation we want because the web service is written against the interface. 113 | 114 | When we [integration test](../src/Part03/ServiceTest.hs) the web service with the queue, we always use the fake queue for speed and determinism: 115 | 116 | ``` haskell 117 | import Part03.ServiceTest () 118 | ``` 119 | 120 | Because we’ve made sure that the fake queue is faithful to the real queue so we can be reasonably sure that when we use the real queue in a “production” deployment the system will behave the same as it did in the tests with the fake queue. 121 | 122 | ## Discussion 123 | 124 | Why not just spin up the real component B when testing component A? 125 | 126 | - Imagine B is a queue and the real implementation uses Kafka, then we’d need to start several processes… 127 | 128 | - Sometimes component B is slow to use (uses disk or network I/O)… 129 | 130 | - Sometimes component B is a third-party component which we can’t redeploy or reset between test runs… 131 | 132 | - Often we want to be resilient at the level of component A in case component B fails, injecting faults in B to test this is much easier on a fake of B rather than on the real implementation of B (more on this in the next part). 133 | 134 | - Basically this is how the road towards slow and flaky tests starts. Don’t go down that path! If you are thinking: “but some code is only exercised when the real component is deployed, e.g. configuration”, then use [smoke tests](https://en.wikipedia.org/wiki/Smoke_testing_%28software%29) rather than integration tests with real components. 135 | 136 | Origin of the terminology: “The phrase smoke test comes from electronic hardware testing. You plug in a new board and turn on the power. If you see smoke coming from the board, turn off the power. You don’t have to do any more testing.” 137 | 138 | The software analogue: spin up component(s), wait for their status to become “ready”, make some basic requests and see if they succeed. 139 | 140 | Acceptable if these are a bit flaky: 141 | 142 | - Component spin up happens relatively rarely in production 143 | - These tests will likely involve docker containers and networking, i.e. third-party infrastructure that sometimes is flaky 144 | 145 | “After code reviews, smoke testing is the most cost effective method for identifying and fixing defects in software.” – [Microsoft](https://docs.microsoft.com/en-us/previous-versions/ms182613(v=vs.80)) 146 | 147 | For most software systems, between good contract tests and smoke tests there shouldn’t be much of a gap for bugs to sneak in. For special cases, such as distributed systems, we will cover more comprehensive techniques in part 5. 148 | 149 | ## Exercises 150 | 151 | 0. The fake/model of the queue is thread-safe, but the real implementation isn’t! Fix that and do concurrent contract testing. 152 | 153 | 1. Introduce an interface for all database interaction, move the current database implementation to `realDb` and introduce fake database instance of the interface. 154 | 155 | 2. Write contract tests that ensure that the fake database faithfully represents the real one. 156 | 157 | 3. Once the contract tests pass, switch out the real database for the fake one in the integration tests (the test-suite of the web service). Enable timing output in `ghci` with `:set +s`, crank up the number of tests that `QuickCheck` generates, and see if you notice any speed up in the test execution time. 158 | 159 | 4. Think of corner cases for the queue you’d write unit tests for, but instead add those cases to the coverage checker to ensure that the generator generates them. 160 | 161 | ## See also 162 | 163 | - For the difference between a fake and e.g. a mock see the following [article](https://www.martinfowler.com/bliki/TestDouble.html) by Martin Fowler; 164 | 165 | - For more on contract testing see this [article](https://martinfowler.com/bliki/ContractTest.html) and for more on their consumer-driven variant see the following [article](https://martinfowler.com/articles/consumerDrivenContracts.html); 166 | 167 | - [*Integrated Tests Are A Scam*](https://www.youtube.com/watch?v=fhFa4tkFUFw) talk by J.B. Rainsberger (2022), this a less ranty version of a talk with the same title that he [gave](https://www.youtube.com/watch?v=VDfX44fZoMc) at DevConFu in 2013; 168 | 169 | - [*Consumer-Driven Contracts Done Right*](https://github.com/aleryo/homomorphic-event-sourcing/) talk by Arnaud Bailly and Nicole Rauch (2018). 170 | 171 | ## Summary 172 | 173 | - State machine testing a component using a model gives us a faithful fake for that component for free; 174 | 175 | - Using fakes enables to fast and deterministic integration tests and, as we shall see next, makes it easier to introduce faults when testing; 176 | 177 | - Contract tests justify the use of fakes, in-place of the real dependencies, when integration testing the SUT. 178 | 179 | ## Next up 180 | 181 | In [part 4](./Part04FaultInjection.md#readme) we will look at how we can test some “unhappy paths” of the SUT by injecting faults into our fakes. 182 | -------------------------------------------------------------------------------- /images/concurrent_counter.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | thread 1:thread 2:thread 3:incr 1getincr 2gettime -------------------------------------------------------------------------------- /images/concurrent_counter_get_1_3.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | thread 1:thread 2:thread 3:incr 1getincr 2gettime -------------------------------------------------------------------------------- /images/concurrent_counter_get_3_3.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | thread 1:thread 2:thread 3:incr 1getincr 2gettime -------------------------------------------------------------------------------- /images/coverage.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | ... -------------------------------------------------------------------------------- /images/generator.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | Generator<input₀, input₁, ..., inputₙ> SeedMaxlength -------------------------------------------------------------------------------- /images/part2-sequence-diagram.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | thread 1thread 2thread 3Countertimeincr 1incr 2getget -------------------------------------------------------------------------------- /images/part3-sm-model-fake-small.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stevana/property-based-testing-stateful-systems-tutorial/65fbef07c33c12bab8a857080eadbcc31b1116cc/images/part3-sm-model-fake-small.jpg -------------------------------------------------------------------------------- /images/part3-sm-model-fake.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | SM model fakeSM modelstateinputoutput -------------------------------------------------------------------------------- /images/part3-sm-model-small.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stevana/property-based-testing-stateful-systems-tutorial/65fbef07c33c12bab8a857080eadbcc31b1116cc/images/part3-sm-model-small.jpg -------------------------------------------------------------------------------- /images/part3-sm-model.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | SUTSM modelinputoutputinputstateoutputstate -------------------------------------------------------------------------------- /images/part3-web-service-with-interface-small.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stevana/property-based-testing-stateful-systems-tutorial/65fbef07c33c12bab8a857080eadbcc31b1116cc/images/part3-web-service-with-interface-small.jpg -------------------------------------------------------------------------------- /images/part3-web-service-with-queue-small.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stevana/property-based-testing-stateful-systems-tutorial/65fbef07c33c12bab8a857080eadbcc31b1116cc/images/part3-web-service-with-queue-small.jpg -------------------------------------------------------------------------------- /images/part3-web-service-with-queue.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | Web serviceRequestQueue (FIFO)WorkerResponse -------------------------------------------------------------------------------- /images/part4-invoke-ok-fail-info.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | timethread 1:thread 2:thread 3:invokeokinvokefailinvokeinfo -------------------------------------------------------------------------------- /images/part4-seq-diagram.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | timeclientserverrequest 1400bad requestrequest 2response 2 gets droppedtimeoutserver state updatedrequest 3 gets droppedtimeoutserver state unchanged -------------------------------------------------------------------------------- /images/regression.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | ...s₀s₁s₂s₃i₀i₁i₂ -------------------------------------------------------------------------------- /images/shrinking-small.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stevana/property-based-testing-stateful-systems-tutorial/65fbef07c33c12bab8a857080eadbcc31b1116cc/images/shrinking-small.jpg -------------------------------------------------------------------------------- /images/shrinking.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 15 | 16 | < i₀, i₁, i₂, i₃ >< i₀, i₁ >< i₂, i₃ >< i₁ >< i₀ >< i₃ >< i₂ >< i₀, i₁, i₂ >< i₀, i₁ >< i₁ >< i₀ >< i₀, i₂ >< i₁, i₂ >< i₀ >< i₂ >< i₁ >< i₂ >... -------------------------------------------------------------------------------- /images/sm-testing-small.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stevana/property-based-testing-stateful-systems-tutorial/65fbef07c33c12bab8a857080eadbcc31b1116cc/images/sm-testing-small.jpg -------------------------------------------------------------------------------- /images/under_construction.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stevana/property-based-testing-stateful-systems-tutorial/65fbef07c33c12bab8a857080eadbcc31b1116cc/images/under_construction.gif -------------------------------------------------------------------------------- /property-based-testing-stateful-systems-tutorial.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: property-based-testing-stateful-systems-tutorial 3 | version: 0.0.0 4 | synopsis: 5 | A tutorial about how to apply property-based testing to stateful systems. 6 | 7 | description: 8 | See README at 9 | 10 | homepage: 11 | https://github.com/stevana/property-based-testing-stateful-systems-tutorial#readme 12 | 13 | bug-reports: 14 | https://github.com/stevana/property-based-testing-stateful-systems-tutorial/issues 15 | 16 | license: MIT 17 | license-file: LICENSE 18 | author: Stevan Andjelkovic and Daniel Gustafsson 19 | maintainer: stevana@users.noreply.github.com 20 | copyright: Copyright (c) 2022 Symbiont Inc; 2023 Stevan Andjelkovic, Daniel Gustafsson. 21 | category: Testing 22 | extra-source-files: 23 | CHANGELOG.md 24 | LICENSE 25 | README.md 26 | 27 | tested-with: GHC ==9.0.2 28 | 29 | library 30 | build-depends: base ==4.15.1.0 31 | hs-source-dirs: src 32 | 33 | -- GHC boot library dependencies: 34 | -- (https://gitlab.haskell.org/ghc/ghc/-/blob/master/packages) 35 | build-depends: 36 | , bytestring 37 | , containers 38 | , directory 39 | , stm 40 | , text 41 | -- , time 42 | -- , transformers 43 | , unix 44 | 45 | -- Other dependencies: 46 | build-depends: 47 | -- , aeson 48 | , async 49 | -- , heaps 50 | , http-client 51 | , http-types 52 | , HUnit 53 | -- , microlens-platform 54 | , QuickCheck 55 | , random 56 | , sqlite-simple 57 | -- , tree-diff ==0.0.2.1 58 | , vector 59 | , wai 60 | , warp 61 | 62 | exposed-modules: 63 | Part01SMTesting 64 | Part02ConcurrentSMTesting 65 | Part03.Queue 66 | Part03.QueueInterface 67 | Part03.QueueTest 68 | Part03.Service 69 | Part03.ServiceTest 70 | Part03SMContractTesting 71 | Part04.CRC32 72 | Part04.FSFI 73 | Part04.LineariseWithFault 74 | Part04FaultInjection 75 | -- Part05.Agenda 76 | -- Part05.AwaitingClients 77 | -- Part05.ClientGenerator 78 | -- Part05.Codec 79 | -- Part05.Configuration 80 | -- Part05.Debug 81 | -- Part05.Deployment 82 | -- Part05.ErrorReporter 83 | -- Part05.Event 84 | -- Part05.EventLoop 85 | -- Part05.EventQueue 86 | -- Part05.History 87 | -- Part05.LibMain 88 | -- Part05.Network 89 | -- Part05.Options 90 | -- Part05.Random 91 | -- Part05.StateMachine 92 | -- Part05.StateMachineDSL 93 | -- Part05.Time 94 | -- Part05.TimerWheel 95 | -- Part05.ViewstampReplication.Machine 96 | -- Part05.ViewstampReplication.Message 97 | -- Part05.ViewstampReplication.State 98 | -- Part05.ViewstampReplication.Test.ClientGenerator 99 | -- Part05.ViewstampReplication.Test.Model 100 | -- Part05SimulationTesting 101 | 102 | default-language: Haskell2010 103 | ghc-options: 104 | -Wall -Wcompat -Widentities -Wincomplete-uni-patterns 105 | -Wincomplete-record-updates -Wredundant-constraints 106 | -Wnoncanonical-monad-instances -Wmissing-export-lists 107 | -Wpartial-fields -Wmissing-deriving-strategies -fhide-source-paths 108 | -Wunused-packages 109 | 110 | if impl(ghc >=9.0) 111 | ghc-options: 112 | -Winvalid-haddock -Wunicode-bidirectional-format-characters 113 | -Werror=unicode-bidirectional-format-characters 114 | 115 | if impl(ghc >=9.2) 116 | ghc-options: 117 | -Wredundant-bang-patterns -Woperator-whitespace -Wimplicit-lift 118 | 119 | if impl(ghc >=9.4) 120 | ghc-options: -Wredundant-strictness-flags 121 | 122 | source-repository head 123 | type: git 124 | location: 125 | https://github.com/stevana/property-based-testing-stateful-systems-tutorial 126 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | pkgs = import (builtins.fetchTarball { 3 | url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/22.05.tar.gz"; 4 | sha256 = "0d643wp3l77hv2pmg2fi7vyxn4rwy0iyr8djcw1h5x72315ck9ik"; 5 | }) {}; 6 | in 7 | with pkgs; 8 | 9 | mkShell rec { 10 | buildInputs = [ 11 | act 12 | cabal-install 13 | haskell.compiler.ghc902 14 | haskellPackages.cabal-fmt 15 | haskellPackages.ormolu 16 | haskellPackages.tasty-discover 17 | hlint 18 | gmp 19 | pandoc 20 | pkgconfig 21 | stylish-haskell 22 | zlib 23 | ]; 24 | 25 | # Ensure that libz.so and other libraries are available to TH splices, cabal 26 | # repl, etc. 27 | LD_LIBRARY_PATH = lib.makeLibraryPath buildInputs; 28 | } 29 | -------------------------------------------------------------------------------- /src/Part03/Queue.hs: -------------------------------------------------------------------------------- 1 | module Part03.Queue (module Part03.Queue) where 2 | 3 | import Control.Monad 4 | import Data.IORef 5 | import qualified Data.Vector.Mutable as Vec 6 | 7 | ------------------------------------------------------------------------ 8 | 9 | -- In order to make the queue more performant and more tricky for ourselves to 10 | -- implement, we'll make it array-backed where elements are not removed from the 11 | -- array when they are dequeued, but rather overwritten by a later enqueue 12 | -- operation. 13 | 14 | -- In order to pull this off we'll keep track of the total capacity of the 15 | -- queue, the current size and what the "rear" of the queue is, i.e. the index 16 | -- which we should dequeue next. 17 | 18 | data Queue a = Queue 19 | { qCapacity :: !Int 20 | , qSize :: !(IORef Int) 21 | , qRear :: !(IORef Int) 22 | , qQueue :: !(Vec.IOVector a) 23 | } 24 | 25 | newQueue :: Int -> IO (Queue a) 26 | newQueue cap = Queue <$> pure cap <*> newIORef 0 <*> newIORef 0 <*> Vec.new cap 27 | 28 | capacity :: Queue a -> Int 29 | capacity = qCapacity 30 | 31 | size :: Queue a -> IO Int 32 | size = readIORef . qSize 33 | 34 | -- XXX: Don't export. 35 | rear :: Queue a -> IO Int 36 | rear = readIORef . qRear 37 | 38 | clear :: Queue a -> IO () 39 | clear q = do 40 | writeIORef (qSize q) 0 41 | writeIORef (qRear q) 0 42 | Vec.clear (qQueue q) 43 | 44 | isEmpty :: Queue a -> IO Bool 45 | isEmpty q = do 46 | sz <- size q 47 | return (sz == 0) 48 | 49 | enqueue :: Queue a -> a -> IO Bool 50 | enqueue q x = do 51 | n <- size q 52 | if n >= capacity q 53 | then return False 54 | else do 55 | j <- rear q 56 | Vec.unsafeWrite (qQueue q) ((j + n) `mod` capacity q) x 57 | modifyIORef' (qSize q) succ 58 | return True 59 | 60 | dequeue :: Queue a -> IO (Maybe a) 61 | dequeue q = do 62 | empty <- isEmpty q 63 | if empty 64 | then return Nothing 65 | else do 66 | j <- rear q 67 | x <- Vec.unsafeRead (qQueue q) j 68 | modifyIORef' (qSize q) (\sz -> sz - 1) 69 | modifyIORef' (qRear q) (\j' -> (j' + 1) `mod` capacity q) 70 | return (Just x) 71 | 72 | -- We add a display function for debugging. 73 | 74 | display :: Show a => Queue a -> IO () 75 | display q = do 76 | putStrLn "Queue" 77 | putStr " { capacity = " 78 | putStrLn (show (capacity q)) 79 | putStr " , size = " 80 | sz <- size q 81 | putStrLn (show sz) 82 | putStr " , rear = " 83 | r <- rear q 84 | putStrLn (show r) 85 | putStr " , queue = " 86 | putStr "[" 87 | r' <- rear q 88 | sz' <- size q 89 | flip mapM_ [r'..sz' - 1] $ \ix -> do 90 | x <- Vec.unsafeRead (qQueue q) ix 91 | putStr (show x) 92 | unless (ix == sz' - 1) $ do 93 | putStr ", " 94 | putStrLn "]" 95 | 96 | -- If you read this far, hopefully you will appreciate that getting all this 97 | -- right without an off-by-one error somewhere can be a bit tricky... 98 | -------------------------------------------------------------------------------- /src/Part03/QueueInterface.hs: -------------------------------------------------------------------------------- 1 | module Part03.QueueInterface (module Part03.QueueInterface) where 2 | 3 | -- The queue interface supports enqueing, where a bool is returned indicating if 4 | -- the queue is full or not, and dequeuing, where we get an optional value out 5 | -- to cover the case of the queue being empty. 6 | 7 | data QueueI a = QueueI 8 | { qiEnqueue :: a -> IO Bool 9 | , qiDequeue :: IO (Maybe a) 10 | } 11 | -------------------------------------------------------------------------------- /src/Part03/QueueTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | 3 | module Part03.QueueTest (module Part03.QueueTest) where 4 | 5 | import Control.Monad 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Monadic 8 | 9 | import Part03.Queue 10 | 11 | ------------------------------------------------------------------------ 12 | 13 | -- The model of our queue will use a simple immutable linked list rather than 14 | -- the complicated mutable array. 15 | 16 | data Model a = Model 17 | { mCapacity :: Int 18 | , mQueue :: [a] 19 | } 20 | deriving stock Show 21 | 22 | newModel :: Int -> Model a 23 | newModel cap = Model cap [] 24 | 25 | data Command a 26 | = Size 27 | | Clear 28 | | IsEmpty 29 | | Enqueue a 30 | | Dequeue 31 | deriving stock Show 32 | 33 | prettyCommand :: Command a -> String 34 | prettyCommand Size = "Size" 35 | prettyCommand Clear = "Clear" 36 | prettyCommand IsEmpty = "IsEmpty" 37 | prettyCommand Enqueue {} = "Enqueue" 38 | prettyCommand Dequeue = "Dequeue" 39 | 40 | data Response a 41 | = Int Int 42 | | Unit () 43 | | Maybe (Maybe a) 44 | | Bool Bool 45 | deriving stock (Show, Eq) 46 | 47 | -- Enqueuing merely appends to the back of the list. 48 | 49 | fakeEnqueue :: a -> Model a -> (Model a, Bool) 50 | fakeEnqueue x m 51 | | length (mQueue m) >= mCapacity m = (m, False) 52 | | otherwise = (m { mQueue = mQueue m ++ [x]}, True) 53 | 54 | -- While dequeuing merely returns the head of the list. 55 | 56 | fakeDequeue :: Model a -> (Model a, Maybe a) 57 | fakeDequeue m = case mQueue m of 58 | [] -> (m, Nothing) 59 | (x : xs) -> (m { mQueue = xs }, Just x) 60 | 61 | step :: Command a -> Model a -> (Model a, Response a) 62 | step Size m = (m, Int (length (mQueue m))) 63 | step Clear m = (m { mQueue = [] }, Unit ()) 64 | step IsEmpty m = (m, Bool (null (mQueue m))) 65 | step (Enqueue x) m = Bool <$> fakeEnqueue x m 66 | step Dequeue m = Maybe <$> fakeDequeue m 67 | 68 | exec :: Command a -> Queue a -> IO (Response a) 69 | exec Size q = Int <$> size q 70 | exec Clear q = Unit <$> clear q 71 | exec IsEmpty q = Bool <$> isEmpty q 72 | exec (Enqueue x) q = Bool <$> enqueue q x 73 | exec Dequeue q = Maybe <$> dequeue q 74 | 75 | genCommand :: Arbitrary a => Int -> Int -> Gen (Command a) 76 | genCommand _cap _sz = frequency 77 | [ (3, pure Size) 78 | , (0, pure Clear) -- NOTE: If this happens too often, it causing enqueue to 79 | -- rarely write to a full queue. 80 | , (2, pure IsEmpty) 81 | , (5, Enqueue <$> arbitrary) 82 | , (2, pure Dequeue) 83 | ] 84 | 85 | genCommands :: Arbitrary a => Int -> Int -> Gen [Command a] 86 | genCommands cap sz0 = sized (go sz0) 87 | where 88 | go _sz 0 = return [] 89 | go sz n = do 90 | cmd <- genCommand cap sz 91 | let sz' = case cmd of 92 | Size -> sz 93 | Clear -> 0 94 | IsEmpty -> sz 95 | Enqueue {} -> sz + 1 96 | Dequeue -> sz - 1 97 | cmds <- go sz' (n - 1) 98 | return (cmd : cmds) 99 | 100 | newtype Capacity = Capacity Int 101 | deriving stock Show 102 | 103 | instance Arbitrary Capacity where 104 | arbitrary = Capacity <$> choose (0, 5) 105 | 106 | -- The tests that ensure that the model is faithful to the real queue 107 | -- implementation also doubles as contract tests once we turn or model into a 108 | -- fake. 109 | 110 | prop_contractTests :: Capacity -> Property 111 | prop_contractTests (Capacity cap) = 112 | forAllShrink (genCommands cap 0) (shrinkList (const [])) $ \cmds -> monadicIO $ do 113 | let m = newModel cap 114 | q <- run (newQueue cap) 115 | monitor (tabulate "Commands" (map prettyCommand cmds)) 116 | (result, hist) <- go cmds m q [] 117 | mapM_ (monitor . classify') (zip cmds hist) 118 | return result 119 | where 120 | go :: [Command Int] -> Model Int -> Queue Int -> [Response Int] -> PropertyM IO (Bool, [Response Int]) 121 | go [] _m _q hist = return (True, reverse hist) 122 | go (cmd : cmds) m q hist = do 123 | let (m', resp) = step cmd m 124 | resp' <- run (exec cmd q) 125 | unless (resp == resp') $ 126 | monitor (counterexample (show resp ++ " /= " ++ show resp')) 127 | go cmds m' q (resp : hist) 128 | 129 | classify' :: (Command a, Response a) -> Property -> Property 130 | classify' (Enqueue {}, Bool b) = classify b "enqueue successful" 131 | classify' (_, _) = id 132 | -------------------------------------------------------------------------------- /src/Part03/Service.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE NumericUnderscores #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Part03.Service (module Part03.Service) where 7 | 8 | import Control.Concurrent 9 | import Control.Concurrent.Async 10 | import Control.Exception (IOException, bracket, catch, throwIO) 11 | import Control.Monad (forM_) 12 | import Data.ByteString.Lazy (ByteString) 13 | import qualified Data.ByteString.Lazy.Char8 as BS8 14 | import Data.IORef 15 | import Data.String (fromString) 16 | import Data.Text.Read (decimal) 17 | import Database.SQLite.Simple 18 | ( Connection 19 | , Only(Only) 20 | , close 21 | , execute 22 | , execute_ 23 | , lastInsertRowId 24 | , open 25 | , query 26 | ) 27 | import Network.HTTP.Types.Status 28 | import Network.Wai 29 | import Network.Wai.Handler.Warp 30 | import System.Environment 31 | import System.Timeout (timeout) 32 | 33 | import Part03.Queue 34 | import Part03.QueueInterface 35 | import Part03.QueueTest (fakeDequeue, fakeEnqueue, newModel) 36 | 37 | ------------------------------------------------------------------------ 38 | 39 | mAX_QUEUE_SIZE :: Int 40 | mAX_QUEUE_SIZE = 128 41 | 42 | pORT :: Int 43 | pORT = 8050 44 | 45 | ------------------------------------------------------------------------ 46 | 47 | -- We start by implementing our queue interface using the real mutable 48 | -- array-backed queue and the fake immutable linked list based one. 49 | 50 | realQueue :: Int -> IO (QueueI a) 51 | realQueue sz = do 52 | q <- newQueue sz 53 | return QueueI 54 | { qiEnqueue = enqueue q 55 | , qiDequeue = dequeue q 56 | } 57 | 58 | fakeQueue :: Int -> IO (QueueI a) 59 | fakeQueue sz = do 60 | ref <- newIORef (newModel sz) 61 | return QueueI 62 | { qiEnqueue = \x -> atomicModifyIORef' ref (fakeEnqueue x) 63 | , qiDequeue = atomicModifyIORef' ref fakeDequeue 64 | } 65 | 66 | -- ^ Notice how the fake queue uses the model together with a mutable variable 67 | -- (`IORef`) to keep track of the current state (starting with the inital 68 | -- model). 69 | 70 | ------------------------------------------------------------------------ 71 | 72 | -- The main function chooses between the two implementations of the interfaces 73 | -- depending on a command-line flag. 74 | 75 | main :: IO () 76 | main = do 77 | args <- getArgs 78 | queue <- case args of 79 | ["--testing"] -> fakeQueue mAX_QUEUE_SIZE 80 | _otherwise -> realQueue mAX_QUEUE_SIZE 81 | service sQLITE_DB_PATH queue 82 | 83 | -- The web service is written against the queue interface, it doesn't care which 84 | -- implementation of it we pass it. 85 | 86 | service :: FilePath -> QueueI Command -> IO () 87 | service sqliteDbPath queue = do 88 | bracket (initDB sqliteDbPath) closeDB $ \conn -> 89 | withAsync (worker NoBug queue conn) $ \_a -> do 90 | _ready <- newEmptyMVar 91 | runFrontEnd NoBug queue _ready pORT 92 | 93 | data Bug = NoBug | IgnoreCheckingIfEnqueueSucceeded | DontCatchDequeueError | TooShortWorkerTimeout 94 | deriving stock Eq 95 | 96 | withService :: Bug -> QueueI Command -> IO () -> IO () 97 | withService bug = withService' bug sQLITE_DB_PATH 98 | 99 | withService' :: Bug -> FilePath -> QueueI Command -> IO () -> IO () 100 | withService' bug sqliteDbPath queue io = do 101 | bracket (initDB sqliteDbPath) closeDB $ \conn -> 102 | withAsync (worker bug queue conn) $ \wPid -> do 103 | link wPid 104 | ready <- newEmptyMVar 105 | withAsync (runFrontEnd bug queue ready pORT) $ \fePid -> do 106 | link fePid 107 | takeMVar ready 108 | io 109 | 110 | worker :: Bug -> QueueI Command -> Connection -> IO () 111 | worker bug queue conn = go 112 | where 113 | go :: IO () 114 | go = do 115 | mCmd <- qiDequeue queue 116 | -- BUG: Without this catch the read error fault will cause a crash. 117 | `catch` (\(err :: IOException) -> if bug == DontCatchDequeueError 118 | then throwIO err 119 | else return Nothing) 120 | case mCmd of 121 | Nothing -> do 122 | threadDelay 1000 -- 1 ms 123 | go 124 | Just cmd -> do 125 | exec cmd conn 126 | go 127 | 128 | data Command 129 | = Write ByteString (MVar Int) 130 | | Read Int (MVar (Maybe ByteString)) 131 | | Reset (MVar ()) -- For testing. 132 | 133 | prettyCommand :: Command -> String 134 | prettyCommand (Write bs _response) = "Write " ++ show bs 135 | prettyCommand (Read ix _response) = "Read " ++ show ix 136 | prettyCommand (Reset _response) = "Reset" 137 | 138 | exec :: Command -> Connection -> IO () 139 | exec (Read ix response) conn = do 140 | bs <- readDB conn ix 141 | putMVar response bs 142 | exec (Write bs response) conn = do 143 | ix <- writeDB conn bs 144 | putMVar response ix 145 | exec (Reset response) conn = do 146 | resetDB conn 147 | putMVar response () 148 | 149 | wORKER_TIMEOUT_MICROS :: Bug -> Int 150 | -- BUG: Having a shorter worker timeout will cause the slow read fault to crash the system. 151 | wORKER_TIMEOUT_MICROS TooShortWorkerTimeout = 100_000 -- 0.1s 152 | wORKER_TIMEOUT_MICROS _otherwise = 30_000_000 -- 30s 153 | 154 | httpFrontend :: Bug -> QueueI Command -> Application 155 | httpFrontend bug queue req respond = 156 | case requestMethod req of 157 | "GET" -> do 158 | case parseIndex of 159 | Nothing -> 160 | respond (responseLBS status400 [] "Couldn't parse index") 161 | Just ix -> do 162 | response <- newEmptyMVar 163 | success <- qiEnqueue queue (Read ix response) 164 | if success 165 | then do 166 | mMbs <- timeout (wORKER_TIMEOUT_MICROS bug) (takeMVar response) 167 | case mMbs of 168 | Just Nothing -> respond (responseLBS status404 [] (BS8.pack "Not found")) 169 | Just (Just bs) -> respond (responseLBS status200 [] bs) 170 | Nothing -> respond (responseLBS status500 [] (BS8.pack "Internal error")) 171 | else respond (responseLBS status503 [] "Overloaded") 172 | "POST" -> do 173 | bs <- consumeRequestBodyStrict req 174 | response <- newEmptyMVar 175 | success <- qiEnqueue queue (Write bs response) 176 | -- BUG: Ignoring whether the enqueuing operation was successful or not will cause a crash. 177 | if success || bug == IgnoreCheckingIfEnqueueSucceeded 178 | then do 179 | mIx <- timeout (wORKER_TIMEOUT_MICROS bug) (takeMVar response) 180 | case mIx of 181 | Just ix -> respond (responseLBS status200 [] (BS8.pack (show ix))) 182 | Nothing -> respond (responseLBS status500 [] (BS8.pack "Internal error")) 183 | else respond (responseLBS status503 [] "Overloaded") 184 | 185 | "DELETE" -> do 186 | response <- newEmptyMVar 187 | _b <- qiEnqueue queue (Reset response) 188 | mu <- timeout (wORKER_TIMEOUT_MICROS bug) (takeMVar response) 189 | case mu of 190 | Just () -> respond (responseLBS status200 [] (BS8.pack "Reset")) 191 | Nothing -> respond (responseLBS status500 [] (BS8.pack "Internal error")) 192 | _otherwise -> do 193 | respond (responseLBS status400 [] "Invalid method") 194 | where 195 | parseIndex :: Maybe Int 196 | parseIndex = case pathInfo req of 197 | [txt] -> case decimal txt of 198 | Right (ix, _rest) -> Just ix 199 | _otherwise -> Nothing 200 | _otherwise -> Nothing 201 | 202 | runFrontEnd :: Bug -> QueueI Command -> MVar () -> Port -> IO () 203 | runFrontEnd bug queue ready port = runSettings settings (httpFrontend bug queue) 204 | where 205 | settings 206 | = setPort port 207 | $ setBeforeMainLoop (putMVar ready ()) 208 | $ defaultSettings 209 | 210 | ------------------------------------------------------------------------ 211 | 212 | sQLITE_DB_PATH :: FilePath 213 | sQLITE_DB_PATH = "/tmp/part3_webservice.sqlite3" 214 | 215 | sQLITE_FLAGS :: [String] 216 | sQLITE_FLAGS = ["fullfsync=1", "journal_mode=WAL", "synchronous=NORMAL"] 217 | 218 | sqlitePath :: FilePath -> String 219 | sqlitePath fp = 220 | let 221 | flags = map (++ ";") sQLITE_FLAGS 222 | in 223 | fp ++ "?" ++ concat flags 224 | 225 | initDB :: FilePath -> IO Connection 226 | initDB fp = do 227 | conn <- open (sqlitePath fp) 228 | let flags = map (++ ";") sQLITE_FLAGS 229 | forM_ flags $ \flag -> do 230 | execute_ conn ("PRAGMA " <> fromString flag) 231 | resetDB conn 232 | return conn 233 | 234 | resetDB :: Connection -> IO () 235 | resetDB conn = do 236 | execute_ conn "DROP TABLE IF EXISTS part3_webservice" 237 | execute_ conn "CREATE TABLE IF NOT EXISTS part3_webservice (ix INTEGER PRIMARY KEY, value BLOB)" 238 | 239 | writeDB :: Connection -> ByteString -> IO Int 240 | writeDB conn bs = do 241 | execute conn "INSERT INTO part3_webservice (value) VALUES (?)" (Only bs) 242 | fromIntegral . pred <$> lastInsertRowId conn 243 | 244 | readDB :: Connection -> Int -> IO (Maybe ByteString) 245 | readDB conn ix = do 246 | result <- query conn "SELECT value from part3_webservice WHERE ix = ?" (Only (ix + 1)) 247 | case result of 248 | [[bs]] -> return (Just bs) 249 | _otherwise -> return Nothing 250 | 251 | closeDB :: Connection -> IO () 252 | closeDB = close 253 | -------------------------------------------------------------------------------- /src/Part03/ServiceTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Part03.ServiceTest (module Part03.ServiceTest) where 6 | 7 | import Control.Concurrent 8 | import Control.Concurrent.Async 9 | import Control.Concurrent.STM 10 | import Control.Monad 11 | import qualified Data.ByteString.Char8 as BS8 12 | import Data.ByteString.Lazy (ByteString) 13 | import qualified Data.ByteString.Lazy as LBS 14 | import qualified Data.ByteString.Lazy.Char8 as LBS8 15 | import Data.List (permutations) 16 | import Data.Vector (Vector) 17 | import qualified Data.Vector as Vector 18 | import Network.HTTP.Client 19 | ( Manager 20 | , RequestBody(RequestBodyLBS) 21 | , brConsume 22 | , defaultManagerSettings 23 | , httpLbs 24 | , method 25 | , newManager 26 | , parseRequest 27 | , path 28 | , requestBody 29 | , responseBody 30 | , throwErrorStatusCodes 31 | , withResponse 32 | ) 33 | import Test.QuickCheck 34 | import Test.QuickCheck.Monadic 35 | 36 | -- We can reuse most of the concurrent testing machinary from the second 37 | -- part. 38 | 39 | import Part02ConcurrentSMTesting 40 | ( History'(History) 41 | , Operation'(Ok) 42 | , appendHistory 43 | , assertWithFail 44 | , classifyCommandsLength 45 | , interleavings 46 | , linearisable 47 | , prettyHistory 48 | , toPid 49 | ) 50 | import Part03.Service 51 | 52 | ------------------------------------------------------------------------ 53 | 54 | newtype Index = Index Int 55 | deriving stock (Eq, Ord, Show) 56 | deriving newtype Num 57 | 58 | data ClientRequest = WriteReq ByteString | ReadReq Index 59 | deriving stock Show 60 | 61 | data ClientResponse = WriteResp Index | ReadResp ByteString 62 | deriving stock (Eq, Show) 63 | 64 | newtype ConcProgram = ConcProgram { unConcProgram :: [[ClientRequest]] } 65 | deriving stock Show 66 | 67 | newtype Model = Model (Vector ByteString) 68 | 69 | initModel :: Model 70 | initModel = Model Vector.empty 71 | 72 | step :: Model -> ClientRequest -> (Model, ClientResponse) 73 | step (Model vec) (WriteReq bs) = 74 | (Model (Vector.snoc vec bs), WriteResp (Index (Vector.length vec))) 75 | step (Model vec) (ReadReq (Index ix)) = 76 | (Model vec, ReadResp (vec Vector.! ix)) 77 | 78 | type Operation = Operation' ClientRequest ClientResponse 79 | 80 | concExec :: Manager -> TQueue Operation -> ClientRequest -> IO () 81 | concExec mgr hist req = 82 | case req of 83 | WriteReq bs -> do 84 | ix <- httpWrite mgr bs 85 | pid <- toPid <$> myThreadId 86 | appendHistory hist (Ok pid (WriteResp ix)) 87 | ReadReq ix -> do 88 | bs <- httpRead mgr ix 89 | pid <- toPid <$> myThreadId 90 | appendHistory hist (Ok pid (ReadResp bs)) 91 | 92 | ------------------------------------------------------------------------ 93 | 94 | httpWrite :: Manager -> ByteString -> IO Index 95 | httpWrite mgr bs = do 96 | initReq <- parseRequest ("http://localhost:" ++ show pORT) 97 | let req = initReq { method = "POST" 98 | , requestBody = RequestBodyLBS bs 99 | } 100 | withResponse req mgr $ \resp -> do 101 | throwErrorStatusCodes req resp 102 | bss <- brConsume (responseBody resp) 103 | case LBS8.readInt (LBS8.fromChunks bss) of 104 | Nothing -> error "httpWrite: can't read index" 105 | Just (ix, _rest) -> return (Index ix) 106 | 107 | httpRead :: Manager -> Index -> IO ByteString 108 | httpRead mgr (Index ix) = do 109 | initReq <- parseRequest ("http://localhost:" ++ show pORT) 110 | let req = initReq { method = "GET" 111 | , path = path initReq <> BS8.pack (show ix) 112 | } 113 | withResponse req mgr $ \resp -> do 114 | throwErrorStatusCodes req resp 115 | bss <- brConsume (responseBody resp) 116 | return (LBS8.fromChunks bss) 117 | 118 | httpReset :: Manager -> IO () 119 | httpReset mgr = do 120 | initReq <- parseRequest ("http://localhost:" ++ show pORT) 121 | _resp <- httpLbs initReq { method = "DELETE" } mgr 122 | return () 123 | 124 | ------------------------------------------------------------------------ 125 | 126 | genClientRequest :: Gen ClientRequest 127 | genClientRequest = oneof 128 | [ WriteReq <$> (LBS.pack <$> arbitrary) 129 | , ReadReq <$> (Index <$> arbitrary) 130 | ] 131 | 132 | validProgram :: Model -> [ClientRequest] -> Bool 133 | validProgram _model _cmds = True 134 | 135 | shrinkClientRequest :: ClientRequest -> [ClientRequest] 136 | shrinkClientRequest (WriteReq bs) = [ WriteReq (LBS.pack s') | s' <- shrink (LBS.unpack bs) ] 137 | shrinkClientRequest (ReadReq _ix) = [] 138 | 139 | genConcProgram :: Model -> Gen ConcProgram 140 | genConcProgram m0 = sized (go m0 []) 141 | where 142 | go :: Model -> [[ClientRequest]] -> Int -> Gen ConcProgram 143 | go m acc sz | sz <= 0 = return (ConcProgram (reverse acc)) 144 | | otherwise = do 145 | n <- chooseInt (2, 5) 146 | reqs <- vectorOf n genClientRequest `suchThat` concSafe m 147 | go (advanceModel m reqs) (reqs : acc) (sz - n) 148 | 149 | advanceModel :: Model -> [ClientRequest] -> Model 150 | advanceModel m reqs = foldl (\ih req -> fst (step ih req)) m reqs 151 | 152 | concSafe :: Model -> [ClientRequest] -> Bool 153 | concSafe m = all (validProgram m) . permutations 154 | 155 | validConcProgram :: Model -> ConcProgram -> Bool 156 | validConcProgram m0 (ConcProgram reqss0) = go m0 True reqss0 157 | where 158 | go :: Model -> Bool -> [[ClientRequest]] -> Bool 159 | go _m False _ = False 160 | go _m acc [] = acc 161 | go m _acc (reqs : reqss) = go (advanceModel m reqs) (concSafe m reqs) reqss 162 | 163 | shrinkConcProgram :: Model -> ConcProgram -> [ConcProgram] 164 | shrinkConcProgram m 165 | = filter (validConcProgram m) 166 | . map ConcProgram 167 | . filter (not . null) 168 | . shrinkList (shrinkList shrinkClientRequest) 169 | . unConcProgram 170 | 171 | prettyConcProgram :: ConcProgram -> String 172 | prettyConcProgram = show 173 | 174 | forAllConcProgram :: (ConcProgram -> Property) -> Property 175 | forAllConcProgram k = 176 | forAllShrinkShow (genConcProgram m) (shrinkConcProgram m) prettyConcProgram k 177 | where 178 | m = initModel 179 | 180 | -- Finally we can write our integration tests between the queue and the web 181 | -- service, sometimes these tests are also called "collaboration tests". 182 | 183 | -- NOTE: We shouldn't use a model in concurrent tests before we made sure it 184 | -- passes sequential tests. 185 | 186 | -- NOTE: Assumes that the service is running. 187 | prop_integrationTests :: Manager -> Property 188 | prop_integrationTests mgr = mapSize (min 20) $ 189 | forAllConcProgram $ \(ConcProgram reqss) -> monadicIO $ do 190 | monitor (classifyCommandsLength (concat reqss)) 191 | monitor (tabulate "Client requests" (map constructorString (concat reqss))) 192 | monitor (tabulate "Number of concurrent client requests" (map (show . length) reqss)) 193 | -- Rerun a couple of times, to avoid being lucky with the interleavings. 194 | replicateM_ 10 $ do 195 | queue <- run newTQueueIO 196 | run (mapM_ (mapConcurrently (concExec mgr queue)) reqss) 197 | hist <- History <$> run (atomically (flushTQueue queue)) 198 | assertWithFail (linearisable step initModel (interleavings hist)) (prettyHistory hist) 199 | run (httpReset mgr) 200 | where 201 | constructorString :: ClientRequest -> String 202 | constructorString WriteReq {} = "WriteReq" 203 | constructorString ReadReq {} = "ReadReq" 204 | 205 | test :: IO () 206 | test = do 207 | -- NOTE: fake queue is used here, justified by previous contract testing. 208 | queue <- fakeQueue mAX_QUEUE_SIZE 209 | mgr <- newManager defaultManagerSettings 210 | withService NoBug queue (quickCheck (prop_integrationTests mgr)) 211 | -------------------------------------------------------------------------------- /src/Part03SMContractTesting.lhs: -------------------------------------------------------------------------------- 1 | Integration tests against state machine fakes and consumer-driven contract tests for the fakes 2 | ============================================================================================== 3 | 4 | Motivation 5 | ---------- 6 | 7 | So far we have seen how to test a single component sequentially ([part 8 | 1](./Part01SMTesting.md#readme)) and concurrently ([part 9 | 2](./Part02ConcurrentSMTesting.md#readme)). Most systems are composed of several 10 | components however, and the global correctness of the composed system doesn't 11 | follow from the local correctness of its components, a typical problem being 12 | that the two components that are meant to talk to each other make wrong 13 | assumptions about each other's API. 14 | 15 | The usual solution to this problem is to add so called integration tests which 16 | deploy both components and perform some kind of interaction that exercises the 17 | API between the components to ensure that the assumptions are correct. Whenever 18 | some component needs to be deployed it will slow down the test and most likely 19 | introduce some flakiness related to deployment, e.g. some port is in use 20 | already, or not yet available to be used, or docker registry is temporarily 21 | down, or some other http request that is involved during deployment fails, etc. 22 | 23 | In order to avoid having slow and flaky integration tests, the standard solution 24 | is to mock out all the dependencies of the software under test (SUT). This 25 | works, however it introduces a new problem: what if the mocks are incorrect 26 | (i.e. they encode the same false assumptions of the consumed API). A solution to 27 | this problem is to write so called (consumer-driven) contract tests which verify 28 | that the mock is faithful to the real component. Unfortunately this solution 29 | doesn't seem to be standard in our industry. Mocks are fairly common, but 30 | contract tests not so much so. This has led to mocks sometimes being called 31 | useless, because people have been bitten by mocks being wrong (because they 32 | didn't have contract tests). 33 | 34 | In our case, since we got an executable state machine model, we effectively 35 | already got something that is better than a mock: a fake. Furthermore we have 36 | already seen how to ensure that such a state machine model is faithful to the 37 | real component, i.e. we already know how to do contract tests. So in this part 38 | we will merely make these things more explicit and glue them together to get 39 | fast and deterministic integration tests. 40 | 41 | Plan 42 | ---- 43 | 44 | Imagine our system consists of two components: $A$ and $B$, where $A$ depends on 45 | $B$. We then proceed as follows: 46 | 47 | 1. Following the pattern from part 1 and 2: make a state machine (SM) model of 48 | the dependency $B$, use SM testing to ensure that the model is faithful to 49 | the real implementation of $B$ (these tests are our contract tests); 50 | 51 | 2. Turn the SM model of $B$ into a fake and use it in-place of the real 52 | implementation of $B$ inside the real implementation of $A$; 53 | 54 | 3. Repeat the first step for component $A$. Note that while testing $A$ we will 55 | not be using the real component $B$ but rather a fake of it, this gives us 56 | possibly faster and more deterministic integration tests. 57 | 58 | How it works 59 | ------------ 60 | 61 | The SUT of the day is a web service which queues up client requests and has a 62 | worker that processes the queue and replies to the clients. 63 | 64 | ![](../images/part3-web-service-with-queue-small.jpg){ width=400px } 65 | 66 | Imagine if this queue is a separate process. This makes it a bit annoying to 67 | test because we need to deploy the queue first, make sure it's ready for work 68 | before we start testing the web service. 69 | 70 | One way around the above problem is to implement the web service against an 71 | *interface* of the queue rather than the queue itself. We can then implement 72 | this interface using the real queue but also a fake queue which lives in the 73 | same process as the web service hence avoiding deploying the queue before 74 | testing. Depending if we deploy the web service in "production" or for "testing" 75 | we choose the between the two implementations of the interface. 76 | 77 | ![](../images/part3-web-service-with-interface-small.jpg){ width=450px } 78 | 79 | The problem of this approach is: how do we know that the fake queue is faithful 80 | to the real queue implementation? We would need to test this somehow! (These 81 | tests are usually called contract tests.) 82 | 83 | Let's take a step back and recall what we are doing when we are state machine 84 | testing. We ensure that the state machine model is faithful to the SUT. 85 | 86 | ![](../images/part3-sm-model-small.jpg){ width=250px } 87 | 88 | Assuming we have a state machine model of the queue which we know is faithful to 89 | the real queue, is there a way to turn this model into a fake and hence solve 90 | our problem? 91 | 92 | Yes! It's quite simple, merely create a wrapper around the state machine model 93 | which has a variable with the current state. Initialise this current state with 94 | the initial model, and every time we get an input, read the state, apply the 95 | state machine function, update the state variable. 96 | 97 | (Note that the model isn't a fake because it doesn't have the same in- and 98 | outputs -- that's what the wrapper fixes.) 99 | 100 | ![](../images/part3-sm-model-fake-small.jpg){ width=500px } 101 | 102 | Let's zoom out a bit and contemplate the general picture. Our queue can be 103 | thought of as a producer of the interface, while the web service is consumer of 104 | it. 105 | 106 | ``` 107 | Interface 108 | | 109 | Consumer | Producer 110 | | 111 | ----------> x--------> 112 | | 113 | Integration | Contract tests 114 | tests | 115 | 116 | ``` 117 | 118 | When we integration test our web service against the fake queue we are doing, 119 | what is sometimes called, "collaboration tests", while when we are ensuring that 120 | the fake queue is faithful to the real queue we are doing contract tests. 121 | 122 | The above relations between consumers and producers of interfaces can be 123 | generalised from one-to-one relations, as in the web service and queue example, 124 | to many-to-many relations and we can also nest them, i.e. a producer can in turn 125 | be a consumer. The kind of testing we've talked about generalised to these 126 | contexts as well and done in "layers", starting with the bottom layer and going 127 | up. 128 | 129 | Almost done! We've seen that the job of contract tests are to ensure the 130 | accuracy of the fakes you use of other components in your fast and deterministic 131 | integration tests. We use the term *consumer-driven* contract tests if the 132 | consumer of the faked API writes the contract test inside the test-suite of the 133 | producer. 134 | 135 | For example, if component $A$ and $B$ are developed in different repos or by 136 | different teams, then the consumer of the API (in our case $A$ consumes $B$'s 137 | API) should write the contract test (hence *consumer-driven*). 138 | 139 | That way: 140 | 141 | 1. the fake of the consumed API is more to encode the assumptions that the 142 | consumer makes; 143 | 144 | 2. if the implementation of the consumed API changes in a way that break the 145 | contract test that ensures that the fake is faithfully with regards to the 146 | real implementation, then the developers of the consumed API will get a 147 | failing test and thus a warning about the fact that some assumptions of the 148 | consumer might have been broken. 149 | 150 | So with other words, consumer-driven is just a policy about who writes which 151 | contract tests and where those tests are supposed to live, and by following this 152 | policy we are more likely to catch if a producer of an API makes a change that 153 | will break the interaction between the consumer and the producer. 154 | 155 | Code 156 | ---- 157 | 158 | 163 | 164 | In order to save space we won't include all code here, but rather link to the 165 | relevant modules. 166 | 167 | Let's start with our dependency, the [queue](../src/Part03/Queue.hs): 168 | 169 | > import Part03.Queue () 170 | 171 | The queue is [tested](../src/Part03/QueueTest.hs) using a state machine model like 172 | we did in part 1 och 2: 173 | 174 | > import Part03.QueueTest () 175 | 176 | So far nothing new, except for terminology: because the state machine model will 177 | later become our fake, we call the tests that check that the model is faithful 178 | to the real queue: *contract tests*. 179 | 180 | Next lets have a look at the web services which depends on the queue. In order 181 | for us to be able to swap between the fake and the real queue implementation we 182 | first specify a queue [interface](../src/Part03/QueueInterface.hs): 183 | 184 | > import Part03.QueueInterface () 185 | 186 | Our [web service](../src/Part03/Service.hs) is implemented against the 187 | interface: 188 | 189 | > import Part03.Service () 190 | 191 | Notice how simple it's to implement a fake queue from the state machine model 192 | (we only need a mutable variable, this is the wrapper we talked about above in 193 | the "how it works" section). Also notice that in, e.g., `main` we can select 194 | which implementation we want because the web service is written against the 195 | interface. 196 | 197 | When we [integration test](../src/Part03/ServiceTest.hs) the web service with 198 | the queue, we always use the fake queue for speed and determinism: 199 | 200 | > import Part03.ServiceTest () 201 | 202 | Because we've made sure that the fake queue is faithful to the real queue so we 203 | can be reasonably sure that when we use the real queue in a "production" 204 | deployment the system will behave the same as it did in the tests with the fake 205 | queue. 206 | 207 | Discussion 208 | ---------- 209 | 210 | Why not just spin up the real component B when testing component A? 211 | 212 | - Imagine B is a queue and the real implementation uses Kafka, then we'd need to 213 | start several processes... 214 | 215 | - Sometimes component B is slow to use (uses disk or network I/O)... 216 | 217 | - Sometimes component B is a third-party component which we can't redeploy or 218 | reset between test runs... 219 | 220 | - Often we want to be resilient at the level of component A in case component B 221 | fails, injecting faults in B to test this is much easier on a fake of B rather 222 | than on the real implementation of B (more on this in the next part). 223 | 224 | - Basically this is how the road towards slow and flaky tests starts. Don't go 225 | down that path! If you are thinking: "but some code is only exercised when the 226 | real component is deployed, e.g. configuration", then use [smoke 227 | tests](https://en.wikipedia.org/wiki/Smoke_testing_%28software%29) rather than 228 | integration tests with real components. 229 | 230 | Origin of the terminology: "The phrase smoke test comes from electronic 231 | hardware testing. You plug in a new board and turn on the power. If you see 232 | smoke coming from the board, turn off the power. You don’t have to do any more 233 | testing." 234 | 235 | The software analogue: spin up component(s), wait for their status to become 236 | "ready", make some basic requests and see if they succeed. 237 | 238 | Acceptable if these are a bit flaky: 239 | 240 | + Component spin up happens relatively rarely in production 241 | + These tests will likely involve docker containers and networking, i.e. 242 | third-party infrastructure that sometimes is flaky 243 | 244 | "After code reviews, smoke testing is the most cost effective method for 245 | identifying and fixing defects in software." -- 246 | [Microsoft](https://docs.microsoft.com/en-us/previous-versions/ms182613(v=vs.80)) 247 | 248 | For most software systems, between good contract tests and smoke tests there 249 | shouldn't be much of a gap for bugs to sneak in. For special cases, such as 250 | distributed systems, we will cover more comprehensive techniques in part 5. 251 | 252 | Exercises 253 | --------- 254 | 255 | 0. The fake/model of the queue is thread-safe, but the real implementation 256 | isn't! Fix that and do concurrent contract testing. 257 | 258 | 1. Introduce an interface for all database interaction, move the current 259 | database implementation to `realDb` and introduce fake database instance of 260 | the interface. 261 | 262 | 2. Write contract tests that ensure that the fake database faithfully represents 263 | the real one. 264 | 265 | 3. Once the contract tests pass, switch out the real database for the fake one 266 | in the integration tests (the test-suite of the web service). Enable timing 267 | output in `ghci` with `:set +s`, crank up the number of tests that 268 | `QuickCheck` generates, and see if you notice any speed up in the test 269 | execution time. 270 | 271 | 4. Think of corner cases for the queue you'd write unit tests for, but instead 272 | add those cases to the coverage checker to ensure that the generator 273 | generates them. 274 | 275 | See also 276 | -------- 277 | 278 | - For the difference between a fake and e.g. a mock see the following 279 | [article](https://www.martinfowler.com/bliki/TestDouble.html) by Martin 280 | Fowler; 281 | 282 | - For more on contract testing see this 283 | [article](https://martinfowler.com/bliki/ContractTest.html) and for more on 284 | their consumer-driven variant see the following 285 | [article](https://martinfowler.com/articles/consumerDrivenContracts.html); 286 | 287 | - [*Integrated Tests Are A Scam*](https://www.youtube.com/watch?v=fhFa4tkFUFw) 288 | talk by J.B. Rainsberger (2022), this a less ranty version of a talk with the 289 | same title that he [gave](https://www.youtube.com/watch?v=VDfX44fZoMc) at 290 | DevConFu in 2013; 291 | 292 | - [*Consumer-Driven Contracts Done 293 | Right*](https://github.com/aleryo/homomorphic-event-sourcing/) talk by Arnaud 294 | Bailly and Nicole Rauch (2018). 295 | 296 | Summary 297 | ------- 298 | 299 | - State machine testing a component using a model gives us a faithful fake for 300 | that component for free; 301 | 302 | - Using fakes enables to fast and deterministic integration tests and, as we 303 | shall see next, makes it easier to introduce faults when testing; 304 | 305 | - Contract tests justify the use of fakes, in-place of the real dependencies, 306 | when integration testing the SUT. 307 | 308 | Next up 309 | ------- 310 | 311 | In [part 4](./Part04FaultInjection.md#readme) we will look at how we can test 312 | some "unhappy paths" of the SUT by injecting faults into our fakes. 313 | -------------------------------------------------------------------------------- /src/Part04/CRC32.hs: -------------------------------------------------------------------------------- 1 | module Part04.CRC32 (module Part04.CRC32) where 2 | 3 | import Data.Bits (complement, shiftR, xor, (.&.)) 4 | import Data.ByteString (ByteString) 5 | import qualified Data.ByteString as BS 6 | import Data.Vector.Unboxed (Vector) 7 | import qualified Data.Vector.Unboxed as Vector 8 | import Data.Word (Word32, Word8) 9 | 10 | ------------------------------------------------------------------------ 11 | 12 | -- The checksum function is taken from 13 | -- https://rosettacode.org/wiki/CRC-32#Haskell. 14 | crc32 :: ByteString -> Word32 15 | crc32 = complement . BS.foldl go (complement 0) 16 | where 17 | go :: Word32 -> Word8 -> Word32 18 | go crc byte = (crc `shiftR` 8) `xor` 19 | table Vector.! fromIntegral ((crc .&. 0xFF) `xor` fromIntegral byte) 20 | 21 | -- The following table is generated using the code from "A PAINLESS GUIDE TO CRC 22 | -- ERROR DETECTION ALGORITHMS" (https://zlib.net/crc_v3.txt). 23 | table :: Vector Word32 24 | table = Vector.fromList [ 25 | 0x00000000, 0x77073096, 0xEE0E612C, 0x990951BA, 26 | 0x076DC419, 0x706AF48F, 0xE963A535, 0x9E6495A3, 27 | 0x0EDB8832, 0x79DCB8A4, 0xE0D5E91E, 0x97D2D988, 28 | 0x09B64C2B, 0x7EB17CBD, 0xE7B82D07, 0x90BF1D91, 29 | 0x1DB71064, 0x6AB020F2, 0xF3B97148, 0x84BE41DE, 30 | 0x1ADAD47D, 0x6DDDE4EB, 0xF4D4B551, 0x83D385C7, 31 | 0x136C9856, 0x646BA8C0, 0xFD62F97A, 0x8A65C9EC, 32 | 0x14015C4F, 0x63066CD9, 0xFA0F3D63, 0x8D080DF5, 33 | 0x3B6E20C8, 0x4C69105E, 0xD56041E4, 0xA2677172, 34 | 0x3C03E4D1, 0x4B04D447, 0xD20D85FD, 0xA50AB56B, 35 | 0x35B5A8FA, 0x42B2986C, 0xDBBBC9D6, 0xACBCF940, 36 | 0x32D86CE3, 0x45DF5C75, 0xDCD60DCF, 0xABD13D59, 37 | 0x26D930AC, 0x51DE003A, 0xC8D75180, 0xBFD06116, 38 | 0x21B4F4B5, 0x56B3C423, 0xCFBA9599, 0xB8BDA50F, 39 | 0x2802B89E, 0x5F058808, 0xC60CD9B2, 0xB10BE924, 40 | 0x2F6F7C87, 0x58684C11, 0xC1611DAB, 0xB6662D3D, 41 | 0x76DC4190, 0x01DB7106, 0x98D220BC, 0xEFD5102A, 42 | 0x71B18589, 0x06B6B51F, 0x9FBFE4A5, 0xE8B8D433, 43 | 0x7807C9A2, 0x0F00F934, 0x9609A88E, 0xE10E9818, 44 | 0x7F6A0DBB, 0x086D3D2D, 0x91646C97, 0xE6635C01, 45 | 0x6B6B51F4, 0x1C6C6162, 0x856530D8, 0xF262004E, 46 | 0x6C0695ED, 0x1B01A57B, 0x8208F4C1, 0xF50FC457, 47 | 0x65B0D9C6, 0x12B7E950, 0x8BBEB8EA, 0xFCB9887C, 48 | 0x62DD1DDF, 0x15DA2D49, 0x8CD37CF3, 0xFBD44C65, 49 | 0x4DB26158, 0x3AB551CE, 0xA3BC0074, 0xD4BB30E2, 50 | 0x4ADFA541, 0x3DD895D7, 0xA4D1C46D, 0xD3D6F4FB, 51 | 0x4369E96A, 0x346ED9FC, 0xAD678846, 0xDA60B8D0, 52 | 0x44042D73, 0x33031DE5, 0xAA0A4C5F, 0xDD0D7CC9, 53 | 0x5005713C, 0x270241AA, 0xBE0B1010, 0xC90C2086, 54 | 0x5768B525, 0x206F85B3, 0xB966D409, 0xCE61E49F, 55 | 0x5EDEF90E, 0x29D9C998, 0xB0D09822, 0xC7D7A8B4, 56 | 0x59B33D17, 0x2EB40D81, 0xB7BD5C3B, 0xC0BA6CAD, 57 | 0xEDB88320, 0x9ABFB3B6, 0x03B6E20C, 0x74B1D29A, 58 | 0xEAD54739, 0x9DD277AF, 0x04DB2615, 0x73DC1683, 59 | 0xE3630B12, 0x94643B84, 0x0D6D6A3E, 0x7A6A5AA8, 60 | 0xE40ECF0B, 0x9309FF9D, 0x0A00AE27, 0x7D079EB1, 61 | 0xF00F9344, 0x8708A3D2, 0x1E01F268, 0x6906C2FE, 62 | 0xF762575D, 0x806567CB, 0x196C3671, 0x6E6B06E7, 63 | 0xFED41B76, 0x89D32BE0, 0x10DA7A5A, 0x67DD4ACC, 64 | 0xF9B9DF6F, 0x8EBEEFF9, 0x17B7BE43, 0x60B08ED5, 65 | 0xD6D6A3E8, 0xA1D1937E, 0x38D8C2C4, 0x4FDFF252, 66 | 0xD1BB67F1, 0xA6BC5767, 0x3FB506DD, 0x48B2364B, 67 | 0xD80D2BDA, 0xAF0A1B4C, 0x36034AF6, 0x41047A60, 68 | 0xDF60EFC3, 0xA867DF55, 0x316E8EEF, 0x4669BE79, 69 | 0xCB61B38C, 0xBC66831A, 0x256FD2A0, 0x5268E236, 70 | 0xCC0C7795, 0xBB0B4703, 0x220216B9, 0x5505262F, 71 | 0xC5BA3BBE, 0xB2BD0B28, 0x2BB45A92, 0x5CB36A04, 72 | 0xC2D7FFA7, 0xB5D0CF31, 0x2CD99E8B, 0x5BDEAE1D, 73 | 0x9B64C2B0, 0xEC63F226, 0x756AA39C, 0x026D930A, 74 | 0x9C0906A9, 0xEB0E363F, 0x72076785, 0x05005713, 75 | 0x95BF4A82, 0xE2B87A14, 0x7BB12BAE, 0x0CB61B38, 76 | 0x92D28E9B, 0xE5D5BE0D, 0x7CDCEFB7, 0x0BDBDF21, 77 | 0x86D3D2D4, 0xF1D4E242, 0x68DDB3F8, 0x1FDA836E, 78 | 0x81BE16CD, 0xF6B9265B, 0x6FB077E1, 0x18B74777, 79 | 0x88085AE6, 0xFF0F6A70, 0x66063BCA, 0x11010B5C, 80 | 0x8F659EFF, 0xF862AE69, 0x616BFFD3, 0x166CCF45, 81 | 0xA00AE278, 0xD70DD2EE, 0x4E048354, 0x3903B3C2, 82 | 0xA7672661, 0xD06016F7, 0x4969474D, 0x3E6E77DB, 83 | 0xAED16A4A, 0xD9D65ADC, 0x40DF0B66, 0x37D83BF0, 84 | 0xA9BCAE53, 0xDEBB9EC5, 0x47B2CF7F, 0x30B5FFE9, 85 | 0xBDBDF21C, 0xCABAC28A, 0x53B39330, 0x24B4A3A6, 86 | 0xBAD03605, 0xCDD70693, 0x54DE5729, 0x23D967BF, 87 | 0xB3667A2E, 0xC4614AB8, 0x5D681B02, 0x2A6F2B94, 88 | 0xB40BBE37, 0xC30C8EA1, 0x5A05DF1B, 0x2D02EF8D ] 89 | -------------------------------------------------------------------------------- /src/Part04/FSFI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Part04.FSFI (module Part04.FSFI) where 5 | 6 | -- https://danluu.com/deconstruct-files/ 7 | 8 | import Control.Exception 9 | import Control.Monad (void) 10 | import Data.ByteString.Char8 (ByteString) 11 | import qualified Data.ByteString.Char8 as BS 12 | import Data.ByteString.Internal (fromForeignPtr, toForeignPtr) 13 | import Data.IORef 14 | import Data.Map (Map) 15 | import qualified Data.Map as Map 16 | import Data.Maybe (fromMaybe) 17 | import Data.Tuple (swap) 18 | import qualified Data.Vector as Vector 19 | import Foreign (copyBytes, plusPtr, withForeignPtr) 20 | import GHC.IO.Device (SeekMode(..)) 21 | import System.Directory 22 | import System.Posix.Files 23 | import System.Posix.IO.ByteString 24 | import System.Posix.Types 25 | import System.Posix.Unistd 26 | import System.Random 27 | import Test.QuickCheck 28 | import Test.QuickCheck.Monadic 29 | 30 | ------------------------------------------------------------------------ 31 | 32 | data FS = FS 33 | { fsOpenFd :: FilePath -> IO Fd 34 | , fsWrite :: Fd -> ByteString -> IO ByteCount 35 | , fsFsync :: Fd -> IO () 36 | , fsSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset 37 | , fsRead :: Fd -> ByteCount -> IO (ByteString, ByteCount) 38 | } 39 | 40 | realFS :: IO FS 41 | realFS = return FS 42 | { fsOpenFd = \fp -> openFd (BS.pack fp) ReadWrite 43 | (Just (ownerReadMode `unionFileModes` ownerWriteMode)) 44 | defaultFileFlags { append = True } 45 | , fsWrite = \fd bs -> fdWrite fd (BS.unpack bs) 46 | , fsFsync = fileSynchronise 47 | , fsSeek = fdSeek 48 | , fsRead = \fd bc -> fdRead fd bc >>= \(s, bc') -> return (BS.pack s, bc') 49 | } 50 | 51 | fsExample :: FS -> IO () 52 | fsExample fs = do 53 | fd <- fsOpenFd fs "/tmp/test.txt" 54 | void (fsWrite fs fd "hej") 55 | fsFsync fs fd 56 | void (fsSeek fs fd AbsoluteSeek 0) 57 | -- TODO: Second fsync. 58 | print =<< fsRead fs fd 3 59 | 60 | unit_realFS :: IO () 61 | unit_realFS = do 62 | fs <- realFS 63 | fsExample fs 64 | 65 | ------------------------------------------------------------------------ 66 | 67 | data FakeDisk = FakeDisk 68 | { fdFiles :: IORef (Map FilePath ByteString) 69 | , fdOpenFds :: IORef (Map Fd OpenFd) 70 | , fdNextFd :: IORef Fd 71 | } 72 | 73 | data OpenFd = OpenFd 74 | { ofdOffset :: COff 75 | , ofdFilePath :: FilePath 76 | } 77 | 78 | newFakeDisk :: IO FakeDisk 79 | newFakeDisk = FakeDisk <$> newIORef Map.empty <*> newIORef Map.empty <*> newIORef (Fd 0) 80 | 81 | fakeOpenFd :: FakeDisk -> FilePath -> IO Fd 82 | fakeOpenFd fdisk fp = do 83 | fd <- atomicModifyIORef' (fdNextFd fdisk) (\fd -> (fd + 1, fd)) 84 | -- Only add a file with empty content if there already isn't a file. 85 | modifyIORef (fdFiles fdisk) (Map.insertWith (<>) fp BS.empty) 86 | modifyIORef (fdOpenFds fdisk) (Map.insert fd (OpenFd 0 fp)) -- XXX: offset depends on opening mode? 87 | return fd 88 | 89 | adjustOffset :: Integral i => (i -> i) -> Fd -> Map Fd OpenFd -> Map Fd OpenFd 90 | adjustOffset f = Map.adjust (\(OpenFd offset fp) -> OpenFd (fromIntegral (f (fromIntegral offset))) fp) 91 | 92 | fakeWrite :: FakeDisk -> Fd -> ByteString -> IO ByteCount 93 | fakeWrite fdisk fd s = do 94 | ofd <- atomicModifyIORef' (fdOpenFds fdisk) (\ofds -> (adjustOffset (+ BS.length s) fd ofds, ofds Map.! fd)) 95 | mOldBs <- Map.lookup (ofdFilePath ofd) <$> readIORef (fdFiles fdisk) 96 | newBs <- write (ofdOffset ofd) s (fromMaybe BS.empty mOldBs) 97 | modifyIORef (fdFiles fdisk) (Map.insert (ofdFilePath ofd) newBs) 98 | return (fromIntegral (BS.length s)) 99 | 100 | write :: COff -> ByteString -> ByteString -> IO ByteString 101 | write off dst src = do 102 | let (dfptr, doff, dlen) = toForeignPtr dst 103 | (sfptr, soff, slen) = toForeignPtr src 104 | withForeignPtr dfptr $ \dptr -> 105 | withForeignPtr sfptr $ \sptr -> do 106 | copyBytes (dptr `plusPtr` (doff + fromIntegral off)) (sptr `plusPtr` soff) slen 107 | return (fromForeignPtr dfptr 0 (max dlen (fromIntegral off + slen))) 108 | 109 | prop_write :: NonNegative Int -> ASCIIString -> ASCIIString -> Property 110 | prop_write (NonNegative off) (ASCIIString dst) (ASCIIString src) = monadicIO $ do 111 | pre (off + length src <= length dst) 112 | bs <- run (write (fromIntegral off) (BS.pack dst) (BS.pack src)) 113 | let s' = write' dst src off 114 | monitor (counterexample ("'" ++ BS.unpack bs ++ "' /= '" ++ s' ++ "'")) 115 | Test.QuickCheck.Monadic.assert (BS.unpack bs == s') 116 | 117 | write' :: [a] -> [a] -> Int -> [a] 118 | write' dst src off = Vector.toList (Vector.fromList dst Vector.// zip [off..off+length src] src) 119 | 120 | fakeFsync :: FakeDisk -> Fd -> IO () 121 | fakeFsync _ _ = return () -- XXX 122 | 123 | fakeSeek :: FakeDisk -> Fd -> SeekMode -> FileOffset -> IO FileOffset 124 | fakeSeek fdisk fd _seekMode offset = do 125 | -- NOTE: Simplified, only absolute seek. 126 | modifyIORef (fdOpenFds fdisk) (adjustOffset (const offset) fd) 127 | return offset 128 | 129 | fakeRead :: FakeDisk -> Fd -> ByteCount -> IO (ByteString, ByteCount) 130 | fakeRead fdisk fd l = do 131 | ofds <- readIORef (fdOpenFds fdisk) 132 | let ofd = ofds Map.! fd 133 | files <- readIORef (fdFiles fdisk) 134 | let contents = files Map.! ofdFilePath ofd 135 | s = BS.take (fromIntegral l) (BS.drop (fromIntegral (ofdOffset ofd)) contents) 136 | print contents 137 | return (s, fromIntegral (BS.length s)) 138 | 139 | fakeFS :: IO FS 140 | fakeFS = do 141 | fdisk <- newFakeDisk 142 | return FS 143 | { fsOpenFd = fakeOpenFd fdisk 144 | , fsWrite = fakeWrite fdisk 145 | , fsFsync = fakeFsync fdisk 146 | , fsSeek = fakeSeek fdisk 147 | , fsRead = fakeRead fdisk 148 | } 149 | 150 | unit_fakeFS :: IO () 151 | unit_fakeFS = do 152 | fs <- fakeFS 153 | fsExample fs 154 | 155 | -- TODO: Contract test realFS against fakeFS. 156 | 157 | ------------------------------------------------------------------------ 158 | 159 | data CrashingFakeDisk = CrashingFakeDisk 160 | { cfdFakeDisk :: FakeDisk 161 | , cfdUnflushed :: IORef (Map Fd ByteString) -- Not yet flushed to the filesystem. 162 | , cfdStdGen :: IORef StdGen 163 | -- TODO: Add a way to configure the characteristics and distribution of the faults here. 164 | } 165 | 166 | newCrashingFakeDisk :: Int -> IO CrashingFakeDisk 167 | newCrashingFakeDisk seed = 168 | CrashingFakeDisk <$> newFakeDisk <*> newIORef Map.empty <*> newIORef (mkStdGen seed) 169 | 170 | partialWrite :: CrashingFakeDisk -> Fd -> ByteString -> IO ByteCount 171 | partialWrite cfdisk fd s = do 172 | -- NOTE: Simplified, write always appends to the end of the file... 173 | modifyIORef (cfdUnflushed cfdisk) (Map.insertWith (flip (<>)) fd s) 174 | return (fromIntegral (BS.length s)) 175 | 176 | partialFsync :: CrashingFakeDisk -> Fd -> IO () 177 | partialFsync cfdisk fd = do 178 | mUnflushed <- atomicModifyIORef' (cfdUnflushed cfdisk) (swap . Map.updateLookupWithKey (\_k _v -> Nothing) fd) 179 | case mUnflushed of 180 | Nothing -> return () -- Nothing to flush. 181 | Just unflushed -> do 182 | -- Dungeons and dragons style die roll where something bad happens if we throw a one. 183 | dieRoll <- atomicModifyIORef' (cfdStdGen cfdisk) (swap . randomR (1, 6 :: Int)) 184 | if dieRoll == 1 185 | then do 186 | -- NOTE: Simplified, doesn't have to be prefix. 187 | prefix <- atomicModifyIORef' (cfdStdGen cfdisk) (swap . randomR (0, BS.length unflushed - 1)) 188 | _bc <- fakeWrite (cfdFakeDisk cfdisk) fd (BS.take prefix unflushed) 189 | throwIO Crash 190 | else do 191 | _bc <- fakeWrite (cfdFakeDisk cfdisk) fd unflushed 192 | return () 193 | 194 | data Crash = Crash 195 | deriving stock Show 196 | 197 | instance Exception Crash 198 | 199 | crashingFS :: Int -> IO FS 200 | crashingFS seed = do 201 | cfdisk <- newCrashingFakeDisk seed 202 | return FS 203 | { fsOpenFd = fakeOpenFd (cfdFakeDisk cfdisk) 204 | , fsWrite = partialWrite cfdisk 205 | , fsFsync = partialFsync cfdisk 206 | , fsSeek = fakeSeek (cfdFakeDisk cfdisk) 207 | , fsRead = fakeRead (cfdFakeDisk cfdisk) 208 | } 209 | 210 | unit_crashingFS :: IO () 211 | unit_crashingFS = do 212 | let seed = 6 213 | fs <- crashingFS seed 214 | fsExample fs `catch` (\Crash -> handleCrash fs) 215 | where 216 | handleCrash fs = do 217 | fd <- fsOpenFd fs "/tmp/test.txt" 218 | void (fsSeek fs fd AbsoluteSeek 0) 219 | (s, _l) <- fsRead fs fd 3 220 | assertIO (s == "h") -- Partial write happened due to the crash. 221 | 222 | assertIO :: Bool -> IO () 223 | assertIO b = Control.Exception.assert b (return ()) 224 | 225 | ------------------------------------------------------------------------ 226 | 227 | -- TODO: Can we introduce a latency keeping fake disk which can simulate the 228 | -- performance improvement of using 1PC + C vs 2PC? 229 | -- https://www.redb.org/post/2022/07/26/faster-commits-with-1pcc-instead-of-2pc/ 230 | 231 | twoPhaseCommit :: FS -> FilePath -> ByteString -> IO () 232 | twoPhaseCommit fs fp s = do 233 | fd <- fsOpenFd fs fp 234 | -- We use one character for the length of the string. Ideally we should 235 | -- dedicate, say, 4 bytes for the length and encode a unsigned 32 bit integrer 236 | -- instead, so that we can write much larger strings. 237 | void (fsSeek fs fd AbsoluteSeek 1) 238 | void (fsWrite fs fd s) 239 | fsFsync fs fd 240 | -- Next two steps are "promote to primary", basically we want to atomically 241 | -- (writing one byte) mark that the data is now available. Note that if we 242 | -- write one byte the partiality of write will ensure that either it's written 243 | -- or not, i.e. atomic. There are atomic primitives for writing, say, unsinged 244 | -- 32 bit integers as well, if we would have used that as length. 245 | void (fsSeek fs fd AbsoluteSeek 0) 246 | void (fsWrite fs fd (BS.pack (show (BS.length s)))) 247 | fsFsync fs fd 248 | 249 | recover :: FS -> Fd -> IO () 250 | recover fs fd = do 251 | -- XXX: this read seems to segfault... 252 | (bs, _len) <- fsRead fs fd 1 253 | -- If the length hasn't been written, erase the rest of the content. 254 | if bs == BS.pack " " 255 | then return () -- void (fsWrite fs fd " ") 256 | else return () 257 | 258 | prop_recovery :: Int -> Property 259 | prop_recovery seed = monadicIO $ do 260 | let fp = "/tmp/prop_recovery.txt" 261 | run (removePathForcibly fp) 262 | fs <- run (crashingFS seed) 263 | -- NOTE: Simplified, since we are working with strings rather than 264 | -- bytestrings, one character (byte) can only represent 1-9 in ASCII. 265 | len <- pick (choose (1, 9)) 266 | s <- pick (BS.pack <$> vectorOf len (choose ('a', 'z'))) 267 | e <- run ((Right <$> twoPhaseCommit fs fp s) `catch` (\Crash -> do 268 | fd <- fsOpenFd fs fp 269 | recover fs fd 270 | Left <$> fsRead fs fd (fromIntegral len))) 271 | case e of 272 | Left (t, _len) -> 273 | Test.QuickCheck.Monadic.assert (s == t || t == "" || t == " ") -- No partial writes. 274 | Right () -> do 275 | fd <- run (fsOpenFd fs fp) 276 | (t, _len) <- run (fsRead fs fd (fromIntegral len)) 277 | Test.QuickCheck.Monadic.assert (s == t) 278 | 279 | -- run (removePathForcibly fp) 280 | 281 | -- segfaults: 282 | -- s = do { fs <- crashingFS 0; (Right <$> twoPhaseCommit fs "/tmp/recovery.txt" "hej") `catch` (\Crash -> Left <$> do { fd <- fsOpenFd fs "/tmp/recovery.txt"; recover fs fd; fsRead fs fd 3 }) } 283 | -------------------------------------------------------------------------------- /src/Part04/LineariseWithFault.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Part04.LineariseWithFault 7 | (module Part04.LineariseWithFault) where 8 | 9 | import Control.Concurrent.STM (TQueue, atomically, writeTQueue) 10 | import Data.Tree (Forest, Tree(Node)) 11 | import Test.QuickCheck hiding (Result) 12 | 13 | import Part01SMTesting (Command, Response) 14 | import Part02ConcurrentSMTesting (Pid(..)) 15 | 16 | ------------------------------------------------------------------------ 17 | 18 | newtype History' cmd resp = History [Operation' cmd resp] 19 | deriving stock (Show, Functor, Foldable) 20 | 21 | prettyHistory :: (Show cmd, Show resp) => History' cmd resp -> String 22 | prettyHistory = show 23 | 24 | type History = History' Command Response 25 | 26 | data FailureMode 27 | = FAIL 28 | | INFO 29 | deriving stock Show 30 | 31 | -- XXX: We probably don't want to use Pid = ThreadId here, because if we have an 32 | -- INFO we don't want any further operations executed by that Pid. 33 | data Operation' cmd resp 34 | = Invoke Pid cmd 35 | | Ok Pid resp 36 | | Fail Pid FailureMode (Maybe String {- the reason for failure if it exists -}) -- should this has a cmd? 37 | deriving stock (Show, Functor, Foldable) 38 | 39 | type Operation = Operation' Command Response 40 | 41 | appendHistory :: TQueue (Operation' cmd resp) -> Operation' cmd resp -> IO () 42 | appendHistory hist op = atomically (writeTQueue hist op) 43 | 44 | data Result resp 45 | = OkWithResponse resp 46 | | OkWithNoResponse 47 | deriving stock Show 48 | 49 | isValidConcurrentHistory :: History' cmd resp -> Either String () 50 | isValidConcurrentHistory (History xs) = go [] [] xs 51 | where 52 | go _runningPids _infoPids [] = Right () 53 | go runningPids infoPids (op:ops) = case op of 54 | Invoke pid _ 55 | | pid `elem` runningPids -> Left $ show pid ++ " is already running. Each pid should only run one command at a time." 56 | | pid `elem` infoPids -> Left $ show pid ++ " have already returned an INFO and shouldn't make any more comands. But we see an INVOKE." 57 | | otherwise -> go (pid:runningPids) infoPids ops 58 | Ok pid _ -> go (filter (/= pid) runningPids) infoPids ops 59 | Fail pid FAIL _reason -> go (filter (/= pid) runningPids) infoPids ops 60 | Fail pid INFO _reason -> go (filter (/= pid) runningPids) (pid:infoPids) ops 61 | 62 | interleavings :: History' cmd resp -> Forest (cmd, Result resp) 63 | interleavings (History []) = [] 64 | interleavings (History ops) | all (not . isOk) ops = [] 65 | where 66 | isOk :: Operation' cmd resp -> Bool 67 | isOk (Ok{}) = True 68 | isOk _ = False 69 | interleavings (History ops0) = 70 | [ Node (cmd, resp) (interleavings (History ops')) 71 | | (tid, cmd) <- takeInvocations ops0 72 | , (resp, ops') <- findResponse tid 73 | (filter1 (not . matchInvocation tid) ops0) 74 | ] 75 | where 76 | takeInvocations :: [Operation' cmd resp] -> [(Pid, cmd)] 77 | takeInvocations [] = [] 78 | takeInvocations ((Invoke pid cmd) : ops) = (pid, cmd) : takeInvocations ops 79 | takeInvocations ((Ok _pid _resp) : _) = [] 80 | takeInvocations ((Fail _pid _mode _reason) : ops) = takeInvocations ops 81 | 82 | findResponse :: Pid -> [Operation' cmd resp] -> [(Result resp, [Operation' cmd resp])] 83 | findResponse _pid [] = [] 84 | findResponse pid ((Ok pid' resp) : ops) | pid == pid' = [(OkWithResponse resp, ops)] 85 | findResponse pid ((Fail pid' mode _reason) : ops) 86 | | pid == pid' = case mode of 87 | FAIL -> [] 88 | INFO -> [(OkWithNoResponse, ops)] 89 | findResponse pid (op : ops) = 90 | [ (resp, op : ops') | (resp, ops') <- findResponse pid ops ] 91 | 92 | matchInvocation :: Pid -> Operation' cmd resp -> Bool 93 | matchInvocation pid (Invoke pid' _cmd) = pid == pid' 94 | matchInvocation _ _ = False 95 | 96 | filter1 :: (a -> Bool) -> [a] -> [a] 97 | filter1 _ [] = [] 98 | filter1 p (x : xs) | p x = x : filter1 p xs 99 | | otherwise = xs 100 | 101 | linearisable :: forall model cmd resp. Eq resp 102 | => (model -> cmd -> (model, resp)) -> model -> Forest (cmd, Result resp) -> Bool 103 | linearisable step0 model0 = any' (go model0) 104 | where 105 | go :: model -> Tree (cmd, Result resp) -> Bool 106 | go model (Node (cmd, mresp) ts) = 107 | let 108 | (model', resp') = step0 model cmd 109 | in case mresp of 110 | OkWithResponse resp -> resp == resp' && any' (go model') ts 111 | OkWithNoResponse -> any' (go model') ts 112 | 113 | any' :: (a -> Bool) -> [a] -> Bool 114 | any' _p [] = True 115 | any' p xs = any p xs 116 | 117 | linearise :: forall model cmd resp. Eq resp 118 | => (model -> cmd -> (model, resp)) -> model -> History' cmd resp -> Bool 119 | linearise step0 model0 history = case isValidConcurrentHistory history of 120 | Left err -> error err 121 | Right () -> linearisable step0 model0 (interleavings history) 122 | 123 | 124 | -------------------------------------------------------------------------------- 125 | -- Testing 126 | -------------------------------------------------------------------------------- 127 | 128 | example :: History' String String 129 | example = History 130 | [ Invoke p0 "A" 131 | , Invoke p2 "B" 132 | , Invoke p1 "C" 133 | , Ok p0 "RA" 134 | , Fail p2 INFO (Just "timeout") 135 | , Invoke p0 "D" 136 | , Ok p1 "RC" 137 | , Ok p0 "RD" 138 | ] 139 | where 140 | p0 = Pid 0 141 | p1 = Pid 1 142 | p2 = Pid 2 143 | 144 | -------------------------------------------------------------------------------- 145 | -- QuickCheck 146 | -------------------------------------------------------------------------------- 147 | 148 | data LinearEvent cmd resp = LinearEvent Pid cmd resp 149 | deriving stock Show 150 | 151 | data PidStatus cmd resp 152 | = DoingNothing 153 | | MadeRequest cmd 154 | | CommitedRequest cmd (Maybe resp) 155 | | FailedRequest cmd 156 | 157 | -- selectOne will pick a random element, and also give the remaining elements 158 | -- could use NonEmpty but error is fine for now 159 | selectOne :: [x] -> Gen (x,[x]) 160 | selectOne [] = error "selectOne requires at least one element" 161 | selectOne xs = do 162 | i <- chooseInt (0, length xs - 1) 163 | -- we could have a specialised function for this that would have better performance 164 | return (xs !! i, take i xs ++ drop (succ i) xs) 165 | 166 | genHistory :: forall model cmd resp. 167 | (model -> cmd -> (model, resp)) -> model -> Gen cmd 168 | -> Int -> [Pid] -> Gen (History' cmd resp, [LinearEvent cmd resp]) 169 | genHistory step0 model0 genC nrOfNewPids pids0 = sized $ go [] [] model0 (zip pids0 $ repeat DoingNothing) nextPid0 170 | where 171 | nextPid0 = nextPid (maximum pids0) 172 | lastPid = foldr (.) id (replicate nrOfNewPids nextPid) $ nextPid0 173 | nextPid (Pid p) = Pid (succ p) 174 | go1 :: [Operation' cmd resp] -> [LinearEvent cmd resp] -> model 175 | -> Pid -> PidStatus cmd resp -> Bool 176 | -> Gen ( [Operation' cmd resp] 177 | , [LinearEvent cmd resp] 178 | , model 179 | , Maybe (PidStatus cmd resp) 180 | , Bool) 181 | go1 conc linear model pid state shouldStartNew = case state of 182 | DoingNothing 183 | | shouldStartNew -> do 184 | cmd <- genC 185 | return (Invoke pid cmd:conc, linear, model, Just $ MadeRequest cmd, True) 186 | | otherwise -> return (conc, linear, model, Nothing, False) 187 | MadeRequest cmd -> frequency 188 | [ (10, do -- request succeed, and response arrived 189 | let (model', resp) = step0 model cmd 190 | return (conc, LinearEvent pid cmd resp:linear, model', Just $ CommitedRequest cmd (Just resp), False) 191 | ) 192 | , (1, do -- request succeed, but response failed 193 | let (model', resp) = step0 model cmd 194 | return (conc, LinearEvent pid cmd resp:linear, model', Just $ CommitedRequest cmd Nothing, False) 195 | ) 196 | , (1, do -- request fails 197 | return (conc, linear, model, Just $ FailedRequest cmd, False) 198 | )] 199 | CommitedRequest _cmd mresp -> do 200 | let op = case mresp of 201 | Nothing -> Fail pid INFO Nothing 202 | Just resp-> Ok pid resp 203 | return (op:conc, linear, model, fmap (const DoingNothing) mresp, False) 204 | FailedRequest _cmd -> 205 | return (Fail pid INFO Nothing :conc, linear, model, Nothing, False) 206 | 207 | go conc linear _model [] _npid _size = pure (History $ reverse conc, reverse linear) 208 | go conc linear model pids npid size = do 209 | ((pid, state), pids') <- selectOne pids 210 | (conc', linear', model', status, shouldChangeSize) <- go1 conc linear model pid state (0 < size) 211 | let (pids'', npid') = case status of 212 | Nothing 213 | | size <= 0 || npid >= lastPid -> (pids', npid) 214 | | otherwise -> ((npid, DoingNothing):pids', nextPid npid) 215 | Just s -> ((pid,s):pids', npid) 216 | size' = if shouldChangeSize then pred size else size 217 | go conc' linear' model' pids'' npid' size' 218 | 219 | type SimpleModel = [Int] 220 | 221 | smStep :: SimpleModel -> Int -> (SimpleModel, [Int]) 222 | smStep xs x = (x:xs, x:xs) 223 | 224 | smModel :: SimpleModel 225 | smModel = [] 226 | 227 | prop_genHistory :: [Pid] -> Int -> Property 228 | prop_genHistory pids nrOfNewPids = 229 | forAll (genHistory smStep smModel arbitrary nrOfNewPids pids) $ \(ch, _) -> 230 | case isValidConcurrentHistory ch of 231 | Left err -> counterexample err False 232 | Right () -> property True 233 | 234 | prop_linearise :: [Pid] -> Int -> Property 235 | prop_linearise pids nrOfNewPids = 236 | forAll (genHistory smStep smModel arbitrary nrOfNewPids pids) $ \(ch, _) -> 237 | linearise smStep smModel ch 238 | -------------------------------------------------------------------------------- /tools/generate_changelog.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runghc 2 | 3 | import Control.Monad 4 | import Data.Char 5 | import Data.List 6 | import Data.Map (Map) 7 | import qualified Data.Map as Map 8 | import qualified Data.Set as Set 9 | import System.Environment 10 | import System.Exit 11 | import System.Process 12 | 13 | ------------------------------------------------------------------------ 14 | 15 | main :: IO () 16 | main = do 17 | args <- getArgs 18 | unless (length args == 1 || length args == 2) printHelp 19 | let fromTag = args !! 0 20 | toTag | length args == 1 = "HEAD" 21 | | otherwise = args !! 1 22 | gitLog <- readProcess "git" 23 | [ "log" 24 | , fromTag ++ ".." ++ toTag 25 | , "--no-merges" 26 | , "--pretty=format:%s ([%h](" ++ repoUrl ++ "/commit/%H))" 27 | ] 28 | "" 29 | date <- readProcess "date" ["+%Y-%m-%d"] "" 30 | putStrLn (concat 31 | [ "## [", toTag, "](", repoUrl, "/compare/", fromTag, "...", toTag, ")" 32 | , " (" ++ dropWhileEnd isSpace date ++ ")"]) 33 | putStrLn "" 34 | putStrLn (prettyBucket (createBucket (lines gitLog))) 35 | 36 | repoUrl :: String 37 | repoUrl = "https://github.com/stevana/property-based-testing-stateful-systems-tutorial" 38 | 39 | printHelp :: IO () 40 | printHelp = do 41 | progName <- getProgName 42 | putStrLn (progName ++ ": []") 43 | exitFailure 44 | 45 | ------------------------------------------------------------------------ 46 | 47 | type Bucket = Map String [String] 48 | 49 | createBucket :: [String] -> Bucket 50 | createBucket = foldl insertBucket Map.empty 51 | 52 | knownCategories :: Map String String 53 | knownCategories = Map.fromList 54 | [ ("test", "Testing improvements") 55 | , ("feat", "New features") 56 | , ("add", "New features") 57 | , ("fix", "Bug fixes") 58 | , ("bug", "Bug fixes") 59 | , ("perf", "Performance improvements") 60 | , ("pref", "Performance improvements") 61 | , ("roadmap", "Documentation improvements") 62 | , ("readme", "Documentation improvements") 63 | , ("docs", "Documentation improvements") 64 | , ("doc", "Documentation improvements") 65 | , ("changelog", "Documentation improvements") 66 | , ("nix", "Build improvements") 67 | , ("bazel", "Build improvements") 68 | , ("build", "Build improvements") 69 | , ("remove", "Removed features") 70 | , ("cleanup", "Removed features") 71 | , ("refactor", "Refactorings") 72 | , ("ci", "CI improvements") 73 | ] 74 | 75 | insertBucket :: Bucket -> String -> Bucket 76 | insertBucket bucket line = 77 | let 78 | (tag, _colon : message) = break (== ':') line 79 | (category, context) = span (/= '(') tag 80 | message' = dropWhile isSpace message 81 | context' = "**" ++ dropWhileEnd (==')') (dropWhile (=='(') context) ++ "**: " 82 | context'' | context' == "****: " = "" 83 | | otherwise = context' 84 | in 85 | if category `Set.member` Map.keysSet knownCategories 86 | then 87 | Map.insertWith (++) (knownCategories Map.! category) 88 | [ "* " ++ context'' ++ message' ] bucket 89 | else 90 | Map.insertWith (++) "Uncategorised" [ "* " ++ line ] bucket 91 | 92 | prettyBucket :: Bucket -> String 93 | prettyBucket bucket = unlines 94 | [ unlines (("### " ++ category) : reverse items) 95 | | (category, items) <- Map.toList bucket 96 | ] 97 | -------------------------------------------------------------------------------- /tools/generate_markdown.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -euo pipefail 4 | if [[ "${TRACE-0}" == "1" ]]; then set -o xtrace; fi 5 | 6 | SCRATCH=${SCRATCH:-"/tmp/pbt-stateful-systems"} 7 | 8 | # Change directory to the root directory of this repo. Taken from: 9 | # https://stackoverflow.com/a/246128/3858681 10 | DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" > /dev/null 2>&1 && pwd )" 11 | pushd "${DIR}/.." > /dev/null 12 | 13 | PANDOC="pandoc --wrap=none --highlight-style=kate" 14 | 15 | # Backup old docs before replacing them. 16 | mv ./docs "${SCRATCH}-docs-backup-$(date +%s)" 17 | mkdir -p docs 18 | 19 | for file in src/*.lhs; do 20 | ${PANDOC} --from markdown+lhs --to gfm "${file}" > "docs/$(basename ${file} .lhs).md" 21 | sed -i 's/``` {.haskell .literate}/```haskell/' "docs/$(basename ${file} .lhs).md" 22 | done 23 | 24 | if [[ "${1:-}" == "--preview-html" ]]; then 25 | 26 | mkdir -p "${SCRATCH}-html-preview/docs" 27 | 28 | ${PANDOC} --from gfm --to html README.md > "${SCRATCH}-html-preview/README.html" 29 | sed -i 's/.md/.html/g' "${SCRATCH}-html-preview/README.html" 30 | 31 | cp -r images/ "${SCRATCH}-html-preview/" 32 | 33 | for file in docs/*.md; do 34 | ${PANDOC} --from gfm --to html "${file}" > \ 35 | "${SCRATCH}-html-preview/docs/$(basename ${file} .md).html" 36 | sed -i 's/.md/.html/g' "${SCRATCH}-html-preview/docs/$(basename ${file} .md).html" 37 | done 38 | 39 | echo "Preview unstyled HTML: ${SCRATCH}-html-preview/README.html" 40 | 41 | fi 42 | 43 | popd > /dev/null 44 | --------------------------------------------------------------------------------