Add two more Haskell examples (with their note files)

This commit is contained in:
Hassan Abedi 2026-04-28 16:06:25 +02:00
parent f517fa533f
commit 87d02e8bc2
17 changed files with 802 additions and 0 deletions

View File

@ -0,0 +1,25 @@
# 30-haskell-traverse-resolution
This example shows intermediate Haskell batch resolution with `traverse`.
It includes:
- a deployment request type parsed from compact CLI input,
- a service catalog with per-service release metadata,
- one `traverse` pass that resolves every request or fails the whole batch, and
- a test suite run by `nix flake check`.
Useful commands:
```bash
nix develop
cabal run
cabal run -- api:production:stable worker:staging:candidate auth:production:stable
cabal test
nix build
./result/bin/mini-resolution api:production:stable worker:staging:candidate auth:production:stable
nix run . -- api:production:stable worker:staging:candidate auth:production:stable
nix flake check
```

View File

@ -0,0 +1,29 @@
module Main where
import MiniResolution.Plan
( catalog
, parseRequest
, renderPlan
, resolveRequests
)
import System.Environment (getArgs)
import System.Exit (die)
main :: IO ()
main = do
args <- getArgs
let inputArgs =
case args of
[] ->
[ "api:production:stable"
, "worker:staging:candidate"
, "auth:production:stable"
]
_ -> args
case traverse parseRequest inputArgs of
Left err -> die err
Right requests ->
case resolveRequests catalog requests of
Left err -> die err
Right deployments -> putStrLn (renderPlan deployments)

View File

@ -0,0 +1,27 @@
{
"nodes": {
"nixpkgs": {
"locked": {
"lastModified": 1776548001,
"narHash": "sha256-ZSK0NL4a1BwVbbTBoSnWgbJy9HeZFXLYQizjb2DPF24=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "b12141ef619e0a9c1c84dc8c684040326f27cdcc",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixos-unstable",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"nixpkgs": "nixpkgs"
}
}
},
"root": "root",
"version": 7
}

View File

@ -0,0 +1,38 @@
{
# Builds a Haskell project that resolves a batch of deployment requests
# against a service catalog with traverse.
description = "A Haskell project for traverse-based resolution";
inputs = {
nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
};
outputs =
{ self, nixpkgs, ... }:
let
system = "x86_64-linux";
pkgs = import nixpkgs { inherit system; };
inherit (pkgs) haskellPackages;
project = haskellPackages.callCabal2nix "mini-resolution" ./. { };
checkedProject = pkgs.haskell.lib.doCheck project;
in
{
packages.${system}.default = project;
apps.${system}.default = {
type = "app";
program = "${self.packages.${system}.default}/bin/mini-resolution";
meta.description = "Run the traverse-based release resolution example.";
};
devShells.${system}.default = pkgs.mkShell {
packages = [
haskellPackages.ghc
pkgs.cabal-install
pkgs.haskell-language-server
];
};
checks.${system}.test-suite = checkedProject;
};
}

View File

@ -0,0 +1,29 @@
cabal-version: 2.4
name: mini-resolution
version: 0.1.0.0
build-type: Simple
library
exposed-modules: MiniResolution.Plan
hs-source-dirs: src
build-depends:
base >=4.14 && <5,
containers
default-language: Haskell2010
executable mini-resolution
main-is: Main.hs
hs-source-dirs: app
build-depends:
base >=4.14 && <5,
mini-resolution
default-language: Haskell2010
test-suite mini-resolution-test
type: exitcode-stdio-1.0
main-is: Main.hs
hs-source-dirs: test
build-depends:
base >=4.14 && <5,
mini-resolution
default-language: Haskell2010

View File

