diff --git a/28-haskell-applicative-validation/README.md b/28-haskell-applicative-validation/README.md new file mode 100644 index 0000000..5d0f450 --- /dev/null +++ b/28-haskell-applicative-validation/README.md @@ -0,0 +1,25 @@ +# 28-haskell-applicative-validation + +This example shows intermediate Haskell validation with an Applicative error accumulator. + +It includes: + +- a custom `Validation` type that accumulates multiple errors, +- a release manifest built from validated fields, +- a CLI that reports all invalid fields at once, and +- a test suite run by `nix flake check`. + +Useful commands: + +```bash +nix develop +cabal run +cabal run -- service=api-gateway env=production owners=platform,security replicas=3 strategy=canary:20 window=22-24 +cabal test + +nix build +./result/bin/mini-validation service=api-gateway env=production owners=platform,security replicas=3 strategy=canary:20 window=22-24 + +nix run . -- service=api-gateway env=production owners=platform,security replicas=3 strategy=canary:20 window=22-24 +nix flake check +``` diff --git a/28-haskell-applicative-validation/app/Main.hs b/28-haskell-applicative-validation/app/Main.hs new file mode 100644 index 0000000..b909357 --- /dev/null +++ b/28-haskell-applicative-validation/app/Main.hs @@ -0,0 +1,33 @@ +module Main where + +import MiniValidation.Manifest + ( Validation (Failure, Success) + , readRawManifest + , renderManifest + , renderValidationErrors + , validateManifest + ) +import System.Environment (getArgs) +import System.Exit (die) + +main :: IO () +main = do + args <- getArgs + let inputArgs = + case args of + [] -> + [ "service=api-gateway" + , "env=production" + , "owners=platform,security" + , "replicas=3" + , "strategy=canary:20" + , "window=22-24" + ] + _ -> args + + case readRawManifest inputArgs of + Left err -> die err + Right rawManifest -> + case validateManifest rawManifest of + Failure validationErrors -> die (renderValidationErrors validationErrors) + Success manifest -> putStrLn (renderManifest manifest) diff --git a/28-haskell-applicative-validation/flake.lock b/28-haskell-applicative-validation/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/28-haskell-applicative-validation/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/28-haskell-applicative-validation/flake.nix b/28-haskell-applicative-validation/flake.nix new file mode 100644 index 0000000..fa2e8b9 --- /dev/null +++ b/28-haskell-applicative-validation/flake.nix @@ -0,0 +1,38 @@ +{ + # Builds a Haskell project that validates a release manifest with an + # Applicative validation type that accumulates multiple field errors. + description = "A Haskell project for Applicative validation"; + + 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-validation" ./. { }; + checkedProject = pkgs.haskell.lib.doCheck project; + in + { + packages.${system}.default = project; + + apps.${system}.default = { + type = "app"; + program = "${self.packages.${system}.default}/bin/mini-validation"; + meta.description = "Run the Applicative validation example."; + }; + + devShells.${system}.default = pkgs.mkShell { + packages = [ + haskellPackages.ghc + pkgs.cabal-install + pkgs.haskell-language-server + ]; + }; + + checks.${system}.test-suite = checkedProject; + }; +} diff --git a/28-haskell-applicative-validation/mini-validation.cabal b/28-haskell-applicative-validation/mini-validation.cabal new file mode 100644 index 0000000..bdce966 --- /dev/null +++ b/28-haskell-applicative-validation/mini-validation.cabal @@ -0,0 +1,28 @@ +cabal-version: 2.4 +name: mini-validation +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MiniValidation.Manifest + hs-source-dirs: src + build-depends: + base >=4.14 && <5 + default-language: Haskell2010 + +executable mini-validation + main-is: Main.hs + hs-source-dirs: app + build-depends: + base >=4.14 && <5, + mini-validation + default-language: Haskell2010 + +test-suite mini-validation-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base >=4.14 && <5, + mini-validation + default-language: Haskell2010 diff --git a/28-haskell-applicative-validation/src/MiniValidation/Manifest.hs b/28-haskell-applicative-validation/src/MiniValidation/Manifest.hs new file mode 100644 index 0000000..7bf4413 --- /dev/null +++ b/28-haskell-applicative-validation/src/MiniValidation/Manifest.hs @@ -0,0 +1,222 @@ +module MiniValidation.Manifest where + +import Data.Char (isDigit, isLower) +import Data.List (group, intercalate) + +data Validation errorValue value + = Failure errorValue + | Success value + deriving (Eq, Show) + +instance Functor (Validation errorValue) where + fmap _ (Failure err) = Failure err + fmap f (Success value) = Success (f value) + +instance Semigroup errorValue => Applicative (Validation errorValue) where + pure = Success + Failure leftError <*> Failure rightError = Failure (leftError <> rightError) + Failure err <*> _ = Failure err + _ <*> Failure err = Failure err + Success f <*> Success value = Success (f value) + +data Environment + = Staging + | Production + deriving (Eq, Show) + +data RolloutStrategy + = Rolling + | Canary Int + deriving (Eq, Show) + +data MaintenanceWindow = MaintenanceWindow + { windowStartHour :: Int + , windowEndHour :: Int + } + deriving (Eq, Show) + +data ReleaseManifest = ReleaseManifest + { manifestService :: String + , manifestEnvironment :: Environment + , manifestOwners :: [String] + , manifestReplicas :: Int + , manifestStrategy :: RolloutStrategy + , manifestWindow :: MaintenanceWindow + } + deriving (Eq, Show) + +data RawManifest = RawManifest + { rawService :: Maybe String + , rawEnvironment :: Maybe String + , rawOwners :: Maybe String + , rawReplicas :: Maybe String + , rawStrategy :: Maybe String + , rawWindow :: Maybe String + } + deriving (Eq, Show) + +emptyRawManifest :: RawManifest +emptyRawManifest = + RawManifest + { rawService = Nothing + , rawEnvironment = Nothing + , rawOwners = Nothing + , rawReplicas = Nothing + , rawStrategy = Nothing + , rawWindow = Nothing + } + +readRawManifest :: [String] -> Either String RawManifest +readRawManifest = foldl step (Right emptyRawManifest) + where + step (Left err) _ = Left err + step (Right manifest) assignment = do + (key, value) <- parseAssignment assignment + applyAssignment key value manifest + +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) + +applyAssignment :: String -> String -> RawManifest -> Either String RawManifest +applyAssignment "service" value manifest = Right manifest { rawService = Just value } +applyAssignment "env" value manifest = Right manifest { rawEnvironment = Just value } +applyAssignment "owners" value manifest = Right manifest { rawOwners = Just value } +applyAssignment "replicas" value manifest = Right manifest { rawReplicas = Just value } +applyAssignment "strategy" value manifest = Right manifest { rawStrategy = Just value } +applyAssignment "window" value manifest = Right manifest { rawWindow = Just value } +applyAssignment key _ _ = Left ("unknown field: " ++ key) + +validateManifest :: RawManifest -> Validation [String] ReleaseManifest +validateManifest rawManifest = + ReleaseManifest + <$> validateService (rawService rawManifest) + <*> validateEnvironment (rawEnvironment rawManifest) + <*> validateOwners (rawOwners rawManifest) + <*> validateReplicas (rawReplicas rawManifest) + <*> validateStrategy (rawStrategy rawManifest) + <*> validateWindow (rawWindow rawManifest) + +validateService :: Maybe String -> Validation [String] String +validateService Nothing = Failure ["service is required"] +validateService (Just serviceName) + | length serviceName < 3 = Failure ["service must be at least 3 characters long"] + | not (all validServiceChar serviceName) = + Failure ["service must use lowercase letters and hyphens only"] + | otherwise = Success serviceName + +validateEnvironment :: Maybe String -> Validation [String] Environment +validateEnvironment Nothing = Failure ["env is required"] +validateEnvironment (Just "staging") = Success Staging +validateEnvironment (Just "production") = Success Production +validateEnvironment (Just otherValue) = Failure ["unknown environment: " ++ otherValue] + +validateOwners :: Maybe String -> Validation [String] [String] +validateOwners Nothing = Failure ["owners is required"] +validateOwners (Just rawOwnerList) = + let owners = splitOn ',' rawOwnerList + in case () of + _ | null owners -> Failure ["owners must contain at least one owner"] + | any null owners -> Failure ["owners must not contain empty entries"] + | hasDuplicates owners -> Failure ["owners must not contain duplicates"] + | otherwise -> Success owners + +validateReplicas :: Maybe String -> Validation [String] Int +validateReplicas Nothing = Failure ["replicas is required"] +validateReplicas (Just rawValue) = + case reads rawValue of + [(replicaCount, "")] + | replicaCount >= 2 -> Success replicaCount + | otherwise -> Failure ["replicas must be at least 2"] + _ -> Failure ["replicas must be a whole number"] + +validateStrategy :: Maybe String -> Validation [String] RolloutStrategy +validateStrategy Nothing = Failure ["strategy is required"] +validateStrategy (Just "rolling") = Success Rolling +validateStrategy (Just rawValue) = + case break (== ':') rawValue of + ("canary", ':' : rawPercent) -> + case reads rawPercent of + [(percent, "")] + | percent >= 1 && percent <= 50 -> Success (Canary percent) + | otherwise -> Failure ["canary percentage must be between 1 and 50"] + _ -> Failure ["canary percentage must be a whole number"] + _ -> Failure ["strategy must be rolling or canary:"] + +validateWindow :: Maybe String -> Validation [String] MaintenanceWindow +validateWindow Nothing = Failure ["window is required"] +validateWindow (Just rawValue) = + case break (== '-') rawValue of + (rawStart, '-' : rawEnd) + | all isDigits [rawStart, rawEnd] -> + case (reads rawStart, reads rawEnd) of + ([(startHour, "")], [(endHour, "")]) + | startHour < 0 || endHour > 24 -> + Failure ["window hours must stay within 0 and 24"] + | startHour >= endHour -> + Failure ["window start must be before window end"] + | otherwise -> + Success + MaintenanceWindow + { windowStartHour = startHour + , windowEndHour = endHour + } + _ -> Failure ["window must use whole hours"] + | otherwise -> Failure ["window must use whole hours"] + _ -> Failure ["window must use the form start-end"] + +renderManifest :: ReleaseManifest -> String +renderManifest manifest = + intercalate + ", " + [ "service " ++ manifestService manifest + , "env " ++ renderEnvironment (manifestEnvironment manifest) + , "owners " ++ intercalate "/" (manifestOwners manifest) + , "replicas " ++ show (manifestReplicas manifest) + , "strategy " ++ renderStrategy (manifestStrategy manifest) + , "window " ++ renderWindow (manifestWindow manifest) + ] + +renderValidationErrors :: [String] -> String +renderValidationErrors errors = unlines (map ("- " ++) errors) + +renderEnvironment :: Environment -> String +renderEnvironment Staging = "staging" +renderEnvironment Production = "production" + +renderStrategy :: RolloutStrategy -> String +renderStrategy Rolling = "rolling" +renderStrategy (Canary percent) = "canary " ++ show percent ++ "%" + +renderWindow :: MaintenanceWindow -> String +renderWindow window = show (windowStartHour window) ++ "-" ++ show (windowEndHour window) + +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 + +validServiceChar :: Char -> Bool +validServiceChar nextChar = isLower nextChar || nextChar == '-' + +isDigits :: String -> Bool +isDigits = all isDigit + +hasDuplicates :: Ord value => [value] -> Bool +hasDuplicates = any ((> 1) . length) . group . quickSort + +quickSort :: Ord value => [value] -> [value] +quickSort [] = [] +quickSort (pivot : remainingValues) = + quickSort [ value | value <- remainingValues, value <= pivot ] + ++ [pivot] + ++ quickSort [ value | value <- remainingValues, value > pivot ] diff --git a/28-haskell-applicative-validation/test/Main.hs b/28-haskell-applicative-validation/test/Main.hs new file mode 100644 index 0000000..db87ab5 --- /dev/null +++ b/28-haskell-applicative-validation/test/Main.hs @@ -0,0 +1,47 @@ +module Main where + +import MiniValidation.Manifest + ( Environment (Production) + , MaintenanceWindow (MaintenanceWindow) + , ReleaseManifest (ReleaseManifest) + , RolloutStrategy (Canary) + , Validation (Failure, Success) + , readRawManifest + , renderManifest + , validateManifest + ) +import System.Exit (die) + +main :: IO () +main = + case + ( readRawManifest + [ "service=api-gateway" + , "env=production" + , "owners=platform,security" + , "replicas=3" + , "strategy=canary:20" + , "window=22-24" + ] + , readRawManifest + [ "service=API" + , "env=prod" + , "owners=platform,platform" + , "replicas=1" + , "strategy=canary:75" + , "window=24-20" + ] + ) of + ( Right validRawManifest + , Right invalidRawManifest + ) -> + case (validateManifest validRawManifest, validateManifest invalidRawManifest) of + ( Success (ReleaseManifest "api-gateway" Production ["platform", "security"] 3 (Canary 20) (MaintenanceWindow 22 24)) + , Failure validationErrors + ) | renderManifest + (ReleaseManifest "api-gateway" Production ["platform", "security"] 3 (Canary 20) (MaintenanceWindow 22 24)) + == "service api-gateway, env production, owners platform/security, replicas 3, strategy canary 20%, window 22-24" + && length validationErrors == 6 -> + putStrLn "test passed" + _ -> die "unexpected validation result" + _ -> die "unexpected manifest parse result" diff --git a/29-haskell-foldmap-summary/README.md b/29-haskell-foldmap-summary/README.md new file mode 100644 index 0000000..80cb72f --- /dev/null +++ b/29-haskell-foldmap-summary/README.md @@ -0,0 +1,25 @@ +# 29-haskell-foldmap-summary + +This example shows intermediate Haskell aggregation with `foldMap` and monoids. + +It includes: + +- a structured deployment event type, +- a summary type built from monoidal fields, +- one `foldMap` pass that aggregates several useful metrics, and +- a test suite run by `nix flake check`. + +Useful commands: + +```bash +nix develop +cabal run +cabal run -- api:production:succeeded:3:platform,security worker:staging:failed-db-lock:1:ops ui:production:cancelled:2:frontend +cabal test + +nix build +./result/bin/mini-summary api:production:succeeded:3:platform,security worker:staging:failed-db-lock:1:ops ui:production:cancelled:2:frontend + +nix run . -- api:production:succeeded:3:platform,security worker:staging:failed-db-lock:1:ops ui:production:cancelled:2:frontend +nix flake check +``` diff --git a/29-haskell-foldmap-summary/app/Main.hs b/29-haskell-foldmap-summary/app/Main.hs new file mode 100644 index 0000000..cb8f34c --- /dev/null +++ b/29-haskell-foldmap-summary/app/Main.hs @@ -0,0 +1,25 @@ +module Main where + +import MiniSummary.Report + ( parseEvent + , renderSummary + , summarizeEvents + ) +import System.Environment (getArgs) +import System.Exit (die) + +main :: IO () +main = do + args <- getArgs + let inputArgs = + case args of + [] -> + [ "api:production:succeeded:3:platform,security" + , "worker:staging:failed-db-lock:1:ops" + , "ui:production:cancelled:2:frontend" + ] + _ -> args + + case traverse parseEvent inputArgs of + Left err -> die err + Right events -> putStrLn (renderSummary (summarizeEvents events)) diff --git a/29-haskell-foldmap-summary/flake.lock b/29-haskell-foldmap-summary/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/29-haskell-foldmap-summary/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/29-haskell-foldmap-summary/flake.nix b/29-haskell-foldmap-summary/flake.nix new file mode 100644 index 0000000..ca3aa17 --- /dev/null +++ b/29-haskell-foldmap-summary/flake.nix @@ -0,0 +1,38 @@ +{ + # Builds a Haskell project that summarizes deployment events with foldMap + # and monoidal summary values. + description = "A Haskell project for foldMap summaries"; + + 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-summary" ./. { }; + checkedProject = pkgs.haskell.lib.doCheck project; + in + { + packages.${system}.default = project; + + apps.${system}.default = { + type = "app"; + program = "${self.packages.${system}.default}/bin/mini-summary"; + meta.description = "Run the foldMap summary example."; + }; + + devShells.${system}.default = pkgs.mkShell { + packages = [ + haskellPackages.ghc + pkgs.cabal-install + pkgs.haskell-language-server + ]; + }; + + checks.${system}.test-suite = checkedProject; + }; +} diff --git a/29-haskell-foldmap-summary/mini-summary.cabal b/29-haskell-foldmap-summary/mini-summary.cabal new file mode 100644 index 0000000..7112545 --- /dev/null +++ b/29-haskell-foldmap-summary/mini-summary.cabal @@ -0,0 +1,30 @@ +cabal-version: 2.4 +name: mini-summary +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MiniSummary.Report + hs-source-dirs: src + build-depends: + base >=4.14 && <5, + containers + default-language: Haskell2010 + +executable mini-summary + main-is: Main.hs + hs-source-dirs: app + build-depends: + base >=4.14 && <5, + mini-summary + default-language: Haskell2010 + +test-suite mini-summary-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base >=4.14 && <5, + containers, + mini-summary + default-language: Haskell2010 diff --git a/29-haskell-foldmap-summary/src/MiniSummary/Report.hs b/29-haskell-foldmap-summary/src/MiniSummary/Report.hs new file mode 100644 index 0000000..07e1601 --- /dev/null +++ b/29-haskell-foldmap-summary/src/MiniSummary/Report.hs @@ -0,0 +1,190 @@ +module MiniSummary.Report where + +import Data.List (intercalate) +import qualified Data.Set as Set +import Data.Set (Set) + +data Environment + = Staging + | Production + deriving (Eq, Ord, Show) + +data DeploymentStatus + = Succeeded + | Failed String + | Cancelled + deriving (Eq, Ord, Show) + +data DeploymentEvent = DeploymentEvent + { eventService :: String + , eventEnvironment :: Environment + , eventStatus :: DeploymentStatus + , eventReplicas :: Int + , eventOwners :: [String] + } + deriving (Eq, Show) + +newtype Count = Count + { unCount :: Int + } + deriving (Eq, Show) + +instance Semigroup Count where + Count leftValue <> Count rightValue = Count (leftValue + rightValue) + +instance Monoid Count where + mempty = Count 0 + +newtype LargestReplicas = LargestReplicas + { unLargestReplicas :: Int + } + deriving (Eq, Show) + +instance Semigroup LargestReplicas where + LargestReplicas leftValue <> LargestReplicas rightValue = + LargestReplicas (max leftValue rightValue) + +instance Monoid LargestReplicas where + mempty = LargestReplicas 0 + +newtype CancelledSeen = CancelledSeen + { unCancelledSeen :: Bool + } + deriving (Eq, Show) + +instance Semigroup CancelledSeen where + CancelledSeen leftValue <> CancelledSeen rightValue = CancelledSeen (leftValue || rightValue) + +instance Monoid CancelledSeen where + mempty = CancelledSeen False + +data DeploymentSummary = DeploymentSummary + { totalDeployments :: Count + , productionDeployments :: Count + , totalReplicas :: Count + , failedServices :: Set String + , activeOwners :: Set String + , cancelledSeen :: CancelledSeen + , largestReplicaCount :: LargestReplicas + } + deriving (Eq, Show) + +instance Semigroup DeploymentSummary where + leftSummary <> rightSummary = + DeploymentSummary + { totalDeployments = totalDeployments leftSummary <> totalDeployments rightSummary + , productionDeployments = productionDeployments leftSummary <> productionDeployments rightSummary + , totalReplicas = totalReplicas leftSummary <> totalReplicas rightSummary + , failedServices = failedServices leftSummary <> failedServices rightSummary + , activeOwners = activeOwners leftSummary <> activeOwners rightSummary + , cancelledSeen = cancelledSeen leftSummary <> cancelledSeen rightSummary + , largestReplicaCount = largestReplicaCount leftSummary <> largestReplicaCount rightSummary + } + +instance Monoid DeploymentSummary where + mempty = + DeploymentSummary + { totalDeployments = mempty + , productionDeployments = mempty + , totalReplicas = mempty + , failedServices = mempty + , activeOwners = mempty + , cancelledSeen = mempty + , largestReplicaCount = mempty + } + +parseEvent :: String -> Either String DeploymentEvent +parseEvent rawEvent = + case splitOn ':' rawEvent of + [serviceName, environmentName, statusName, rawReplicas, rawOwners] -> do + environment <- parseEnvironment environmentName + status <- parseStatus statusName + replicas <- parseReplicas rawReplicas + let owners = splitOn ',' rawOwners + if any null owners then + Left "owners must not contain empty entries" + else + Right + DeploymentEvent + { eventService = serviceName + , eventEnvironment = environment + , eventStatus = status + , eventReplicas = replicas + , eventOwners = owners + } + _ -> Left ("expected ::::, got: " ++ rawEvent) + +parseEnvironment :: String -> Either String Environment +parseEnvironment "staging" = Right Staging +parseEnvironment "production" = Right Production +parseEnvironment otherValue = Left ("unknown environment: " ++ otherValue) + +parseStatus :: String -> Either String DeploymentStatus +parseStatus "succeeded" = Right Succeeded +parseStatus "cancelled" = Right Cancelled +parseStatus rawStatus = + case splitOn '-' rawStatus of + "failed" : reasonParts + | not (null reasonParts) -> Right (Failed (intercalate "-" reasonParts)) + _ -> Left ("unknown status: " ++ rawStatus) + +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) + +summarizeEvents :: [DeploymentEvent] -> DeploymentSummary +summarizeEvents = foldMap summarizeEvent + +summarizeEvent :: DeploymentEvent -> DeploymentSummary +summarizeEvent deploymentEvent = + DeploymentSummary + { totalDeployments = Count 1 + , productionDeployments = + case eventEnvironment deploymentEvent of + Production -> Count 1 + Staging -> Count 0 + , totalReplicas = Count (eventReplicas deploymentEvent) + , failedServices = + case eventStatus deploymentEvent of + Failed _ -> Set.singleton (eventService deploymentEvent) + _ -> Set.empty + , activeOwners = Set.fromList (eventOwners deploymentEvent) + , cancelledSeen = + case eventStatus deploymentEvent of + Cancelled -> CancelledSeen True + _ -> CancelledSeen False + , largestReplicaCount = LargestReplicas (eventReplicas deploymentEvent) + } + +renderSummary :: DeploymentSummary -> String +renderSummary summary = + unlines + [ "total deployments: " ++ show (unCount (totalDeployments summary)) + , "production deployments: " ++ show (unCount (productionDeployments summary)) + , "total replicas: " ++ show (unCount (totalReplicas summary)) + , "largest rollout: " ++ show (unLargestReplicas (largestReplicaCount summary)) + , "cancelled seen: " ++ renderBool (unCancelledSeen (cancelledSeen summary)) + , "failed services: " ++ renderSet (failedServices summary) + , "owners: " ++ renderSet (activeOwners summary) + ] + +renderBool :: Bool -> String +renderBool True = "yes" +renderBool False = "no" + +renderSet :: Set String -> String +renderSet values + | Set.null values = "none" + | otherwise = intercalate ", " (Set.toAscList values) + +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/29-haskell-foldmap-summary/test/Main.hs b/29-haskell-foldmap-summary/test/Main.hs new file mode 100644 index 0000000..6d20bbe --- /dev/null +++ b/29-haskell-foldmap-summary/test/Main.hs @@ -0,0 +1,38 @@ +module Main where + +import MiniSummary.Report + ( Count (Count) + , DeploymentSummary (..) + , LargestReplicas (LargestReplicas) + , parseEvent + , renderSummary + , summarizeEvents + ) +import qualified Data.Set as Set +import System.Exit (die) + +main :: IO () +main = + case + traverse + parseEvent + [ "api:production:succeeded:3:platform,security" + , "worker:staging:failed-db-lock:1:ops" + , "ui:production:cancelled:2:frontend" + ] of + Left err -> die err + Right events -> + case summarizeEvents events of + DeploymentSummary + { totalDeployments = Count 3 + , productionDeployments = Count 2 + , totalReplicas = Count 6 + , failedServices = failedServicesSet + , activeOwners = ownerSet + , largestReplicaCount = LargestReplicas 3 + } + | failedServicesSet == Set.fromList ["worker"] + && ownerSet == Set.fromList ["frontend", "ops", "platform", "security"] + && "cancelled seen: yes" `elem` lines (renderSummary (summarizeEvents events)) -> + putStrLn "test passed" + _ -> die "unexpected foldMap summary result" diff --git a/notes/014-haskell-learning-path.md b/notes/014-haskell-learning-path.md index 353b62d..c241087 100644 --- a/notes/014-haskell-learning-path.md +++ b/notes/014-haskell-learning-path.md @@ -19,6 +19,8 @@ This note links the Haskell examples in a suggested order from first project str 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 +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 --- @@ -37,6 +39,8 @@ This note links the Haskell examples in a suggested order from first project str - `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 +- `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 --- @@ -55,3 +59,5 @@ This note links the Haskell examples in a suggested order from first project str - `notes/028-haskell-state.md` - `notes/029-haskell-quickcheck.md` - `notes/030-haskell-aeson-roundtrip.md` +- `notes/031-haskell-applicative-validation.md` +- `notes/032-haskell-foldmap-summary.md` diff --git a/notes/031-haskell-applicative-validation.md b/notes/031-haskell-applicative-validation.md new file mode 100644 index 0000000..1a6edc6 --- /dev/null +++ b/notes/031-haskell-applicative-validation.md @@ -0,0 +1,79 @@ +# Haskell Applicative Validation + +This note covers `28-haskell-applicative-validation/`, which validates a release manifest with a custom `Validation` type that accumulates several +field errors at once. + +--- + +## 1. Why This Is Not Just `Either` + +`Either` stops at the first failure. That is useful for many workflows, but it is not always the best fit for validating a form-like input. + +This example wants a different behavior: + +- validate `service`, +- validate `env`, +- validate `owners`, +- validate `replicas`, +- validate `strategy`, and +- validate `window`, + +and report every invalid field in one pass. + +That is why the example uses a `Validation` type with an `Applicative` instance that combines errors through `Semigroup`. + +--- + +## 2. Where the Accumulation Happens + +The important function is: + +```haskell +validateManifest :: RawManifest -> Validation [String] ReleaseManifest +``` + +It builds the final manifest with applicative style: + +```haskell +ReleaseManifest + <$> validateService ... + <*> validateEnvironment ... + <*> validateOwners ... + <*> validateReplicas ... + <*> validateStrategy ... + <*> validateWindow ... +``` + +Each field validator can fail independently, and the `Applicative` instance combines all the resulting error lists. + +--- + +## 3. Why the Input Is Split into Two Stages + +The example still parses `key=value` assignments with `Either`. + +That keeps syntax errors separate from semantic validation: + +- malformed assignments such as `service` or `owners=` fail immediately, and +- well-shaped assignments become a `RawManifest` that the validation layer can inspect field by field. + +This separation keeps the example focused. The interesting part is accumulated validation, not ad hoc string parsing. + +--- + +## 4. Commands to Try + +```bash +cd 28-haskell-applicative-validation + +nix develop +cabal run +cabal run -- service=api-gateway env=production owners=platform,security replicas=3 strategy=canary:20 window=22-24 +cabal test + +nix build +./result/bin/mini-validation service=api-gateway env=production owners=platform,security replicas=3 strategy=canary:20 window=22-24 + +nix run . -- service=api-gateway env=production owners=platform,security replicas=3 strategy=canary:20 window=22-24 +nix flake check +``` diff --git a/notes/032-haskell-foldmap-summary.md b/notes/032-haskell-foldmap-summary.md new file mode 100644 index 0000000..0872e36 --- /dev/null +++ b/notes/032-haskell-foldmap-summary.md @@ -0,0 +1,71 @@ +# Haskell foldMap Summaries + +This note covers `29-haskell-foldmap-summary/`, which summarizes deployment events with one `foldMap` pass into a monoidal report value. + +--- + +## 1. Why `foldMap` Fits This Problem + +Each deployment event contributes a small piece of information: + +- one deployment count, +- maybe one production count, +- some replica count, +- maybe one failed service, +- some owners, +- maybe one cancellation flag, and +- one candidate for the largest rollout. + +Those pieces all combine associatively, which makes the problem a good fit for monoids. + +The example expresses that directly: + +```haskell +summarizeEvents :: [DeploymentEvent] -> DeploymentSummary +summarizeEvents = foldMap summarizeEvent +``` + +--- + +## 2. What the Summary Type Encodes + +`DeploymentSummary` is not one big counter. It is a record of smaller monoidal fields: + +- `Count` for totals, +- `Set String` for failed services and owners, +- `CancelledSeen` for a yes-or-no flag, and +- `LargestReplicas` for the maximum rollout size. + +That is the main teaching point: when each field has a lawful combine operation, the whole summary can combine cleanly too. + +--- + +## 3. Why This Is Better Than a Manual Loop + +The example could have used an explicit left fold and updated every field by hand inside the loop. + +`foldMap` is cleaner here because it splits the work into two precise ideas: + +1. how one event becomes a summary fragment, and +2. how summary fragments combine. + +That makes the aggregation easier to extend without tangling the parsing and report logic. + +--- + +## 4. Commands to Try + +```bash +cd 29-haskell-foldmap-summary + +nix develop +cabal run +cabal run -- api:production:succeeded:3:platform,security worker:staging:failed-db-lock:1:ops ui:production:cancelled:2:frontend +cabal test + +nix build +./result/bin/mini-summary api:production:succeeded:3:platform,security worker:staging:failed-db-lock:1:ops ui:production:cancelled:2:frontend + +nix run . -- api:production:succeeded:3:platform,security worker:staging:failed-db-lock:1:ops ui:production:cancelled:2:frontend +nix flake check +```