diff --git a/23-haskell-maybe-either/README.md b/23-haskell-maybe-either/README.md new file mode 100644 index 0000000..7f687a5 --- /dev/null +++ b/23-haskell-maybe-either/README.md @@ -0,0 +1,25 @@ +# 23-haskell-maybe-either + +This example shows intermediate Haskell request building with `Maybe` and `Either`. + +It includes: + +- optional fields read through `Maybe`, +- required fields upgraded from `Maybe` into `Either` errors, +- validation for rollout strategy and canary percentage, and +- a test suite run by `nix flake check`. + +Useful commands: + +```bash +nix develop +cabal run +cabal run -- service=api env=production replicas=3 strategy=canary canary=10 owner=platform +cabal test + +nix build +./result/bin/mini-release-request service=api env=production replicas=3 strategy=canary canary=10 owner=platform + +nix run . -- service=api env=production replicas=3 strategy=canary canary=10 owner=platform +nix flake check +``` diff --git a/23-haskell-maybe-either/app/Main.hs b/23-haskell-maybe-either/app/Main.hs new file mode 100644 index 0000000..7c0f67e --- /dev/null +++ b/23-haskell-maybe-either/app/Main.hs @@ -0,0 +1,27 @@ +module Main where + +import MiniReleaseRequest.Request + ( buildReleaseRequest + , renderReleaseRequest + ) +import System.Environment (getArgs) +import System.Exit (die) + +main :: IO () +main = do + args <- getArgs + let inputArgs = + case args of + [] -> + [ "service=api" + , "env=production" + , "replicas=3" + , "strategy=canary" + , "canary=10" + , "owner=platform" + ] + _ -> args + + case buildReleaseRequest inputArgs of + Left err -> die err + Right request -> putStrLn (renderReleaseRequest request) diff --git a/23-haskell-maybe-either/flake.lock b/23-haskell-maybe-either/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/23-haskell-maybe-either/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/23-haskell-maybe-either/flake.nix b/23-haskell-maybe-either/flake.nix new file mode 100644 index 0000000..fe6b801 --- /dev/null +++ b/23-haskell-maybe-either/flake.nix @@ -0,0 +1,38 @@ +{ + # Builds a Haskell project that uses Maybe for optional fields and Either + # for validation when constructing a release request. + description = "A Haskell project for Maybe and Either"; + + 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-release-request" ./. { }; + checkedProject = pkgs.haskell.lib.doCheck project; + in + { + packages.${system}.default = project; + + apps.${system}.default = { + type = "app"; + program = "${self.packages.${system}.default}/bin/mini-release-request"; + meta.description = "Run the Maybe and Either release request example."; + }; + + devShells.${system}.default = pkgs.mkShell { + packages = [ + haskellPackages.ghc + pkgs.cabal-install + pkgs.haskell-language-server + ]; + }; + + checks.${system}.test-suite = checkedProject; + }; +} diff --git a/23-haskell-maybe-either/mini-release-request.cabal b/23-haskell-maybe-either/mini-release-request.cabal new file mode 100644 index 0000000..98e725f --- /dev/null +++ b/23-haskell-maybe-either/mini-release-request.cabal @@ -0,0 +1,28 @@ +cabal-version: 2.4 +name: mini-release-request +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MiniReleaseRequest.Request + hs-source-dirs: src + build-depends: + base >=4.14 && <5 + default-language: Haskell2010 + +executable mini-release-request + main-is: Main.hs + hs-source-dirs: app + build-depends: + base >=4.14 && <5, + mini-release-request + default-language: Haskell2010 + +test-suite mini-release-request-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base >=4.14 && <5, + mini-release-request + default-language: Haskell2010 diff --git a/23-haskell-maybe-either/src/MiniReleaseRequest/Request.hs b/23-haskell-maybe-either/src/MiniReleaseRequest/Request.hs new file mode 100644 index 0000000..cde7025 --- /dev/null +++ b/23-haskell-maybe-either/src/MiniReleaseRequest/Request.hs @@ -0,0 +1,113 @@ +module MiniReleaseRequest.Request where + +import Data.List (find, intercalate) + +data Environment + = Staging + | Production + deriving (Eq, Show) + +data Strategy + = Rolling + | Canary Int + deriving (Eq, Show) + +data ReleaseRequest = ReleaseRequest + { serviceName :: String + , environment :: Environment + , replicaCount :: Int + , strategy :: Strategy + , owner :: Maybe String + } + deriving (Eq, Show) + +parseAssignment :: String -> Either String (String, String) +parseAssignment input = + case break (== '=') input of + ([], _) -> Left ("expected key=value, got: " ++ input) + (_, "") -> Left ("expected key=value, got: " ++ input) + (key, '=' : value) + | null value -> Left ("missing value for key: " ++ key) + | otherwise -> Right (key, value) + _ -> Left ("expected key=value, got: " ++ input) + +lookupOptional :: String -> [(String, String)] -> Maybe String +lookupOptional key assignments = snd <$> find ((== key) . fst) assignments + +lookupRequired :: String -> [(String, String)] -> Either String String +lookupRequired key assignments = + case lookupOptional key assignments of + Just value -> Right value + Nothing -> Left ("missing required field: " ++ key) + +parseEnvironment :: String -> Either String Environment +parseEnvironment "staging" = Right Staging +parseEnvironment "production" = Right Production +parseEnvironment other = Left ("unknown environment: " ++ other) + +parseReplicaCount :: String -> Either String Int +parseReplicaCount rawValue = + case reads rawValue of + [(parsedValue, "")] + | parsedValue > 0 -> Right parsedValue + | otherwise -> Left "replicas must be greater than zero" + _ -> Left ("invalid replica count: " ++ rawValue) + +resolveStrategy :: [(String, String)] -> Either String Strategy +resolveStrategy assignments = do + strategyName <- lookupRequired "strategy" assignments + case strategyName of + "rolling" -> + case lookupOptional "canary" assignments of + Nothing -> Right Rolling + Just _ -> Left "rolling strategy does not accept a canary percentage" + "canary" -> do + rawPercent <- lookupRequired "canary" assignments + percent <- + case reads rawPercent of + [(parsedPercent, "")] + | parsedPercent >= 1 && parsedPercent <= 50 -> Right parsedPercent + | otherwise -> Left "canary percentage must be between 1 and 50" + _ -> Left ("invalid canary percentage: " ++ rawPercent) + Right (Canary percent) + other -> Left ("unknown strategy: " ++ other) + +buildReleaseRequest :: [String] -> Either String ReleaseRequest +buildReleaseRequest rawAssignments = do + assignments <- traverse parseAssignment rawAssignments + releaseService <- lookupRequired "service" assignments + releaseEnvironment <- lookupRequired "env" assignments >>= parseEnvironment + releaseReplicaCount <- lookupRequired "replicas" assignments >>= parseReplicaCount + releaseStrategy <- resolveStrategy assignments + let releaseOwner = lookupOptional "owner" assignments + pure + ReleaseRequest + { serviceName = releaseService + , environment = releaseEnvironment + , replicaCount = releaseReplicaCount + , strategy = releaseStrategy + , owner = releaseOwner + } + +renderReleaseRequest :: ReleaseRequest -> String +renderReleaseRequest request = + intercalate + ", " + [ "service " ++ serviceName request + , "env " ++ renderEnvironment (environment request) + , "replicas " ++ show (replicaCount request) + , "strategy " ++ renderStrategy (strategy request) + , renderOwner (owner request) + ] + +renderEnvironment :: Environment -> String +renderEnvironment Staging = "staging" +renderEnvironment Production = "production" + +renderStrategy :: Strategy -> String +renderStrategy Rolling = "rolling" +renderStrategy (Canary percent) = "canary " ++ show percent ++ "%" + +renderOwner :: Maybe String -> String +renderOwner Nothing = "owner unassigned" +renderOwner (Just assignedOwner) = "owner " ++ assignedOwner diff --git a/23-haskell-maybe-either/test/Main.hs b/23-haskell-maybe-either/test/Main.hs new file mode 100644 index 0000000..04182f2 --- /dev/null +++ b/23-haskell-maybe-either/test/Main.hs @@ -0,0 +1,41 @@ +module Main where + +import MiniReleaseRequest.Request + ( Environment (Production, Staging) + , ReleaseRequest (ReleaseRequest) + , Strategy (Canary, Rolling) + , buildReleaseRequest + , renderReleaseRequest + ) +import System.Exit (die) + +main :: IO () +main = + case + ( buildReleaseRequest + [ "service=api" + , "env=production" + , "replicas=3" + , "strategy=canary" + , "canary=10" + ] + , buildReleaseRequest + [ "service=worker" + , "env=staging" + , "replicas=2" + , "strategy=rolling" + , "owner=ops" + ] + , buildReleaseRequest + [ "service=cache" + , "env=production" + , "replicas=2" + , "strategy=canary" + ] + ) of + ( Right (ReleaseRequest "api" Production 3 (Canary 10) Nothing) + , Right rollingRequest@(ReleaseRequest "worker" Staging 2 Rolling (Just "ops")) + , Left _ + ) | renderReleaseRequest rollingRequest == "service worker, env staging, replicas 2, strategy rolling, owner ops" -> + putStrLn "test passed" + _ -> die "unexpected release request result" diff --git a/24-haskell-deriving/README.md b/24-haskell-deriving/README.md new file mode 100644 index 0000000..d7a3d1d --- /dev/null +++ b/24-haskell-deriving/README.md @@ -0,0 +1,24 @@ +# 24-haskell-deriving + +This example shows intermediate Haskell deriving with stock and newtype strategies. + +It includes: + +- `deriving stock` for ordering, enumeration, and display, +- `GeneralizedNewtypeDeriving` for numeric and semigroup behavior, +- one release batch that merges and sorts targets through derived instances, and +- a test suite run by `nix flake check`. + +Useful commands: + +```bash +nix develop +cabal run +cabal test + +nix build +./result/bin/mini-deriving + +nix run +nix flake check +``` diff --git a/24-haskell-deriving/app/Main.hs b/24-haskell-deriving/app/Main.hs new file mode 100644 index 0000000..8e9a310 --- /dev/null +++ b/24-haskell-deriving/app/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import MiniDeriving.Batch + ( mergeBatches + , platformBatch + , renderBatch + , urgentFixBatch + ) + +main :: IO () +main = putStrLn (renderBatch (mergeBatches platformBatch urgentFixBatch)) diff --git a/24-haskell-deriving/flake.lock b/24-haskell-deriving/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/24-haskell-deriving/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/24-haskell-deriving/flake.nix b/24-haskell-deriving/flake.nix new file mode 100644 index 0000000..f06ccc4 --- /dev/null +++ b/24-haskell-deriving/flake.nix @@ -0,0 +1,38 @@ +{ + # Builds a Haskell project that uses deriving strategies to get ordering, + # enumeration, and accumulation behavior for release-planning types. + description = "A Haskell project for deriving strategies"; + + 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-deriving" ./. { }; + checkedProject = pkgs.haskell.lib.doCheck project; + in + { + packages.${system}.default = project; + + apps.${system}.default = { + type = "app"; + program = "${self.packages.${system}.default}/bin/mini-deriving"; + meta.description = "Run the deriving strategies example."; + }; + + devShells.${system}.default = pkgs.mkShell { + packages = [ + haskellPackages.ghc + pkgs.cabal-install + pkgs.haskell-language-server + ]; + }; + + checks.${system}.test-suite = checkedProject; + }; +} diff --git a/24-haskell-deriving/mini-deriving.cabal b/24-haskell-deriving/mini-deriving.cabal new file mode 100644 index 0000000..d17682a --- /dev/null +++ b/24-haskell-deriving/mini-deriving.cabal @@ -0,0 +1,28 @@ +cabal-version: 2.4 +name: mini-deriving +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MiniDeriving.Batch + hs-source-dirs: src + build-depends: + base >=4.14 && <5 + default-language: Haskell2010 + +executable mini-deriving + main-is: Main.hs + hs-source-dirs: app + build-depends: + base >=4.14 && <5, + mini-deriving + default-language: Haskell2010 + +test-suite mini-deriving-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base >=4.14 && <5, + mini-deriving + default-language: Haskell2010 diff --git a/24-haskell-deriving/src/MiniDeriving/Batch.hs b/24-haskell-deriving/src/MiniDeriving/Batch.hs new file mode 100644 index 0000000..9ca6655 --- /dev/null +++ b/24-haskell-deriving/src/MiniDeriving/Batch.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module MiniDeriving.Batch where + +import Data.List (sort) + +newtype BatchName = BatchName + { unBatchName :: String + } + deriving stock (Eq, Show) + deriving newtype (Semigroup, Monoid) + +data Environment + = Staging + | Production + deriving stock (Eq, Ord, Show, Enum, Bounded) + +data Priority + = Urgent + | Standard + | Background + deriving stock (Eq, Ord, Show, Enum, Bounded) + +newtype FailureBudget = FailureBudget + { unFailureBudget :: Int + } + deriving stock (Eq, Show) + deriving newtype (Num, Ord) + +data ReleaseTarget = ReleaseTarget + { targetEnvironment :: Environment + , targetPriority :: Priority + , targetService :: String + , targetFailureBudget :: FailureBudget + } + deriving stock (Eq, Ord, Show) + +data ReleaseBatch = ReleaseBatch + { batchName :: BatchName + , targets :: [ReleaseTarget] + } + deriving stock (Eq, Show) + +allEnvironments :: [Environment] +allEnvironments = [minBound .. maxBound] + +mergeBatches :: ReleaseBatch -> ReleaseBatch -> ReleaseBatch +mergeBatches leftBatch rightBatch = + ReleaseBatch + { batchName = batchName leftBatch <> BatchName "+" <> batchName rightBatch + , targets = targets leftBatch <> targets rightBatch + } + +sortedTargets :: ReleaseBatch -> [ReleaseTarget] +sortedTargets = sort . targets + +totalFailureBudget :: ReleaseBatch -> FailureBudget +totalFailureBudget = sum . map targetFailureBudget . targets + +renderBatch :: ReleaseBatch -> String +renderBatch releaseBatch = + unlines + ( headerLine + : map renderTarget (sortedTargets releaseBatch) + ) + where + headerLine = + "batch " + ++ unBatchName (batchName releaseBatch) + ++ " across " + ++ show (length allEnvironments) + ++ " environments with failure budget " + ++ show (unFailureBudget (totalFailureBudget releaseBatch)) + +renderTarget :: ReleaseTarget -> String +renderTarget releaseTarget = + targetService releaseTarget + ++ " -> " + ++ show (targetEnvironment releaseTarget) + ++ " / " + ++ show (targetPriority releaseTarget) + ++ " / budget " + ++ show (unFailureBudget (targetFailureBudget releaseTarget)) + +platformBatch :: ReleaseBatch +platformBatch = + ReleaseBatch + { batchName = BatchName "platform" + , targets = + [ ReleaseTarget Production Standard "api" 3 + , ReleaseTarget Staging Background "worker" 1 + ] + } + +urgentFixBatch :: ReleaseBatch +urgentFixBatch = + ReleaseBatch + { batchName = BatchName "urgent-fix" + , targets = + [ ReleaseTarget Production Urgent "auth" 2 + , ReleaseTarget Staging Urgent "billing" 1 + ] + } diff --git a/24-haskell-deriving/test/Main.hs b/24-haskell-deriving/test/Main.hs new file mode 100644 index 0000000..8647d9b --- /dev/null +++ b/24-haskell-deriving/test/Main.hs @@ -0,0 +1,35 @@ +module Main where + +import MiniDeriving.Batch + ( Environment (Production, Staging) + , FailureBudget (FailureBudget) + , Priority (Background, Standard, Urgent) + , ReleaseTarget (ReleaseTarget) + , allEnvironments + , mergeBatches + , platformBatch + , renderBatch + , sortedTargets + , totalFailureBudget + , urgentFixBatch + ) +import System.Exit (die) + +main :: IO () +main = + case + ( allEnvironments + , sortedTargets (mergeBatches platformBatch urgentFixBatch) + , totalFailureBudget (mergeBatches platformBatch urgentFixBatch) + ) of + ( [Staging, Production] + , [ ReleaseTarget Staging Urgent "billing" 1 + , ReleaseTarget Staging Background "worker" 1 + , ReleaseTarget Production Urgent "auth" 2 + , ReleaseTarget Production Standard "api" 3 + ] + , FailureBudget 7 + ) | head (lines (renderBatch (mergeBatches platformBatch urgentFixBatch))) + == "batch platform+urgent-fix across 2 environments with failure budget 7" -> + putStrLn "test passed" + _ -> die "unexpected derived behavior" diff --git a/25-haskell-state/README.md b/25-haskell-state/README.md new file mode 100644 index 0000000..c8e84f1 --- /dev/null +++ b/25-haskell-state/README.md @@ -0,0 +1,25 @@ +# 25-haskell-state + +This example shows intermediate Haskell planning with `State`. + +It includes: + +- a planner state that tracks build numbers and rollout waves, +- stateful allocation of per-environment wave numbers, +- a CLI that renders a deployment plan from compact request strings, and +- a test suite run by `nix flake check`. + +Useful commands: + +```bash +nix develop +cabal run +cabal run -- api:production:3 worker:staging:1 cache:production:2 +cabal test + +nix build +./result/bin/mini-state-planner api:production:3 worker:staging:1 cache:production:2 + +nix run . -- api:production:3 worker:staging:1 cache:production:2 +nix flake check +``` diff --git a/25-haskell-state/app/Main.hs b/25-haskell-state/app/Main.hs new file mode 100644 index 0000000..938edb0 --- /dev/null +++ b/25-haskell-state/app/Main.hs @@ -0,0 +1,25 @@ +module Main where + +import MiniStatePlanner.Plan + ( parseRequest + , planDeployments + , renderPlan + ) +import System.Environment (getArgs) +import System.Exit (die) + +main :: IO () +main = do + args <- getArgs + let requestArgs = + case args of + [] -> + [ "api:production:3" + , "worker:staging:1" + , "cache:production:2" + ] + _ -> args + + case traverse parseRequest requestArgs of + Left err -> die err + Right requests -> putStrLn (renderPlan (planDeployments requests)) diff --git a/25-haskell-state/flake.lock b/25-haskell-state/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/25-haskell-state/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/25-haskell-state/flake.nix b/25-haskell-state/flake.nix new file mode 100644 index 0000000..437ace4 --- /dev/null +++ b/25-haskell-state/flake.nix @@ -0,0 +1,38 @@ +{ + # Builds a Haskell project that uses State to allocate build numbers and + # per-environment rollout waves while planning deployments. + description = "A Haskell project for State-based planning"; + + 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-state-planner" ./. { }; + checkedProject = pkgs.haskell.lib.doCheck project; + in + { + packages.${system}.default = project; + + apps.${system}.default = { + type = "app"; + program = "${self.packages.${system}.default}/bin/mini-state-planner"; + meta.description = "Run the State-based release planner example."; + }; + + devShells.${system}.default = pkgs.mkShell { + packages = [ + haskellPackages.ghc + pkgs.cabal-install + pkgs.haskell-language-server + ]; + }; + + checks.${system}.test-suite = checkedProject; + }; +} diff --git a/25-haskell-state/mini-state-planner.cabal b/25-haskell-state/mini-state-planner.cabal new file mode 100644 index 0000000..9173698 --- /dev/null +++ b/25-haskell-state/mini-state-planner.cabal @@ -0,0 +1,30 @@ +cabal-version: 2.4 +name: mini-state-planner +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MiniStatePlanner.Plan + hs-source-dirs: src + build-depends: + base >=4.14 && <5, + containers, + mtl + default-language: Haskell2010 + +executable mini-state-planner + main-is: Main.hs + hs-source-dirs: app + build-depends: + base >=4.14 && <5, + mini-state-planner + default-language: Haskell2010 + +test-suite mini-state-planner-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base >=4.14 && <5, + mini-state-planner + default-language: Haskell2010 diff --git a/25-haskell-state/src/MiniStatePlanner/Plan.hs b/25-haskell-state/src/MiniStatePlanner/Plan.hs new file mode 100644 index 0000000..082c8d0 --- /dev/null +++ b/25-haskell-state/src/MiniStatePlanner/Plan.hs @@ -0,0 +1,121 @@ +module MiniStatePlanner.Plan where + +import Control.Monad.State.Strict + ( State + , evalState + , get + , put + ) +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) + +data Environment + = Staging + | Production + deriving (Eq, Ord, Show) + +data DeploymentRequest = DeploymentRequest + { requestService :: String + , requestEnvironment :: Environment + , requestReplicas :: Int + } + deriving (Eq, Show) + +data PlannedDeployment = PlannedDeployment + { buildNumber :: Int + , waveNumber :: Int + , requestedDeployment :: DeploymentRequest + } + deriving (Eq, Show) + +data PlannerState = PlannerState + { nextBuildNumber :: Int + , nextWaveByEnvironment :: Map Environment Int + } + deriving (Eq, Show) + +initialPlannerState :: PlannerState +initialPlannerState = + PlannerState + { nextBuildNumber = 1001 + , nextWaveByEnvironment = Map.fromList [(Staging, 1), (Production, 1)] + } + +parseEnvironment :: String -> Either String Environment +parseEnvironment "staging" = Right Staging +parseEnvironment "production" = Right Production +parseEnvironment other = Left ("unknown environment: " ++ other) + +parseRequest :: String -> Either String DeploymentRequest +parseRequest rawRequest = + case splitOn ':' rawRequest of + [service, environmentName, rawReplicas] -> do + environment <- parseEnvironment environmentName + replicas <- + case reads rawReplicas of + [(parsedReplicas, "")] + | parsedReplicas > 0 -> Right parsedReplicas + | otherwise -> Left "replicas must be greater than zero" + _ -> Left ("invalid replica count: " ++ rawReplicas) + pure + DeploymentRequest + { requestService = service + , requestEnvironment = environment + , requestReplicas = replicas + } + _ -> Left ("expected ::, got: " ++ rawRequest) + +planDeployment :: DeploymentRequest -> State PlannerState PlannedDeployment +planDeployment request = do + plannerState <- get + let currentBuildNumber = nextBuildNumber plannerState + currentWaveNumber = + Map.findWithDefault 1 (requestEnvironment request) (nextWaveByEnvironment plannerState) + updatedState = + PlannerState + { nextBuildNumber = currentBuildNumber + 1 + , nextWaveByEnvironment = + Map.insert + (requestEnvironment request) + (currentWaveNumber + 1) + (nextWaveByEnvironment plannerState) + } + put updatedState + pure + PlannedDeployment + { buildNumber = currentBuildNumber + , waveNumber = currentWaveNumber + , requestedDeployment = request + } + +planDeployments :: [DeploymentRequest] -> [PlannedDeployment] +planDeployments requests = evalState (traverse planDeployment requests) initialPlannerState + +renderPlan :: [PlannedDeployment] -> String +renderPlan = unlines . map renderDeployment + +renderDeployment :: PlannedDeployment -> String +renderDeployment plannedDeployment = + requestService request + ++ " -> " + ++ renderEnvironment (requestEnvironment request) + ++ ", replicas " + ++ show (requestReplicas request) + ++ ", build " + ++ show (buildNumber plannedDeployment) + ++ ", wave " + ++ show (waveNumber plannedDeployment) + where + request = requestedDeployment plannedDeployment + +renderEnvironment :: Environment -> String +renderEnvironment Staging = "staging" +renderEnvironment Production = "production" + +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/25-haskell-state/test/Main.hs b/25-haskell-state/test/Main.hs new file mode 100644 index 0000000..3228124 --- /dev/null +++ b/25-haskell-state/test/Main.hs @@ -0,0 +1,24 @@ +module Main where + +import MiniStatePlanner.Plan + ( DeploymentRequest (DeploymentRequest) + , Environment (Production, Staging) + , PlannedDeployment (PlannedDeployment) + , parseRequest + , planDeployments + , renderPlan + ) +import System.Exit (die) + +main :: IO () +main = + case traverse parseRequest ["api:production:3", "worker:staging:1", "cache:production:2"] of + Left err -> die err + Right requests -> + case planDeployments requests of + [ PlannedDeployment 1001 1 (DeploymentRequest "api" Production 3) + , PlannedDeployment 1002 1 (DeploymentRequest "worker" Staging 1) + , PlannedDeployment 1003 2 (DeploymentRequest "cache" Production 2) + ] | "cache -> production, replicas 2, build 1003, wave 2" `elem` lines (renderPlan (planDeployments requests)) -> + putStrLn "test passed" + _ -> die "unexpected planning result" diff --git a/notes/014-haskell-learning-path.md b/notes/014-haskell-learning-path.md index 3082de8..353b62d 100644 --- a/notes/014-haskell-learning-path.md +++ b/notes/014-haskell-learning-path.md @@ -14,6 +14,11 @@ This note links the Haskell examples in a suggested order from first project str 6. `10-haskell-effects/`: `ReaderT`, `Except`, and constrained application logic 7. `11-haskell-typeclasses/`: custom type classes and per-type instances 8. `12-haskell-parser-combinators/`: parser combinators with Megaparsec +9. `23-haskell-maybe-either/`: optional values, required-field errors, and layered request validation +10. `24-haskell-deriving/`: deriving strategies for ordering, enumeration, and wrapper behavior +11. `25-haskell-state/`: pure stateful planning with global and per-environment counters +12. `26-haskell-quickcheck/`: property testing for a non-trivial normalization function +13. `27-haskell-aeson-roundtrip/`: explicit JSON instances and round-trip checks --- @@ -27,6 +32,11 @@ This note links the Haskell examples in a suggested order from first project str - `10-haskell-effects/`: how to separate configuration, logic, and failures - `11-haskell-typeclasses/`: how to abstract shared behavior across several types - `12-haskell-parser-combinators/`: how to build a small language from reusable parser pieces +- `23-haskell-maybe-either/`: how optional fields and validation errors play different roles +- `24-haskell-deriving/`: how derived behavior depends on constructor and field layout +- `25-haskell-state/`: how to thread evolving planning state without leaving pure code +- `26-haskell-quickcheck/`: how to test invariants across many generated inputs +- `27-haskell-aeson-roundtrip/`: how to keep domain values and JSON formats aligned --- @@ -40,3 +50,8 @@ This note links the Haskell examples in a suggested order from first project str - `notes/012-haskell-effects.md` - `notes/013-haskell-typeclasses.md` - `notes/015-haskell-parser-combinators.md` +- `notes/026-haskell-maybe-and-either.md` +- `notes/027-haskell-deriving.md` +- `notes/028-haskell-state.md` +- `notes/029-haskell-quickcheck.md` +- `notes/030-haskell-aeson-roundtrip.md` diff --git a/notes/026-haskell-maybe-and-either.md b/notes/026-haskell-maybe-and-either.md new file mode 100644 index 0000000..c7b70ec --- /dev/null +++ b/notes/026-haskell-maybe-and-either.md @@ -0,0 +1,73 @@ +# Haskell Maybe and Either + +This note covers `23-haskell-maybe-either/`, which builds a release request from `key=value` inputs by using `Maybe` for optional data and `Either` +for validation failures. + +--- + +## 1. Why Both Types Matter + +`Maybe` answers one question: is a value present or absent? + +`Either` answers a different question: if something failed, why? + +This example uses both on purpose: + +- optional fields such as `owner` stay as `Maybe`, +- required fields start as lookups that may be absent, and +- missing or invalid required data becomes `Either String ...` with an error message. + +That gives the program a clean progression from raw input toward a validated domain value. + +--- + +## 2. Where `Maybe` Shows Up + +The input is a flat list of assignments such as `service=api` and `owner=platform`. + +`lookupOptional` searches that list and returns `Maybe String`: + +```haskell +lookupOptional :: String -> [(String, String)] -> Maybe String +``` + +That is the right level for values that are genuinely optional. In the example, `owner` can be absent without making the whole request invalid. + +--- + +## 3. Where `Either` Takes Over + +Required fields cannot stay as `Maybe`, because the rest of the program needs a reason when construction fails. + +The example upgrades a missing field into an error: + +```haskell +lookupRequired :: String -> [(String, String)] -> Either String String +``` + +It then adds more validation: + +- environment parsing, +- replica count parsing, and +- canary percentage rules for the rollout strategy. + +That keeps absence and validation separate, which makes the control flow easier to read. + +--- + +## 4. Commands to Try + +```bash +cd 23-haskell-maybe-either + +nix develop +cabal run +cabal run -- service=api env=production replicas=3 strategy=canary canary=10 owner=platform +cabal test + +nix build +./result/bin/mini-release-request service=api env=production replicas=3 strategy=canary canary=10 owner=platform + +nix run . -- service=api env=production replicas=3 strategy=canary canary=10 owner=platform +nix flake check +``` diff --git a/notes/027-haskell-deriving.md b/notes/027-haskell-deriving.md new file mode 100644 index 0000000..d622731 --- /dev/null +++ b/notes/027-haskell-deriving.md @@ -0,0 +1,64 @@ +# Haskell Deriving Strategies + +This note covers `24-haskell-deriving/`, which uses `deriving stock` and `GeneralizedNewtypeDeriving` to build useful behavior for release-planning +types with very little manual code. + +--- + +## 1. What the Example Derives + +The example derives three kinds of behavior: + +- ordering and display for enums and records, +- enumeration for the environment list, and +- numeric and semigroup behavior for newtypes. + +Those derived instances are then used directly in the program: + +- `allEnvironments` comes from `Enum` and `Bounded`, +- `sortedTargets` relies on derived `Ord`, and +- `totalFailureBudget` relies on derived `Num`. + +--- + +## 2. Why the Constructor Order Matters + +Derived ordering is not magical. It follows constructor order for sum types, and field order for product types. + +That matters in this example: + +- `Priority` lists `Urgent` before `Standard` and `Background`, so urgent work sorts first, and +- `ReleaseTarget` stores environment and priority before the service name, so the derived record ordering matches the intended rollout order. + +This is the main teaching point: derived instances are only as good as the domain shape you give them. + +--- + +## 3. Why the Newtypes Are Useful + +`BatchName` and `FailureBudget` are wrappers, but they still need behavior. + +`GeneralizedNewtypeDeriving` lets the example reuse the underlying instances: + +- `BatchName` derives `Semigroup` and `Monoid`, and +- `FailureBudget` derives `Num` and `Ord`. + +That means the code can concatenate names and sum budgets without unpacking the wrappers everywhere. + +--- + +## 4. Commands to Try + +```bash +cd 24-haskell-deriving + +nix develop +cabal run +cabal test + +nix build +./result/bin/mini-deriving + +nix run +nix flake check +``` diff --git a/notes/028-haskell-state.md b/notes/028-haskell-state.md new file mode 100644 index 0000000..72b3e94 --- /dev/null +++ b/notes/028-haskell-state.md @@ -0,0 +1,61 @@ +# Haskell State + +This note covers `25-haskell-state/`, which plans a sequence of deployments by threading a build counter and per-environment wave numbers through +`State`. + +--- + +## 1. What the State Represents + +The planner keeps two changing values: + +- the next global build number, and +- the next rollout wave number for each environment. + +That is a good fit for `State`, because each planned deployment needs to read the current values and write back updated ones. + +--- + +## 2. Why This Stays Pure + +The planning logic does not perform I/O. It just transforms a list of deployment requests into a list of planned deployments. + +`State` keeps that transformation pure: + +```haskell +planDeployment :: DeploymentRequest -> State PlannerState PlannedDeployment +``` + +The caller still gets a plain value at the end through `evalState`. + +That is the important intermediate Haskell idea here: stateful logic does not have to mean mutable variables or `IO`. + +--- + +## 3. What the Example Allocates + +Each request receives: + +- a build number that increments globally, and +- a wave number that increments separately per environment. + +That makes the output more interesting than a single counter example, while still teaching one concept. + +--- + +## 4. Commands to Try + +```bash +cd 25-haskell-state + +nix develop +cabal run +cabal run -- api:production:3 worker:staging:1 cache:production:2 +cabal test + +nix build +./result/bin/mini-state-planner api:production:3 worker:staging:1 cache:production:2 + +nix run . -- api:production:3 worker:staging:1 cache:production:2 +nix flake check +```