@ -0,0 +1,158 @@
module MiniResolution.Plan where
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.List (intercalate)
data Environment
= Staging
| Production
deriving (Eq, Ord, Show)
data ReleaseTrack
= Stable
| Candidate
deriving (Eq, Show)
data DeploymentRequest = DeploymentRequest
{ requestService :: String
, requestEnvironment :: Environment
, requestTrack :: ReleaseTrack
}
deriving (Eq, Show)
data ServiceProfile = ServiceProfile
{ imageRepository :: String
, stableTag :: String
, candidateTag :: Maybe String
, defaultReplicas :: Int
, supportsProduction :: Bool
}
deriving (Eq, Show)
data ResolvedDeployment = ResolvedDeployment
{ resolvedService :: String
, resolvedEnvironment :: Environment
, resolvedImage :: String
, resolvedReplicas :: Int
, approvalRequired :: Bool
}
deriving (Eq, Show)
type Catalog = Map String ServiceProfile
catalog :: Catalog
catalog =
Map.fromList
[ ( "api"
, ServiceProfile
{ imageRepository = "registry.example/api"
, stableTag = "2026.04.1"
, candidateTag = Just "2026.05-rc1"
, defaultReplicas = 3
, supportsProduction = True
}
)
, ( "worker"
, ServiceProfile
{ imageRepository = "registry.example/worker"
, stableTag = "2026.04.0"
, candidateTag = Just "2026.05-beta2"
, defaultReplicas = 2
, supportsProduction = False
}
)
, ( "auth"
, ServiceProfile
{ imageRepository = "registry.example/auth"
, stableTag = "2026.04.3"
, candidateTag = Nothing
, defaultReplicas = 4
, supportsProduction = True
}
)
]
parseRequest :: String -> Either String DeploymentRequest
parseRequest rawRequest =
case splitOn ':' rawRequest of
[serviceName, environmentName, trackName] ->
DeploymentRequest
<$> pure serviceName
<*> parseEnvironment environmentName
<*> parseTrack trackName
_ -> Left ("expected <service>:<environment>:<stable|candidate>, got: " ++ rawRequest)
resolveRequests :: Catalog -> [DeploymentRequest] -> Either String [ResolvedDeployment]
resolveRequests serviceCatalog = traverse (resolveRequest serviceCatalog)
resolveRequest :: Catalog -> DeploymentRequest -> Either String ResolvedDeployment
resolveRequest serviceCatalog request = do
serviceProfile <-
case Map.lookup (requestService request) serviceCatalog of
Just profile -> Right profile
Nothing -> Left ("unknown service: " ++ requestService request)
imageTag <- resolveTag (requestTrack request) serviceProfile
ensureEnvironmentAllowed (requestEnvironment request) serviceProfile
pure
ResolvedDeployment
{ resolvedService = requestService request
, resolvedEnvironment = requestEnvironment request
, resolvedImage = imageRepository serviceProfile ++ ":" ++ imageTag
, resolvedReplicas = defaultReplicas serviceProfile
, approvalRequired =
requestEnvironment request == Production
&& requestTrack request == Candidate
}
resolveTag :: ReleaseTrack -> ServiceProfile -> Either String String
resolveTag Stable serviceProfile = Right (stableTag serviceProfile)
resolveTag Candidate serviceProfile =
case candidateTag serviceProfile of
Just tagValue -> Right tagValue
Nothing -> Left ("service does not publish candidate images: " ++ imageRepository serviceProfile)
ensureEnvironmentAllowed :: Environment -> ServiceProfile -> Either String ()
ensureEnvironmentAllowed Staging _ = Right ()
ensureEnvironmentAllowed Production serviceProfile
| supportsProduction serviceProfile = Right ()
| otherwise = Left ("service is staging-only: " ++ imageRepository serviceProfile)
renderPlan :: [ResolvedDeployment] -> String
renderPlan = unlines . map renderDeployment
renderDeployment :: ResolvedDeployment -> String
renderDeployment deployment =
intercalate
", "
[ resolvedService deployment ++ " -> " ++ renderEnvironment (resolvedEnvironment deployment)
, "image " ++ resolvedImage deployment
, "replicas " ++ show (resolvedReplicas deployment)
, "approval " ++ renderApproval (approvalRequired deployment)
]
parseEnvironment :: String -> Either String Environment
parseEnvironment "staging" = Right Staging
parseEnvironment "production" = Right Production
parseEnvironment otherValue = Left ("unknown environment: " ++ otherValue)
parseTrack :: String -> Either String ReleaseTrack
parseTrack "stable" = Right Stable
parseTrack "candidate" = Right Candidate
parseTrack otherValue = Left ("unknown track: " ++ otherValue)
renderEnvironment :: Environment -> String
renderEnvironment Staging = "staging"
renderEnvironment Production = "production"
renderApproval :: Bool -> String
renderApproval True = "required"
renderApproval False = "not-required"
splitOn :: Char -> String -> [String]
splitOn separator = go []
where
go current [] = [reverse current]
go current (nextChar : remainingChars)
| nextChar == separator = reverse current : go [] remainingChars
| otherwise = go (nextChar : current) remainingChars

