diff options
| -rw-r--r-- | pbt/stateful-pbt/CHANGELOG.md | 5 | ||||
| -rw-r--r-- | pbt/stateful-pbt/LICENSE | 29 | ||||
| -rw-r--r-- | pbt/stateful-pbt/stateful-pbt.cabal | 77 | ||||
| -rw-r--r-- | pbt/stateful-pbt/test/Exalt/APISpec.hs | 140 | ||||
| -rw-r--r-- | pbt/stateful-pbt/test/Main.hs | 4 | ||||
| -rw-r--r-- | pbt/stateful-pbt/test/Spec.hs | 1 |
6 files changed, 256 insertions, 0 deletions
diff --git a/pbt/stateful-pbt/CHANGELOG.md b/pbt/stateful-pbt/CHANGELOG.md new file mode 100644 index 0000000..c0c808b --- /dev/null +++ b/pbt/stateful-pbt/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for stateful-pbt + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/pbt/stateful-pbt/LICENSE b/pbt/stateful-pbt/LICENSE new file mode 100644 index 0000000..aedae6a --- /dev/null +++ b/pbt/stateful-pbt/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2025, Arnaud Bailly + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/pbt/stateful-pbt/stateful-pbt.cabal b/pbt/stateful-pbt/stateful-pbt.cabal new file mode 100644 index 0000000..6af9056 --- /dev/null +++ b/pbt/stateful-pbt/stateful-pbt.cabal @@ -0,0 +1,77 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.1. +-- +-- see: https://github.com/sol/hpack + +name: stateful-pbt +version: 0.1.0.0 +description: Please see the README on Github at <https://github.com/abailly/xxi-century-typed/minilang#readme> +homepage: https://github.com/abailly/minilang#readme +bug-reports: https://github.com/abailly/minilang/issues +author: Arnaud Bailly +maintainer: arnaud@pankzsoft.com +copyright: 2025 Arnaud Bailly +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/abailly/minilang + +library + exposed-modules: + hs-source-dirs: + src + default-extensions: + DeriveGeneric + OverloadedStrings + FlexibleInstances + MultiParamTypeClasses + FlexibleContexts + RecordWildCards + NamedFieldPuns + GeneralizedNewtypeDeriving + ghc-options: -Wall -fno-warn-orphans + build-depends: + aeson + , async + , base + default-language: Haskell2010 + +test-suite minilang-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Exalt.APISpec + hs-source-dirs: + test + default-extensions: + DeriveGeneric + OverloadedStrings + FlexibleInstances + MultiParamTypeClasses + FlexibleContexts + RecordWildCards + NamedFieldPuns + GeneralizedNewtypeDeriving + ghc-options: -Wall -fno-warn-orphans -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + QuickCheck + , base + , base16-bytestring + , bytestring + , containers + , data-default + , directory + , exceptions + , filepath + , haskeline + , hspec + default-language: Haskell2010 diff --git a/pbt/stateful-pbt/test/Exalt/APISpec.hs b/pbt/stateful-pbt/test/Exalt/APISpec.hs new file mode 100644 index 0000000..dd89f2c --- /dev/null +++ b/pbt/stateful-pbt/test/Exalt/APISpec.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Basic implementation of some stateful Property-Based Testing for +-- modelling/simulating some banking "Mainframe" API. +-- +-- This "coding kata" was triggered Johan Martinsson and Mathieu Cans' +-- workshop at NewCrafts 2025, where they detailed the practice of +-- replacing mocks in testing with larger scale _integration tests_ +-- using simulators instead of the real implementation at adapters' +-- boundaries. +-- +-- It seems to me this idea is pretty close to the "common" practice in +-- FP-land to _model_ "effects" and use those models through _Stateful +-- Property-Based Testing_ to ensure implementation's conform to its +-- model. This makes it possible to then use the _model_ as a +-- _simulator_ in integration scenarios, but with a much wider range +-- of possible behaviours tested and exercised. +-- +-- Note there's nothing new here, and it's even something I presented +-- years ago with Nicole Rausch at DDDEurope under the "catchy" name +-- of ["Homomorphic Event +-- Sourcing"](https://www.youtube.com/watch?v=KyOvBQ87aP4), in a more +-- confused way. +module Exalt.APISpec where + +import Control.Monad (replicateM) +import Data.IORef (atomicModifyIORef', newIORef, readIORef) +import qualified Data.Map as Map +import Data.String (IsString) +import Test.Hspec (Spec, it, shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary (..), NonEmptyList (..), choose, elements, forAll) + +newtype Amount = EUR Int deriving (Eq, Show, Ord, Num) + +instance Arbitrary Amount where + arbitrary = do + value <- choose (0, 100000) + return (EUR value) + +newtype AccountNumber = AccountNumber String deriving (Eq, Show, Ord, IsString) + +instance Arbitrary AccountNumber where + arbitrary = do + digits <- replicateM 22 (choose ('0', '9')) + country <- elements ["DE", "FR", "GB", "ES", "IT"] + return (AccountNumber (country ++ digits)) + +newtype MainframeApiError = InsufficientFunds Amount deriving (Eq, Show) + +data MainframeApi = MainframeApi + { deposit :: AccountNumber -> Amount -> IO (Either MainframeApiError ()), + withdraw :: AccountNumber -> Amount -> IO (Either MainframeApiError ()), + balance :: AccountNumber -> IO (Either MainframeApiError Amount) + } + +initMainframeApi :: [(AccountNumber, Amount)] -> IO MainframeApi +initMainframeApi initialAccounts = do + ref <- newIORef $ Map.fromList initialAccounts + -- Initialize the mainframe API with existing accounts + return + MainframeApi + { deposit = \accountNo amount -> do + atomicModifyIORef' ref $ \accountMap -> + case Map.lookup accountNo accountMap of + Just currentAmount -> + let newAmount = currentAmount + amount + in (Map.insert accountNo newAmount accountMap, Right ()) + Nothing -> undefined, + withdraw = \accountNo amount -> do + atomicModifyIORef' ref $ \accountMap -> + case Map.lookup accountNo accountMap of + Just currentAmount + | amount > currentAmount -> + (accountMap, Left $ InsufficientFunds currentAmount) -- Insufficient funds + Just currentAmount -> + let newAmount = currentAmount - amount + in (Map.insert accountNo newAmount accountMap, Right ()) + Nothing -> undefined, + balance = \accountNo -> do + readIORef ref >>= \accountMap -> + return $ + maybe undefined Right $ + Map.lookup accountNo accountMap + } + +spec :: Spec +spec = do + let accountNumber = "DE89370400440532013000" + hundredEuros = EUR 10000 + + it "can deposit 100 EUR given an existing account" $ do + mainframeApi <- initMainframeApi [(accountNumber, hundredEuros)] + + Right result <- deposit mainframeApi accountNumber hundredEuros + + result `shouldBe` () + + prop "can retrieve balance given an existing account with 100 EUR" $ + forAll arbitrary $ \(NonEmpty accounts) -> + forAll (elements accounts) $ \(accountNo, amount) -> do + mainframeApi <- initMainframeApi accounts + + Right balance <- balance mainframeApi accountNo + + balance `shouldBe` amount + + prop "depositing any amount on existing account increases balance" $ + forAll arbitrary $ \(NonEmpty accounts) -> + forAll (elements accounts) $ \(accountNo, initialAmount) -> + forAll arbitrary $ \depositAmount -> do + mainframeApi <- initMainframeApi accounts + + Right () <- deposit mainframeApi accountNo depositAmount + Right newBalance <- balance mainframeApi accountNo + + newBalance `shouldBe` (initialAmount + depositAmount) + + prop "can withdraw up-to available balance of any account" $ + forAll arbitrary $ \(NonEmpty accounts) -> + forAll (elements accounts) $ \(accountNo, initialAmount@(EUR initialValue)) -> + forAll (EUR <$> choose (0, initialValue)) $ \withdrawal -> do + mainframeApi <- initMainframeApi accounts + + Right () <- withdraw mainframeApi accountNo withdrawal + Right newBalance <- balance mainframeApi accountNo + + newBalance `shouldBe` (initialAmount - withdrawal) + + prop "cannot withdraw more than available balance of any account" $ + forAll arbitrary $ \(NonEmpty accounts) -> + forAll (elements accounts) $ \(accountNo, initialAmount@(EUR initialValue)) -> + forAll (EUR <$> choose (initialValue + 1, initialValue + 100000)) $ \withdrawal -> do + mainframeApi <- initMainframeApi accounts + + result <- withdraw mainframeApi accountNo withdrawal + + case result of + Left (InsufficientFunds amount) -> amount `shouldBe` initialAmount + Right _ -> error "Expected withdrawal to fail due to insufficient funds" diff --git a/pbt/stateful-pbt/test/Main.hs b/pbt/stateful-pbt/test/Main.hs new file mode 100644 index 0000000..3e2059e --- /dev/null +++ b/pbt/stateful-pbt/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/pbt/stateful-pbt/test/Spec.hs b/pbt/stateful-pbt/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/pbt/stateful-pbt/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} |