Add two more Haskell examples (with their note files)
This commit is contained in:
parent
f517fa533f
commit
87d02e8bc2
25
30-haskell-traverse-resolution/README.md
Normal file
25
30-haskell-traverse-resolution/README.md
Normal 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
|
||||||
|
```
|
||||||
29
30-haskell-traverse-resolution/app/Main.hs
Normal file
29
30-haskell-traverse-resolution/app/Main.hs
Normal 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)
|
||||||
27
30-haskell-traverse-resolution/flake.lock
generated
Normal file
27
30-haskell-traverse-resolution/flake.lock
generated
Normal 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
|
||||||
|
}
|
||||||
38
30-haskell-traverse-resolution/flake.nix
Normal file
38
30-haskell-traverse-resolution/flake.nix
Normal 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;
|
||||||
|
};
|
||||||
|
}
|
||||||
29
30-haskell-traverse-resolution/mini-resolution.cabal
Normal file
29
30-haskell-traverse-resolution/mini-resolution.cabal
Normal 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
|
||||||
158
30-haskell-traverse-resolution/src/MiniResolution/Plan.hs
Normal file
158
30-haskell-traverse-resolution/src/MiniResolution/Plan.hs
Normal 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
|
||||||
39
30-haskell-traverse-resolution/test/Main.hs
Normal file
39
30-haskell-traverse-resolution/test/Main.hs
Normal 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"
|
||||||
25
31-haskell-writer-audit/README.md
Normal file
25
31-haskell-writer-audit/README.md
Normal 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
|
||||||
|
```
|
||||||
29
31-haskell-writer-audit/app/Main.hs
Normal file
29
31-haskell-writer-audit/app/Main.hs
Normal 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
27
31-haskell-writer-audit/flake.lock
generated
Normal 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
|
||||||
|
}
|
||||||
38
31-haskell-writer-audit/flake.nix
Normal file
38
31-haskell-writer-audit/flake.nix
Normal 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;
|
||||||
|
};
|
||||||
|
}
|
||||||
29
31-haskell-writer-audit/mini-audit.cabal
Normal file
29
31-haskell-writer-audit/mini-audit.cabal
Normal 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
|
||||||
134
31-haskell-writer-audit/src/MiniAudit/Rollout.hs
Normal file
134
31-haskell-writer-audit/src/MiniAudit/Rollout.hs
Normal 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
|
||||||
35
31-haskell-writer-audit/test/Main.hs
Normal file
35
31-haskell-writer-audit/test/Main.hs
Normal 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"
|
||||||
@ -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`
|
||||||
|
|||||||
69
notes/033-haskell-traverse-resolution.md
Normal file
69
notes/033-haskell-traverse-resolution.md
Normal 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
|
||||||
|
```
|
||||||
65
notes/034-haskell-writer-audit.md
Normal file
65
notes/034-haskell-writer-audit.md
Normal 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
|
||||||
|
```
|
||||||
Loading…
x
Reference in New Issue
Block a user