View File

@ -0,0 +1,39 @@
module Main where
import MiniResolution.Plan
( Environment (Production, Staging)
, ReleaseTrack (Candidate, Stable)
, ResolvedDeployment (ResolvedDeployment)
, catalog
, parseRequest
, renderPlan
, resolveRequests
)
import System.Exit (die)
main :: IO ()
main =
case traverse parseRequest ["api:production:stable", "worker:staging:candidate", "auth:production:stable"] of
Left err -> die err
Right requests ->
case
( resolveRequests catalog requests
, traverse parseRequest ["worker:production:stable"] >>= resolveRequests catalog
) of
( Right
[ ResolvedDeployment "api" Production "registry.example/api:2026.04.1" 3 False
, ResolvedDeployment "worker" Staging "registry.example/worker:2026.05-beta2" 2 False
, ResolvedDeployment "auth" Production "registry.example/auth:2026.04.3" 4 False
]
, Left _
) | "auth -> production, image registry.example/auth:2026.04.3, replicas 4, approval not-required"
`elem`
lines
( renderPlan
[ ResolvedDeployment "api" Production "registry.example/api:2026.04.1" 3 False
, ResolvedDeployment "worker" Staging "registry.example/worker:2026.05-beta2" 2 False
, ResolvedDeployment "auth" Production "registry.example/auth:2026.04.3" 4 False
]
) ->
putStrLn "test passed"
_ -> die "unexpected traverse resolution result"

View File

@ -0,0 +1,25 @@
# 31-haskell-writer-audit
This example shows intermediate Haskell rollout simulation with `Writer`.
It includes:
- a release job with rollout modes and replica counts,
- a `Writer [String]` audit trail that records ordered rollout events,
- a final rollout report computed alongside the log, and
- a test suite run by `nix flake check`.
Useful commands:
```bash
nix develop
cabal run
cabal run -- api:production:canary:20:3 worker:staging:rolling:0:2
cabal test
nix build
./result/bin/mini-audit api:production:canary:20:3 worker:staging:rolling:0:2
nix run . -- api:production:canary:20:3 worker:staging:rolling:0:2
nix flake check
```

View File

@ -0,0 +1,29 @@
module Main where
import MiniAudit.Rollout
( parseJob
, renderAudit
, renderReport
, runRollout
)
import System.Environment (getArgs)
import System.Exit (die)
main :: IO ()
main = do
args <- getArgs
let inputArgs =
case args of
[] -> ["api:production:canary:20:3", "worker:staging:rolling:0:2"]
_ -> args
case traverse parseJob inputArgs of
Left err -> die err
Right jobs ->
mapM_
( \job -> do
let (report, auditLog) = runRollout job
putStrLn (renderReport report)
putStrLn (renderAudit auditLog)
)
jobs

27
31-haskell-writer-audit/flake.lock generated Normal file
View File

@ -0,0 +1,27 @@
{
"nodes": {
"nixpkgs": {
"locked": {
"lastModified": 1776548001,
"narHash": "sha256-ZSK0NL4a1BwVbbTBoSnWgbJy9HeZFXLYQizjb2DPF24=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "b12141ef619e0a9c1c84dc8c684040326f27cdcc",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixos-unstable",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"nixpkgs": "nixpkgs"
}
}
},
"root": "root",
"version": 7
}

View File

