diff --git a/30-haskell-traverse-resolution/README.md b/30-haskell-traverse-resolution/README.md new file mode 100644 index 0000000..541d6a0 --- /dev/null +++ b/30-haskell-traverse-resolution/README.md @@ -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 +``` diff --git a/30-haskell-traverse-resolution/app/Main.hs b/30-haskell-traverse-resolution/app/Main.hs new file mode 100644 index 0000000..febb940 --- /dev/null +++ b/30-haskell-traverse-resolution/app/Main.hs @@ -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) diff --git a/30-haskell-traverse-resolution/flake.lock b/30-haskell-traverse-resolution/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/30-haskell-traverse-resolution/flake.lock @@ -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 +} diff --git a/30-haskell-traverse-resolution/flake.nix b/30-haskell-traverse-resolution/flake.nix new file mode 100644 index 0000000..e81d5d9 --- /dev/null +++ b/30-haskell-traverse-resolution/flake.nix @@ -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; + }; +} diff --git a/30-haskell-traverse-resolution/mini-resolution.cabal b/30-haskell-traverse-resolution/mini-resolution.cabal new file mode 100644 index 0000000..6c0a488 --- /dev/null +++ b/30-haskell-traverse-resolution/mini-resolution.cabal @@ -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 diff --git a/30-haskell-traverse-resolution/src/MiniResolution/Plan.hs b/30-haskell-traverse-resolution/src/MiniResolution/Plan.hs new file mode 100644 index 0000000..41dbc89 --- /dev/null +++ b/30-haskell-traverse-resolution/src/MiniResolution/Plan.hs @@ -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 ::, 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 diff --git a/30-haskell-traverse-resolution/test/Main.hs b/30-haskell-traverse-resolution/test/Main.hs new file mode 100644 index 0000000..078c7e9 --- /dev/null +++ b/30-haskell-traverse-resolution/test/Main.hs @@ -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" diff --git a/31-haskell-writer-audit/README.md b/31-haskell-writer-audit/README.md new file mode 100644 index 0000000..9ade852 --- /dev/null +++ b/31-haskell-writer-audit/README.md @@ -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 +``` diff --git a/31-haskell-writer-audit/app/Main.hs b/31-haskell-writer-audit/app/Main.hs new file mode 100644 index 0000000..98824f8 --- /dev/null +++ b/31-haskell-writer-audit/app/Main.hs @@ -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 diff --git a/31-haskell-writer-audit/flake.lock b/31-haskell-writer-audit/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/31-haskell-writer-audit/flake.lock @@ -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 +} diff --git a/31-haskell-writer-audit/flake.nix b/31-haskell-writer-audit/flake.nix new file mode 100644 index 0000000..d3c3d74 --- /dev/null +++ b/31-haskell-writer-audit/flake.nix @@ -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; + }; +} diff --git a/31-haskell-writer-audit/mini-audit.cabal b/31-haskell-writer-audit/mini-audit.cabal new file mode 100644 index 0000000..2b16925 --- /dev/null +++ b/31-haskell-writer-audit/mini-audit.cabal @@ -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 diff --git a/31-haskell-writer-audit/src/MiniAudit/Rollout.hs b/31-haskell-writer-audit/src/MiniAudit/Rollout.hs new file mode 100644 index 0000000..d4ada17 --- /dev/null +++ b/31-haskell-writer-audit/src/MiniAudit/Rollout.hs @@ -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 ::::, 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 diff --git a/31-haskell-writer-audit/test/Main.hs b/31-haskell-writer-audit/test/Main.hs new file mode 100644 index 0000000..3629316 --- /dev/null +++ b/31-haskell-writer-audit/test/Main.hs @@ -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" diff --git a/notes/014-haskell-learning-path.md b/notes/014-haskell-learning-path.md index c241087..8f7195b 100644 --- a/notes/014-haskell-learning-path.md +++ b/notes/014-haskell-learning-path.md @@ -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 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 +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 - `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 +- `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/031-haskell-applicative-validation.md` - `notes/032-haskell-foldmap-summary.md` +- `notes/033-haskell-traverse-resolution.md` +- `notes/034-haskell-writer-audit.md` diff --git a/notes/033-haskell-traverse-resolution.md b/notes/033-haskell-traverse-resolution.md new file mode 100644 index 0000000..bb46e62 --- /dev/null +++ b/notes/033-haskell-traverse-resolution.md @@ -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 +``` diff --git a/notes/034-haskell-writer-audit.md b/notes/034-haskell-writer-audit.md new file mode 100644 index 0000000..ec35d5f --- /dev/null +++ b/notes/034-haskell-writer-audit.md @@ -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 +```