From f7172b38b2a4792296c34be574c90ea45d63f8d5 Mon Sep 17 00:00:00 2001 From: Hassan Abedi Date: Wed, 29 Apr 2026 10:11:55 +0200 Subject: [PATCH] Add three new Haskell examples (with their note files) --- 32-haskell-nonempty-waves/README.md | 25 +++ 32-haskell-nonempty-waves/app/Main.hs | 21 +++ 32-haskell-nonempty-waves/flake.lock | 27 +++ 32-haskell-nonempty-waves/flake.nix | 38 +++++ 32-haskell-nonempty-waves/mini-waves.cabal | 28 ++++ .../src/MiniWaves/Plan.hs | 132 +++++++++++++++ 32-haskell-nonempty-waves/test/Main.hs | 29 ++++ 33-haskell-optparse-cli/README.md | 26 +++ 33-haskell-optparse-cli/app/Main.hs | 30 ++++ 33-haskell-optparse-cli/flake.lock | 27 +++ 33-haskell-optparse-cli/flake.nix | 38 +++++ 33-haskell-optparse-cli/mini-cli.cabal | 29 ++++ .../src/MiniCli/Command.hs | 154 ++++++++++++++++++ 33-haskell-optparse-cli/test/Main.hs | 26 +++ 34-haskell-dependency-order/README.md | 25 +++ 34-haskell-dependency-order/app/Main.hs | 21 +++ 34-haskell-dependency-order/flake.lock | 27 +++ 34-haskell-dependency-order/flake.nix | 38 +++++ .../mini-dependency-order.cabal | 30 ++++ .../src/MiniDependency/Order.hs | 100 ++++++++++++ 34-haskell-dependency-order/test/Main.hs | 49 ++++++ notes/014-haskell-learning-path.md | 9 + notes/035-haskell-nonempty-waves.md | 58 +++++++ notes/036-haskell-optparse-cli.md | 63 +++++++ notes/037-haskell-dependency-order.md | 56 +++++++ 25 files changed, 1106 insertions(+) create mode 100644 32-haskell-nonempty-waves/README.md create mode 100644 32-haskell-nonempty-waves/app/Main.hs create mode 100644 32-haskell-nonempty-waves/flake.lock create mode 100644 32-haskell-nonempty-waves/flake.nix create mode 100644 32-haskell-nonempty-waves/mini-waves.cabal create mode 100644 32-haskell-nonempty-waves/src/MiniWaves/Plan.hs create mode 100644 32-haskell-nonempty-waves/test/Main.hs create mode 100644 33-haskell-optparse-cli/README.md create mode 100644 33-haskell-optparse-cli/app/Main.hs create mode 100644 33-haskell-optparse-cli/flake.lock create mode 100644 33-haskell-optparse-cli/flake.nix create mode 100644 33-haskell-optparse-cli/mini-cli.cabal create mode 100644 33-haskell-optparse-cli/src/MiniCli/Command.hs create mode 100644 33-haskell-optparse-cli/test/Main.hs create mode 100644 34-haskell-dependency-order/README.md create mode 100644 34-haskell-dependency-order/app/Main.hs create mode 100644 34-haskell-dependency-order/flake.lock create mode 100644 34-haskell-dependency-order/flake.nix create mode 100644 34-haskell-dependency-order/mini-dependency-order.cabal create mode 100644 34-haskell-dependency-order/src/MiniDependency/Order.hs create mode 100644 34-haskell-dependency-order/test/Main.hs create mode 100644 notes/035-haskell-nonempty-waves.md create mode 100644 notes/036-haskell-optparse-cli.md create mode 100644 notes/037-haskell-dependency-order.md diff --git a/32-haskell-nonempty-waves/README.md b/32-haskell-nonempty-waves/README.md new file mode 100644 index 0000000..60e6442 --- /dev/null +++ b/32-haskell-nonempty-waves/README.md @@ -0,0 +1,25 @@ +# 32-haskell-nonempty-waves + +This example shows intermediate Haskell rollout planning with `NonEmpty`. + +It includes: + +- a deployment job with rolling and canary modes, +- a `NonEmpty` list of rollout waves that guarantees at least one step, +- a CLI that renders a wave-by-wave plan, and +- a test suite run by `nix flake check`. + +Useful commands: + +```bash +nix develop +cabal run +cabal run -- api:production:canary:20:6 +cabal test + +nix build +./result/bin/mini-waves api:production:canary:20:6 + +nix run . -- api:production:canary:20:6 +nix flake check +``` diff --git a/32-haskell-nonempty-waves/app/Main.hs b/32-haskell-nonempty-waves/app/Main.hs new file mode 100644 index 0000000..f322229 --- /dev/null +++ b/32-haskell-nonempty-waves/app/Main.hs @@ -0,0 +1,21 @@ +module Main where + +import MiniWaves.Plan + ( buildPlan + , parseJob + , renderPlan + ) +import System.Environment (getArgs) +import System.Exit (die) + +main :: IO () +main = do + args <- getArgs + let inputArg = + case args of + [] -> "api:production:canary:20:6" + firstArg : _ -> firstArg + + case parseJob inputArg of + Left err -> die err + Right releaseJob -> putStrLn (renderPlan (buildPlan releaseJob)) diff --git a/32-haskell-nonempty-waves/flake.lock b/32-haskell-nonempty-waves/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/32-haskell-nonempty-waves/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/32-haskell-nonempty-waves/flake.nix b/32-haskell-nonempty-waves/flake.nix new file mode 100644 index 0000000..2a97509 --- /dev/null +++ b/32-haskell-nonempty-waves/flake.nix @@ -0,0 +1,38 @@ +{ + # Builds a Haskell project that models rollout waves with NonEmpty so every + # deployment plan is guaranteed to contain at least one step. + description = "A Haskell project for NonEmpty rollout waves"; + + 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-waves" ./. { }; + checkedProject = pkgs.haskell.lib.doCheck project; + in + { + packages.${system}.default = project; + + apps.${system}.default = { + type = "app"; + program = "${self.packages.${system}.default}/bin/mini-waves"; + meta.description = "Run the NonEmpty rollout wave example."; + }; + + devShells.${system}.default = pkgs.mkShell { + packages = [ + haskellPackages.ghc + pkgs.cabal-install + pkgs.haskell-language-server + ]; + }; + + checks.${system}.test-suite = checkedProject; + }; +} diff --git a/32-haskell-nonempty-waves/mini-waves.cabal b/32-haskell-nonempty-waves/mini-waves.cabal new file mode 100644 index 0000000..9c95382 --- /dev/null +++ b/32-haskell-nonempty-waves/mini-waves.cabal @@ -0,0 +1,28 @@ +cabal-version: 2.4 +name: mini-waves +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MiniWaves.Plan + hs-source-dirs: src + build-depends: + base >=4.14 && <5 + default-language: Haskell2010 + +executable mini-waves + main-is: Main.hs + hs-source-dirs: app + build-depends: + base >=4.14 && <5, + mini-waves + default-language: Haskell2010 + +test-suite mini-waves-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base >=4.14 && <5, + mini-waves + default-language: Haskell2010 diff --git a/32-haskell-nonempty-waves/src/MiniWaves/Plan.hs b/32-haskell-nonempty-waves/src/MiniWaves/Plan.hs new file mode 100644 index 0000000..162de8b --- /dev/null +++ b/32-haskell-nonempty-waves/src/MiniWaves/Plan.hs @@ -0,0 +1,132 @@ +module MiniWaves.Plan where + +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NonEmpty + +data Environment + = Staging + | Production + deriving (Eq, Show) + +data ReleaseMode + = Rolling + | Canary Int + deriving (Eq, Show) + +data ReleaseJob = ReleaseJob + { jobService :: String + , jobEnvironment :: Environment + , jobMode :: ReleaseMode + , jobReplicas :: Int + } + deriving (Eq, Show) + +data Wave = Wave + { waveName :: String + , waveTrafficPercent :: Int + , waveReplicas :: Int + } + deriving (Eq, Show) + +data RolloutPlan = RolloutPlan + { planService :: String + , planEnvironment :: Environment + , planWaves :: NonEmpty Wave + } + deriving (Eq, Show) + +parseJob :: String -> Either String ReleaseJob +parseJob rawJob = + case splitOn ':' rawJob of + [serviceName, environmentName, modeName, rawPercent, rawReplicas] -> do + environment <- parseEnvironment environmentName + mode <- parseMode modeName rawPercent + replicas <- parseReplicas rawReplicas + pure + ReleaseJob + { jobService = serviceName + , jobEnvironment = environment + , jobMode = mode + , jobReplicas = replicas + } + _ -> Left ("expected ::::, got: " ++ rawJob) + +buildPlan :: ReleaseJob -> RolloutPlan +buildPlan releaseJob = + RolloutPlan + { planService = jobService releaseJob + , planEnvironment = jobEnvironment releaseJob + , planWaves = buildWaves releaseJob + } + +buildWaves :: ReleaseJob -> NonEmpty Wave +buildWaves releaseJob = + case jobMode releaseJob of + Rolling -> + Wave "full" 100 (jobReplicas releaseJob) :| [] + Canary percent -> + let canaryReplicas = max 1 (jobReplicas releaseJob `div` 2) + in Wave "canary" percent canaryReplicas + :| [Wave "steady" 100 (jobReplicas releaseJob)] + +renderPlan :: RolloutPlan -> String +renderPlan rolloutPlan = + unlines + ( headerLine + : map renderWave (NonEmpty.toList (planWaves rolloutPlan)) + ) + where + headerLine = + intercalate + ", " + [ planService rolloutPlan ++ " -> " ++ renderEnvironment (planEnvironment rolloutPlan) + , "waves " ++ show (NonEmpty.length (planWaves rolloutPlan)) + , "first " ++ waveName (NonEmpty.head (planWaves rolloutPlan)) + , "last " ++ waveName (NonEmpty.last (planWaves rolloutPlan)) + ] + +renderWave :: Wave -> String +renderWave wave = + waveName wave + ++ ": " + ++ show (waveTrafficPercent wave) + ++ "% traffic, " + ++ show (waveReplicas wave) + ++ " replicas" + +parseEnvironment :: String -> Either String Environment +parseEnvironment "staging" = Right Staging +parseEnvironment "production" = Right Production +parseEnvironment otherValue = Left ("unknown environment: " ++ otherValue) + +parseMode :: String -> String -> Either String ReleaseMode +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" + +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/32-haskell-nonempty-waves/test/Main.hs b/32-haskell-nonempty-waves/test/Main.hs new file mode 100644 index 0000000..fb57fe4 --- /dev/null +++ b/32-haskell-nonempty-waves/test/Main.hs @@ -0,0 +1,29 @@ +module Main where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NonEmpty +import MiniWaves.Plan + ( Environment (Production, Staging) + , ReleaseMode (Canary, Rolling) + , RolloutPlan (RolloutPlan) + , Wave (Wave) + , buildPlan + , parseJob + , renderPlan + ) +import System.Exit (die) + +main :: IO () +main = + case (parseJob "api:production:canary:20:6", parseJob "worker:staging:rolling:0:2") of + ( Right canaryJob + , Right rollingJob + ) -> + case (buildPlan canaryJob, buildPlan rollingJob) of + ( RolloutPlan "api" Production (Wave "canary" 20 3 :| [Wave "steady" 100 6]) + , RolloutPlan "worker" Staging (Wave "full" 100 2 :| []) + ) | "worker -> staging, waves 1, first full, last full" + `elem` lines (renderPlan (buildPlan rollingJob)) -> + putStrLn "test passed" + _ -> die "unexpected NonEmpty wave plan" + _ -> die "unexpected rollout parse result" diff --git a/33-haskell-optparse-cli/README.md b/33-haskell-optparse-cli/README.md new file mode 100644 index 0000000..2f1b36b --- /dev/null +++ b/33-haskell-optparse-cli/README.md @@ -0,0 +1,26 @@ +# 33-haskell-optparse-cli + +This example shows intermediate Haskell CLI parsing with `optparse-applicative`. + +It includes: + +- subcommands for validation and promotion, +- named options, repeated options, and typed numeric parsing, +- a pure parser entry point that the test suite exercises, and +- a test suite run by `nix flake check`. + +Useful commands: + +```bash +nix develop +cabal run +cabal run -- validate --service api --env production --replicas 3 --track stable +cabal run -- promote --service api --from-tag blue --to-tag green --owner platform --owner security --dry-run +cabal test + +nix build +./result/bin/mini-cli validate --service api --env production --replicas 3 --track stable + +nix run . -- validate --service api --env production --replicas 3 --track stable +nix flake check +``` diff --git a/33-haskell-optparse-cli/app/Main.hs b/33-haskell-optparse-cli/app/Main.hs new file mode 100644 index 0000000..fe82628 --- /dev/null +++ b/33-haskell-optparse-cli/app/Main.hs @@ -0,0 +1,30 @@ +module Main where + +import MiniCli.Command + ( renderCommand + , runCliParser + ) +import System.Environment (getArgs) +import System.Exit (die) + +main :: IO () +main = do + args <- getArgs + let inputArgs = + case args of + [] -> + [ "validate" + , "--service" + , "api" + , "--env" + , "production" + , "--replicas" + , "3" + , "--track" + , "stable" + ] + _ -> args + + case runCliParser inputArgs of + Left err -> die err + Right commandValue -> putStrLn (renderCommand commandValue) diff --git a/33-haskell-optparse-cli/flake.lock b/33-haskell-optparse-cli/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/33-haskell-optparse-cli/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/33-haskell-optparse-cli/flake.nix b/33-haskell-optparse-cli/flake.nix new file mode 100644 index 0000000..c49f88b --- /dev/null +++ b/33-haskell-optparse-cli/flake.nix @@ -0,0 +1,38 @@ +{ + # Builds a Haskell project that parses a non-trivial CLI with + # optparse-applicative subcommands and repeated options. + description = "A Haskell project for optparse-applicative"; + + 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-cli" ./. { }; + checkedProject = pkgs.haskell.lib.doCheck project; + in + { + packages.${system}.default = project; + + apps.${system}.default = { + type = "app"; + program = "${self.packages.${system}.default}/bin/mini-cli"; + meta.description = "Run the optparse-applicative example."; + }; + + devShells.${system}.default = pkgs.mkShell { + packages = [ + haskellPackages.ghc + pkgs.cabal-install + pkgs.haskell-language-server + ]; + }; + + checks.${system}.test-suite = checkedProject; + }; +} diff --git a/33-haskell-optparse-cli/mini-cli.cabal b/33-haskell-optparse-cli/mini-cli.cabal new file mode 100644 index 0000000..bc2363d --- /dev/null +++ b/33-haskell-optparse-cli/mini-cli.cabal @@ -0,0 +1,29 @@ +cabal-version: 2.4 +name: mini-cli +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MiniCli.Command + hs-source-dirs: src + build-depends: + base >=4.14 && <5, + optparse-applicative + default-language: Haskell2010 + +executable mini-cli + main-is: Main.hs + hs-source-dirs: app + build-depends: + base >=4.14 && <5, + mini-cli + default-language: Haskell2010 + +test-suite mini-cli-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base >=4.14 && <5, + mini-cli + default-language: Haskell2010 diff --git a/33-haskell-optparse-cli/src/MiniCli/Command.hs b/33-haskell-optparse-cli/src/MiniCli/Command.hs new file mode 100644 index 0000000..5ee6bd9 --- /dev/null +++ b/33-haskell-optparse-cli/src/MiniCli/Command.hs @@ -0,0 +1,154 @@ +module MiniCli.Command where + +import Data.Char (isSpace) +import Data.List (intercalate) +import Options.Applicative + ( Parser + , ParserInfo + , ParserResult (Failure, Success) + , ReadM + , command + , eitherReader + , execParserPure + , fullDesc + , help + , helper + , hsubparser + , info + , long + , metavar + , option + , prefs + , progDesc + , renderFailure + , some + , strOption + , switch + , (<**>) + ) + +data Environment + = Staging + | Production + deriving (Eq, Show) + +data ReleaseTrack + = Stable + | Candidate + deriving (Eq, Show) + +data ValidateSpec = ValidateSpec + { validateService :: String + , validateEnvironment :: Environment + , validateReplicas :: Int + , validateTrack :: ReleaseTrack + } + deriving (Eq, Show) + +data PromoteSpec = PromoteSpec + { promoteService :: String + , fromTag :: String + , toTag :: String + , owners :: [String] + , dryRun :: Bool + } + deriving (Eq, Show) + +data Command + = ValidateCommand ValidateSpec + | PromoteCommand PromoteSpec + deriving (Eq, Show) + +runCliParser :: [String] -> Either String Command +runCliParser inputArgs = + case execParserPure (prefs mempty) parserInfo inputArgs of + Success commandValue -> Right commandValue + Failure parserFailure -> + let (message, _) = renderFailure parserFailure "mini-cli" + in Left (trimTrailingWhitespace message) + +renderCommand :: Command -> String +renderCommand (ValidateCommand validateSpec) = + intercalate + ", " + [ "validate " ++ validateService validateSpec + , "env " ++ renderEnvironment (validateEnvironment validateSpec) + , "replicas " ++ show (validateReplicas validateSpec) + , "track " ++ renderTrack (validateTrack validateSpec) + ] +renderCommand (PromoteCommand promoteSpec) = + intercalate + ", " + [ "promote " ++ promoteService promoteSpec + , "from " ++ fromTag promoteSpec + , "to " ++ toTag promoteSpec + , "owners " ++ intercalate "/" (owners promoteSpec) + , "dry-run " ++ renderBool (dryRun promoteSpec) + ] + +parserInfo :: ParserInfo Command +parserInfo = info (commandParser <**> helper) fullDesc + +commandParser :: Parser Command +commandParser = + hsubparser + ( command "validate" (info (ValidateCommand <$> validateSpecParser) (progDesc "Validate a release specification")) + <> command "promote" (info (PromoteCommand <$> promoteSpecParser) (progDesc "Promote a deployment tag")) + ) + +validateSpecParser :: Parser ValidateSpec +validateSpecParser = + ValidateSpec + <$> strOption (long "service" <> help "Service name" <> metavar "SERVICE") + <*> option environmentReader (long "env" <> help "Deployment environment" <> metavar "ENV") + <*> option intReader (long "replicas" <> help "Replica count" <> metavar "COUNT") + <*> option trackReader (long "track" <> help "Release track" <> metavar "TRACK") + +promoteSpecParser :: Parser PromoteSpec +promoteSpecParser = + PromoteSpec + <$> strOption (long "service" <> help "Service name" <> metavar "SERVICE") + <*> strOption (long "from-tag" <> help "Current deployment tag" <> metavar "TAG") + <*> strOption (long "to-tag" <> help "Target deployment tag" <> metavar "TAG") + <*> some (strOption (long "owner" <> help "Responsible owner" <> metavar "OWNER")) + <*> switch (long "dry-run" <> help "Do not apply the promotion") + +environmentReader :: ReadM Environment +environmentReader = + eitherReader $ \rawValue -> + case rawValue of + "staging" -> Right Staging + "production" -> Right Production + _ -> Left ("expected staging or production, got: " ++ rawValue) + +trackReader :: ReadM ReleaseTrack +trackReader = + eitherReader $ \rawValue -> + case rawValue of + "stable" -> Right Stable + "candidate" -> Right Candidate + _ -> Left ("expected stable or candidate, got: " ++ rawValue) + +intReader :: ReadM Int +intReader = + eitherReader $ \rawValue -> + case reads rawValue of + [(intValue, "")] + | intValue > 0 -> Right intValue + | otherwise -> Left "replicas must be greater than zero" + _ -> Left ("invalid integer: " ++ rawValue) + +renderEnvironment :: Environment -> String +renderEnvironment Staging = "staging" +renderEnvironment Production = "production" + +renderTrack :: ReleaseTrack -> String +renderTrack Stable = "stable" +renderTrack Candidate = "candidate" + +renderBool :: Bool -> String +renderBool True = "yes" +renderBool False = "no" + +trimTrailingWhitespace :: String -> String +trimTrailingWhitespace = reverse . dropWhile isSpace . reverse diff --git a/33-haskell-optparse-cli/test/Main.hs b/33-haskell-optparse-cli/test/Main.hs new file mode 100644 index 0000000..d980686 --- /dev/null +++ b/33-haskell-optparse-cli/test/Main.hs @@ -0,0 +1,26 @@ +module Main where + +import MiniCli.Command + ( Command (PromoteCommand, ValidateCommand) + , Environment (Production) + , PromoteSpec (PromoteSpec) + , ReleaseTrack (Stable) + , ValidateSpec (ValidateSpec) + , renderCommand + , runCliParser + ) +import System.Exit (die) + +main :: IO () +main = + case + ( runCliParser ["validate", "--service", "api", "--env", "production", "--replicas", "3", "--track", "stable"] + , runCliParser ["promote", "--service", "api", "--from-tag", "blue", "--to-tag", "green", "--owner", "platform", "--owner", "security", "--dry-run"] + , runCliParser ["validate", "--service", "api", "--replicas", "3", "--track", "stable"] + ) of + ( Right (ValidateCommand (ValidateSpec "api" Production 3 Stable)) + , Right promoteCommand@(PromoteCommand (PromoteSpec "api" "blue" "green" ["platform", "security"] True)) + , Left _ + ) | renderCommand promoteCommand == "promote api, from blue, to green, owners platform/security, dry-run yes" -> + putStrLn "test passed" + _ -> die "unexpected optparse result" diff --git a/34-haskell-dependency-order/README.md b/34-haskell-dependency-order/README.md new file mode 100644 index 0000000..5be232f --- /dev/null +++ b/34-haskell-dependency-order/README.md @@ -0,0 +1,25 @@ +# 34-haskell-dependency-order + +This example shows intermediate Haskell dependency planning with graph traversal. + +It includes: + +- a service catalog with inter-service dependencies, +- cycle detection and unknown-service rejection, +- a deployment plan rendered in dependency order, and +- a test suite run by `nix flake check`. + +Useful commands: + +```bash +nix develop +cabal run +cabal run -- frontend billing +cabal test + +nix build +./result/bin/mini-dependency-order frontend billing + +nix run . -- frontend billing +nix flake check +``` diff --git a/34-haskell-dependency-order/app/Main.hs b/34-haskell-dependency-order/app/Main.hs new file mode 100644 index 0000000..3fa0688 --- /dev/null +++ b/34-haskell-dependency-order/app/Main.hs @@ -0,0 +1,21 @@ +module Main where + +import MiniDependency.Order + ( catalog + , renderPlan + , resolveDeploymentOrder + ) +import System.Environment (getArgs) +import System.Exit (die) + +main :: IO () +main = do + args <- getArgs + let requestedServices = + case args of + [] -> ["frontend", "billing"] + _ -> args + + case resolveDeploymentOrder catalog requestedServices of + Left err -> die err + Right deploymentPlan -> putStrLn (renderPlan deploymentPlan) diff --git a/34-haskell-dependency-order/flake.lock b/34-haskell-dependency-order/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/34-haskell-dependency-order/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/34-haskell-dependency-order/flake.nix b/34-haskell-dependency-order/flake.nix new file mode 100644 index 0000000..d478eb0 --- /dev/null +++ b/34-haskell-dependency-order/flake.nix @@ -0,0 +1,38 @@ +{ + # Builds a Haskell project that resolves deployment order from a dependency + # graph while rejecting cycles and unknown services. + description = "A Haskell project for dependency-ordered deployment plans"; + + 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-dependency-order" ./. { }; + checkedProject = pkgs.haskell.lib.doCheck project; + in + { + packages.${system}.default = project; + + apps.${system}.default = { + type = "app"; + program = "${self.packages.${system}.default}/bin/mini-dependency-order"; + meta.description = "Run the dependency-ordered deployment example."; + }; + + devShells.${system}.default = pkgs.mkShell { + packages = [ + haskellPackages.ghc + pkgs.cabal-install + pkgs.haskell-language-server + ]; + }; + + checks.${system}.test-suite = checkedProject; + }; +} diff --git a/34-haskell-dependency-order/mini-dependency-order.cabal b/34-haskell-dependency-order/mini-dependency-order.cabal new file mode 100644 index 0000000..0a8df8f --- /dev/null +++ b/34-haskell-dependency-order/mini-dependency-order.cabal @@ -0,0 +1,30 @@ +cabal-version: 2.4 +name: mini-dependency-order +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MiniDependency.Order + hs-source-dirs: src + build-depends: + base >=4.14 && <5, + containers + default-language: Haskell2010 + +executable mini-dependency-order + main-is: Main.hs + hs-source-dirs: app + build-depends: + base >=4.14 && <5, + mini-dependency-order + default-language: Haskell2010 + +test-suite mini-dependency-order-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base >=4.14 && <5, + containers, + mini-dependency-order + default-language: Haskell2010 diff --git a/34-haskell-dependency-order/src/MiniDependency/Order.hs b/34-haskell-dependency-order/src/MiniDependency/Order.hs new file mode 100644 index 0000000..2abf307 --- /dev/null +++ b/34-haskell-dependency-order/src/MiniDependency/Order.hs @@ -0,0 +1,100 @@ +module MiniDependency.Order where + +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import qualified Data.Set as Set +import Data.Set (Set) + +data ServiceProfile = ServiceProfile + { dependencyNames :: [String] + , needsMigration :: Bool + } + deriving (Eq, Show) + +data DeploymentStep = DeploymentStep + { deploymentService :: String + , deploymentDependencies :: [String] + , migrationRequired :: Bool + } + deriving (Eq, Show) + +type Catalog = Map String ServiceProfile + +catalog :: Catalog +catalog = + Map.fromList + [ ("postgres", ServiceProfile [] False) + , ("redis", ServiceProfile [] False) + , ("auth", ServiceProfile ["postgres"] True) + , ("api", ServiceProfile ["auth", "redis"] True) + , ("billing", ServiceProfile ["api", "postgres"] True) + , ("frontend", ServiceProfile ["api"] False) + ] + +resolveDeploymentOrder :: Catalog -> [String] -> Either String [DeploymentStep] +resolveDeploymentOrder serviceCatalog requestedServices = + do + (_, _, orderedSteps) <- foldl step (Right (Set.empty, Set.empty, [])) requestedServices + Right orderedSteps + where + step (Left err) _ = Left err + step (Right visitState) serviceName = visitService serviceCatalog serviceName visitState + +visitService :: + Catalog -> + String -> + (Set String, Set String, [DeploymentStep]) -> + Either String (Set String, Set String, [DeploymentStep]) +visitService serviceCatalog serviceName (visiting, visited, orderedSteps) + | Set.member serviceName visited = + Right (visiting, visited, orderedSteps) + | Set.member serviceName visiting = + Left ("dependency cycle detected at: " ++ serviceName) + | otherwise = + case Map.lookup serviceName serviceCatalog of + Nothing -> Left ("unknown service: " ++ serviceName) + Just serviceProfile -> do + (visitingAfterDeps, visitedAfterDeps, stepsAfterDeps) <- + foldl + stepDependency + (Right (Set.insert serviceName visiting, visited, orderedSteps)) + (dependencyNames serviceProfile) + Right + ( Set.delete serviceName visitingAfterDeps + , Set.insert serviceName visitedAfterDeps + , stepsAfterDeps + ++ [ DeploymentStep + { deploymentService = serviceName + , deploymentDependencies = dependencyNames serviceProfile + , migrationRequired = needsMigration serviceProfile + } + ] + ) + where + stepDependency (Left err) _ = Left err + stepDependency (Right visitState) dependencyName = + visitService serviceCatalog dependencyName visitState + +renderPlan :: [DeploymentStep] -> String +renderPlan = unlines . map renderStep + +renderStep :: DeploymentStep -> String +renderStep deploymentStep = + deploymentService deploymentStep + ++ ", deps " + ++ renderDependencies (deploymentDependencies deploymentStep) + ++ ", migration " + ++ renderBool (migrationRequired deploymentStep) + +renderDependencies :: [String] -> String +renderDependencies [] = "none" +renderDependencies dependencies = commaSeparated dependencies + +renderBool :: Bool -> String +renderBool True = "yes" +renderBool False = "no" + +commaSeparated :: [String] -> String +commaSeparated [] = "" +commaSeparated [singleValue] = singleValue +commaSeparated (firstValue : remainingValues) = firstValue ++ ", " ++ commaSeparated remainingValues diff --git a/34-haskell-dependency-order/test/Main.hs b/34-haskell-dependency-order/test/Main.hs new file mode 100644 index 0000000..60b2ccf --- /dev/null +++ b/34-haskell-dependency-order/test/Main.hs @@ -0,0 +1,49 @@ +module Main where + +import qualified Data.Map.Strict as Map +import MiniDependency.Order + ( Catalog + , DeploymentStep (DeploymentStep) + , ServiceProfile (ServiceProfile) + , catalog + , renderPlan + , resolveDeploymentOrder + ) +import System.Exit (die) + +cyclicCatalog :: Catalog +cyclicCatalog = + Map.fromList + [ ("a", ServiceProfile ["b"] False) + , ("b", ServiceProfile ["a"] False) + ] + +main :: IO () +main = + case + ( resolveDeploymentOrder catalog ["frontend", "billing"] + , resolveDeploymentOrder cyclicCatalog ["a"] + ) of + ( Right + [ DeploymentStep "postgres" [] False + , DeploymentStep "auth" ["postgres"] True + , DeploymentStep "redis" [] False + , DeploymentStep "api" ["auth", "redis"] True + , DeploymentStep "frontend" ["api"] False + , DeploymentStep "billing" ["api", "postgres"] True + ] + , Left _ + ) | "billing, deps api, postgres, migration yes" + `elem` + lines + ( renderPlan + [ DeploymentStep "postgres" [] False + , DeploymentStep "auth" ["postgres"] True + , DeploymentStep "redis" [] False + , DeploymentStep "api" ["auth", "redis"] True + , DeploymentStep "frontend" ["api"] False + , DeploymentStep "billing" ["api", "postgres"] True + ] + ) -> + putStrLn "test passed" + _ -> die "unexpected dependency-order result" diff --git a/notes/014-haskell-learning-path.md b/notes/014-haskell-learning-path.md index 8f7195b..50703f1 100644 --- a/notes/014-haskell-learning-path.md +++ b/notes/014-haskell-learning-path.md @@ -23,6 +23,9 @@ This note links the Haskell examples in a suggested order from first project str 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` +18. `32-haskell-nonempty-waves/`: rollout planning with `NonEmpty` +19. `33-haskell-optparse-cli/`: command-line parsing with `optparse-applicative` +20. `34-haskell-dependency-order/`: dependency-ordered planning with cycle checks --- @@ -45,6 +48,9 @@ This note links the Haskell examples in a suggested order from first project str - `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 +- `32-haskell-nonempty-waves/`: how to encode “at least one rollout step” in the type +- `33-haskell-optparse-cli/`: how to parse a real CLI into typed commands +- `34-haskell-dependency-order/`: how to derive a correct deployment order from dependencies --- @@ -67,3 +73,6 @@ This note links the Haskell examples in a suggested order from first project str - `notes/032-haskell-foldmap-summary.md` - `notes/033-haskell-traverse-resolution.md` - `notes/034-haskell-writer-audit.md` +- `notes/035-haskell-nonempty-waves.md` +- `notes/036-haskell-optparse-cli.md` +- `notes/037-haskell-dependency-order.md` diff --git a/notes/035-haskell-nonempty-waves.md b/notes/035-haskell-nonempty-waves.md new file mode 100644 index 0000000..d47fa0a --- /dev/null +++ b/notes/035-haskell-nonempty-waves.md @@ -0,0 +1,58 @@ +# Haskell NonEmpty Waves + +This note covers `32-haskell-nonempty-waves/`, which models rollout plans with `NonEmpty` so every plan is guaranteed to have at least one wave. + +--- + +## 1. Why `NonEmpty` Matters + +A rollout plan with zero waves is not meaningful. + +Using `[Wave]` would force every caller to handle an impossible-but-representable empty case. This example makes that impossible state unrepresentable +instead: + +```haskell +planWaves :: NonEmpty Wave +``` + +That means the rendering code can safely ask for the first and last wave without defensive checks. + +--- + +## 2. What the Example Builds + +The example turns a release job into: + +- one wave for a rolling rollout, or +- two waves for a canary rollout. + +Both cases still share the same output type. That is the real teaching point: `NonEmpty` lets you preserve list-like behavior while tightening the +domain guarantee. + +--- + +## 3. Why This Is Better Than a Runtime Check + +You could build a plain list and reject `[]` later. + +That would move the invariant into comments and runtime branches. `NonEmpty` pushes the guarantee into the type itself, which is more precise and +easier to trust. + +--- + +## 4. Commands to Try + +```bash +cd 32-haskell-nonempty-waves + +nix develop +cabal run +cabal run -- api:production:canary:20:6 +cabal test + +nix build +./result/bin/mini-waves api:production:canary:20:6 + +nix run . -- api:production:canary:20:6 +nix flake check +``` diff --git a/notes/036-haskell-optparse-cli.md b/notes/036-haskell-optparse-cli.md new file mode 100644 index 0000000..ae05812 --- /dev/null +++ b/notes/036-haskell-optparse-cli.md @@ -0,0 +1,63 @@ +# Haskell optparse-applicative + +This note covers `33-haskell-optparse-cli/`, which parses a small deployment CLI with `optparse-applicative`. + +--- + +## 1. Why This Is Different from the Parser-Combinator Example + +`12-haskell-parser-combinators/` builds a parser for a custom command language. + +This example solves a different problem: parsing a conventional CLI with: + +- subcommands, +- long options, +- repeated options, and +- typed option readers. + +That is a common real-world Haskell task, and `optparse-applicative` is the standard tool for it. + +--- + +## 2. What the Pure Parser Gives You + +The example exposes: + +```haskell +runCliParser :: [String] -> Either String Command +``` + +Internally it uses `execParserPure`, which keeps the parsing logic testable without invoking `IO` or shelling out. + +That is the main teaching point here: command-line parsing can still be structured as a pure transformation from argument vectors to typed commands. + +--- + +## 3. What Makes the Example Non-Trivial + +The parser handles two shapes of command: + +- `validate`, which parses typed environment, replica, and track options, and +- `promote`, which parses repeated `--owner` flags plus a `--dry-run` switch. + +That is enough surface area to show why a dedicated CLI parser library is useful. + +--- + +## 4. Commands to Try + +```bash +cd 33-haskell-optparse-cli + +nix develop +cabal run +cabal run -- validate --service api --env production --replicas 3 --track stable +cabal run -- promote --service api --from-tag blue --to-tag green --owner platform --owner security --dry-run +cabal test + +nix build +./result/bin/mini-cli validate --service api --env production --replicas 3 --track stable + +nix run . -- validate --service api --env production --replicas 3 --track stable +nix flake check +``` diff --git a/notes/037-haskell-dependency-order.md b/notes/037-haskell-dependency-order.md new file mode 100644 index 0000000..69949eb --- /dev/null +++ b/notes/037-haskell-dependency-order.md @@ -0,0 +1,56 @@ +# Haskell Dependency Order + +This note covers `34-haskell-dependency-order/`, which computes a deployment order from service dependencies and rejects cycles. + +--- + +## 1. What the Planner Has to Do + +For each requested service, the planner needs to: + +- find its dependencies, +- visit those dependencies first, +- avoid emitting the same service twice, and +- reject cycles and unknown names. + +That makes the example a good fit for a graph-style traversal, even though the code stays small and explicit. + +--- + +## 2. Why the Output Order Matters + +The planner emits `DeploymentStep` values in dependency order. + +That means infrastructure and foundational services appear before dependents such as `api`, `billing`, or `frontend`. + +This is the important behavior the example demonstrates: ordering is part of correctness, not just presentation. + +--- + +## 3. Why the Cycle Check Is Separate + +The example tracks both: + +- services currently being visited, and +- services already resolved. + +That distinction is what lets it detect `a -> b -> a` style cycles without falsely rejecting shared dependencies that are reached more than once. + +--- + +## 4. Commands to Try + +```bash +cd 34-haskell-dependency-order + +nix develop +cabal run +cabal run -- frontend billing +cabal test + +nix build +./result/bin/mini-dependency-order frontend billing + +nix run . -- frontend billing +nix flake check +```