@ -0,0 +1,38 @@
{
# Builds a Haskell project that simulates a rollout with Writer-based
# audit logging.
description = "A Haskell project for Writer audit trails";
inputs = {
nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
};
outputs =
{ self, nixpkgs, ... }:
let
system = "x86_64-linux";
pkgs = import nixpkgs { inherit system; };
inherit (pkgs) haskellPackages;
project = haskellPackages.callCabal2nix "mini-audit" ./. { };
checkedProject = pkgs.haskell.lib.doCheck project;
in
{
packages.${system}.default = project;
apps.${system}.default = {
type = "app";
program = "${self.packages.${system}.default}/bin/mini-audit";
meta.description = "Run the Writer-based rollout audit example.";
};
devShells.${system}.default = pkgs.mkShell {
packages = [
haskellPackages.ghc
pkgs.cabal-install
pkgs.haskell-language-server
];
};
checks.${system}.test-suite = checkedProject;
};
}

View File

@ -0,0 +1,29 @@
cabal-version: 2.4
name: mini-audit
version: 0.1.0.0
build-type: Simple
library
exposed-modules: MiniAudit.Rollout
hs-source-dirs: src
build-depends:
base >=4.14 && <5,
mtl
default-language: Haskell2010
executable mini-audit
main-is: Main.hs
hs-source-dirs: app
build-depends:
base >=4.14 && <5,
mini-audit
default-language: Haskell2010
test-suite mini-audit-test
type: exitcode-stdio-1.0
main-is: Main.hs
hs-source-dirs: test
build-depends:
base >=4.14 && <5,
mini-audit
default-language: Haskell2010

View File

@ -0,0 +1,134 @@
module MiniAudit.Rollout where
import Control.Monad.Writer.Strict
( Writer
, runWriter
, tell
)
data Environment
= Staging
| Production
deriving (Eq, Show)
data RolloutMode
= Rolling
| Canary Int
deriving (Eq, Show)
data ReleaseJob = ReleaseJob
{ jobService :: String
, jobEnvironment :: Environment
, jobMode :: RolloutMode
, jobReplicas :: Int
}
deriving (Eq, Show)
data RolloutReport = RolloutReport
{ reportService :: String
, reportEnvironment :: Environment
, reportReplicaCount :: Int
, reportTrafficMilestones :: [Int]
, reportSchemaMigrated :: Bool
}
deriving (Eq, Show)
parseJob :: String -> Either String ReleaseJob
parseJob rawJob =
case splitOn ':' rawJob of
[serviceName, environmentName, modeName, rawPercent, rawReplicas] -> do
environment <- parseEnvironment environmentName
mode <- parseMode modeName rawPercent
replicas <- parseReplicas rawReplicas
pure
ReleaseJob
{ jobService = serviceName
, jobEnvironment = environment
, jobMode = mode
, jobReplicas = replicas
}
_ -> Left ("expected <service>:<environment>:<rolling|canary>:<percent>:<replicas>, got: " ++ rawJob)
runRollout :: ReleaseJob -> (RolloutReport, [String])
runRollout = runWriter . simulateRollout
simulateRollout :: ReleaseJob -> Writer [String] RolloutReport
simulateRollout job = do
tell ["start " ++ jobService job ++ " in " ++ renderEnvironment (jobEnvironment job)]
tell ["scale target replicas to " ++ show (jobReplicas job)]
tell ["run schema migration for " ++ jobService job]
milestones <- rolloutMilestones (jobMode job)
tell ["mark rollout complete for " ++ jobService job]
pure
RolloutReport
{ reportService = jobService job
, reportEnvironment = jobEnvironment job
, reportReplicaCount = jobReplicas job
, reportTrafficMilestones = milestones
, reportSchemaMigrated = True
}
rolloutMilestones :: RolloutMode -> Writer [String] [Int]
rolloutMilestones Rolling = do
tell ["shift 100% traffic immediately"]
pure [100]
rolloutMilestones (Canary percent) = do
tell ["shift " ++ show percent ++ "% traffic to canary"]
tell ["observe error budget after canary window"]
tell ["shift remaining " ++ show (100 - percent) ++ "% traffic"]
pure [percent, 100]
renderReport :: RolloutReport -> String
renderReport report =
reportService report
++ " -> "
++ renderEnvironment (reportEnvironment report)
++ ", replicas "
++ show (reportReplicaCount report)
++ ", milestones "
++ show (reportTrafficMilestones report)
++ ", schema migrated "
++ renderBool (reportSchemaMigrated report)
renderAudit :: [String] -> String
renderAudit = unlines
parseEnvironment :: String -> Either String Environment
parseEnvironment "staging" = Right Staging
parseEnvironment "production" = Right Production
parseEnvironment otherValue = Left ("unknown environment: " ++ otherValue)
parseMode :: String -> String -> Either String RolloutMode
parseMode "rolling" "0" = Right Rolling
parseMode "rolling" rawPercent = Left ("rolling mode expects percent 0, got: " ++ rawPercent)
parseMode "canary" rawPercent =
case reads rawPercent of
[(percent, "")]
| percent >= 1 && percent <= 50 -> Right (Canary percent)
| otherwise -> Left "canary percent must be between 1 and 50"
_ -> Left ("invalid canary percent: " ++ rawPercent)
parseMode otherValue _ = Left ("unknown rollout mode: " ++ otherValue)
parseReplicas :: String -> Either String Int
parseReplicas rawReplicas =
case reads rawReplicas of
[(replicas, "")]
| replicas > 0 -> Right replicas
| otherwise -> Left "replicas must be greater than zero"
_ -> Left ("invalid replica count: " ++ rawReplicas)
renderEnvironment :: Environment -> String
renderEnvironment Staging = "staging"
renderEnvironment Production = "production"
renderBool :: Bool -> String
renderBool True = "yes"
renderBool False = "no"
splitOn :: Char -> String -> [String]
splitOn separator = go []
where
go current [] = [reverse current]
go current (nextChar : remainingChars)
| nextChar == separator = reverse current : go [] remainingChars
| otherwise = go (nextChar : current) remainingChars

View File

@ -0,0 +1,35 @@
module Main where
import MiniAudit.Rollout
( Environment (Production)
, ReleaseJob (ReleaseJob)
, RolloutMode (Canary)
, RolloutReport (RolloutReport)
, parseJob
, renderAudit
, renderReport
, runRollout
)
import System.Exit (die)
main :: IO ()
main =
case parseJob "api:production:canary:20:3" of
Left err -> die err
Right job ->
case runRollout job of
( RolloutReport "api" Production 3 [20, 100] True
, auditLog
) | lines (renderAudit auditLog)
== [ "start api in production"
, "scale target replicas to 3"
, "run schema migration for api"
, "shift 20% traffic to canary"
, "observe error budget after canary window"
, "shift remaining 80% traffic"
, "mark rollout complete for api"
]
&& renderReport (RolloutReport "api" Production 3 [20, 100] True)
== "api -> production, replicas 3, milestones [20,100], schema migrated yes" ->
putStrLn "test passed"
_ -> die "unexpected Writer rollout result"

View File

@ -21,6 +21,8 @@ This note links the Haskell examples in a suggested order from first project str
13. `27-haskell-aeson-roundtrip/`: explicit JSON instances and round-trip checks 13. `27-haskell-aeson-roundtrip/`: explicit JSON instances and round-trip checks
14. `28-haskell-applicative-validation/`: accumulated field validation with an Applicative error type 14. `28-haskell-applicative-validation/`: accumulated field validation with an Applicative error type
15. `29-haskell-foldmap-summary/`: monoidal event aggregation with one `foldMap` pass 15. `29-haskell-foldmap-summary/`: monoidal event aggregation with one `foldMap` pass
16. `30-haskell-traverse-resolution/`: batch resolution of requests through `traverse`
17. `31-haskell-writer-audit/`: rollout logging with `Writer`
--- ---
@ -41,6 +43,8 @@ This note links the Haskell examples in a suggested order from first project str
- `27-haskell-aeson-roundtrip/`: how to keep domain values and JSON formats aligned - `27-haskell-aeson-roundtrip/`: how to keep domain values and JSON formats aligned
- `28-haskell-applicative-validation/`: how to report several field errors without stopping at the first one - `28-haskell-applicative-validation/`: how to report several field errors without stopping at the first one
- `29-haskell-foldmap-summary/`: how to express batch aggregation through monoidal summary fragments - `29-haskell-foldmap-summary/`: how to express batch aggregation through monoidal summary fragments
- `30-haskell-traverse-resolution/`: how to sequence per-request resolution across a whole batch
- `31-haskell-writer-audit/`: how to compute a result while accumulating ordered audit output
--- ---
@ -61,3 +65,5 @@ This note links the Haskell examples in a suggested order from first project str
- `notes/030-haskell-aeson-roundtrip.md` - `notes/030-haskell-aeson-roundtrip.md`
- `notes/031-haskell-applicative-validation.md` - `notes/031-haskell-applicative-validation.md`
- `notes/032-haskell-foldmap-summary.md` - `notes/032-haskell-foldmap-summary.md`
- `notes/033-haskell-traverse-resolution.md`
- `notes/034-haskell-writer-audit.md`

View File

@ -0,0 +1,69 @@
# Haskell Traverse for Batch Resolution
This note covers `30-haskell-traverse-resolution/`, which resolves a batch of deployment requests against a service catalog with `traverse`.
---
## 1. Why `traverse` Is the Point
Each deployment request needs an effectful resolution step:
- parse the environment,
- look up the service in the catalog,
- choose the right image tag, and
- reject environment and release-track combinations that are not allowed.
For one request, that is just `Either String ResolvedDeployment`.
For a whole batch, the example uses:
```haskell
resolveRequests :: Catalog -> [DeploymentRequest] -> Either String [ResolvedDeployment]
resolveRequests serviceCatalog = traverse (resolveRequest serviceCatalog)
```
That is the core lesson. `traverse` sequences the per-item effect and preserves the list structure.
---
## 2. What Makes the Example Non-Trivial
The resolution step is more than one lookup.
It decides:
- which image tag to use for `stable` versus `candidate`,
- whether the service even publishes a candidate image, and
- whether the service is allowed in production at all.
That makes the batch resolution behavior worth teaching on its own.
---
## 3. Why the Batch Fails as a Unit
This example uses `Either`, so the whole batch fails on the first invalid request.
That is intentional. The goal here is not accumulated validation. The goal is sequencing several effectful resolutions through one structure with
`traverse`.
`28-haskell-applicative-validation/` already covers the accumulated-error case.
---
## 4. Commands to Try
```bash
cd 30-haskell-traverse-resolution
nix develop
cabal run
cabal run -- api:production:stable worker:staging:candidate auth:production:stable
cabal test
nix build
./result/bin/mini-resolution api:production:stable worker:staging:candidate auth:production:stable
nix run . -- api:production:stable worker:staging:candidate auth:production:stable
nix flake check
```

View File

@ -0,0 +1,65 @@
# Haskell Writer for Audit Trails
This note covers `31-haskell-writer-audit/`, which simulates a rollout while accumulating ordered audit lines with `Writer`.
---
## 1. What `Writer` Adds Here
The example does two things at once:
- compute a final `RolloutReport`, and
- collect human-readable audit lines in execution order.
That is the shape `Writer` is good at:
```haskell
simulateRollout :: ReleaseJob -> Writer [String] RolloutReport
```
The result and the log are produced together, but the rollout code stays direct and readable.
---
## 2. Why the Log Is Worth Teaching
The audit trail is not decorative. It captures meaningful rollout steps:
- rollout start,
- target scaling,
- schema migration,
- traffic shifting, and
- rollout completion.
For canary rollouts, the example records extra milestones and observation points. That makes the logged structure richer than a toy "hello logger"
example.
---
## 3. Why This Stays Separate from Error Handling
`Writer` is used here only for logging.
The example does not mix in failure handling or configuration lookup, because that would blur the concept. Parsing still happens before the writer run,
and the rollout simulation itself is deterministic.
That keeps the example focused on one question: how do you accumulate ordered auxiliary output while computing a result?
---
## 4. Commands to Try
```bash
cd 31-haskell-writer-audit
nix develop
cabal run
cabal run -- api:production:canary:20:3 worker:staging:rolling:0:2
cabal test
nix build
./result/bin/mini-audit api:production:canary:20:3 worker:staging:rolling:0:2
nix run . -- api:production:canary:20:3 worker:staging:rolling:0:2
nix flake check
```