Add three new Haskell examples (with their note files)
This commit is contained in:
parent
87d02e8bc2
commit
f7172b38b2
25
32-haskell-nonempty-waves/README.md
Normal file
25
32-haskell-nonempty-waves/README.md
Normal file
@ -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
|
||||
```
|
||||
21
32-haskell-nonempty-waves/app/Main.hs
Normal file
21
32-haskell-nonempty-waves/app/Main.hs
Normal file
@ -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))
|
||||
27
32-haskell-nonempty-waves/flake.lock
generated
Normal file
27
32-haskell-nonempty-waves/flake.lock
generated
Normal file
@ -0,0 +1,27 @@
|
||||
{
|
||||
"nodes": {
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1776548001,
|
||||
"narHash": "sha256-ZSK0NL4a1BwVbbTBoSnWgbJy9HeZFXLYQizjb2DPF24=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "b12141ef619e0a9c1c84dc8c684040326f27cdcc",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixos-unstable",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"root": {
|
||||
"inputs": {
|
||||
"nixpkgs": "nixpkgs"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
"version": 7
|
||||
}
|
||||
38
32-haskell-nonempty-waves/flake.nix
Normal file
38
32-haskell-nonempty-waves/flake.nix
Normal file
@ -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;
|
||||
};
|
||||
}
|
||||
28
32-haskell-nonempty-waves/mini-waves.cabal
Normal file
28
32-haskell-nonempty-waves/mini-waves.cabal
Normal file
@ -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
|
||||
132
32-haskell-nonempty-waves/src/MiniWaves/Plan.hs
Normal file
132
32-haskell-nonempty-waves/src/MiniWaves/Plan.hs
Normal file
@ -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 <service>:<environment>:<rolling|canary>:<percent>:<replicas>, 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
|
||||
29
32-haskell-nonempty-waves/test/Main.hs
Normal file
29
32-haskell-nonempty-waves/test/Main.hs
Normal file
@ -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"
|
||||
26
33-haskell-optparse-cli/README.md
Normal file
26
33-haskell-optparse-cli/README.md
Normal file
@ -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
|
||||
```
|
||||
30
33-haskell-optparse-cli/app/Main.hs
Normal file
30
33-haskell-optparse-cli/app/Main.hs
Normal file
@ -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)
|
||||
27
33-haskell-optparse-cli/flake.lock
generated
Normal file
27
33-haskell-optparse-cli/flake.lock
generated
Normal file
@ -0,0 +1,27 @@
|
||||
{
|
||||
"nodes": {
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1776548001,
|
||||
"narHash": "sha256-ZSK0NL4a1BwVbbTBoSnWgbJy9HeZFXLYQizjb2DPF24=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "b12141ef619e0a9c1c84dc8c684040326f27cdcc",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixos-unstable",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"root": {
|
||||
"inputs": {
|
||||
"nixpkgs": "nixpkgs"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
"version": 7
|
||||
}
|
||||
38
33-haskell-optparse-cli/flake.nix
Normal file
38
33-haskell-optparse-cli/flake.nix
Normal file
@ -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;
|
||||
};
|
||||
}
|
||||
29
33-haskell-optparse-cli/mini-cli.cabal
Normal file
29
33-haskell-optparse-cli/mini-cli.cabal
Normal file
@ -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
|
||||
154
33-haskell-optparse-cli/src/MiniCli/Command.hs
Normal file
154
33-haskell-optparse-cli/src/MiniCli/Command.hs
Normal file
@ -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
|
||||
26
33-haskell-optparse-cli/test/Main.hs
Normal file
26
33-haskell-optparse-cli/test/Main.hs
Normal file
@ -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"
|
||||
25
34-haskell-dependency-order/README.md
Normal file
25
34-haskell-dependency-order/README.md
Normal file
@ -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
|
||||
```
|
||||
21
34-haskell-dependency-order/app/Main.hs
Normal file
21
34-haskell-dependency-order/app/Main.hs
Normal file
@ -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)
|
||||
27
34-haskell-dependency-order/flake.lock
generated
Normal file
27
34-haskell-dependency-order/flake.lock
generated
Normal file
@ -0,0 +1,27 @@
|
||||
{
|
||||
"nodes": {
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1776548001,
|
||||
"narHash": "sha256-ZSK0NL4a1BwVbbTBoSnWgbJy9HeZFXLYQizjb2DPF24=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "b12141ef619e0a9c1c84dc8c684040326f27cdcc",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixos-unstable",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"root": {
|
||||
"inputs": {
|
||||
"nixpkgs": "nixpkgs"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
"version": 7
|
||||
}
|
||||
38
34-haskell-dependency-order/flake.nix
Normal file
38
34-haskell-dependency-order/flake.nix
Normal file
@ -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;
|
||||
};
|
||||
}
|
||||
30
34-haskell-dependency-order/mini-dependency-order.cabal
Normal file
30
34-haskell-dependency-order/mini-dependency-order.cabal
Normal file
@ -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
|
||||
100
34-haskell-dependency-order/src/MiniDependency/Order.hs
Normal file
100
34-haskell-dependency-order/src/MiniDependency/Order.hs
Normal file
@ -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
|
||||
49
34-haskell-dependency-order/test/Main.hs
Normal file
49
34-haskell-dependency-order/test/Main.hs
Normal file
@ -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"
|
||||
@ -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`
|
||||
|
||||
58
notes/035-haskell-nonempty-waves.md
Normal file
58
notes/035-haskell-nonempty-waves.md
Normal file
@ -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
|
||||
```
|
||||
63
notes/036-haskell-optparse-cli.md
Normal file
63
notes/036-haskell-optparse-cli.md
Normal file
@ -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
|
||||
```
|
||||
56
notes/037-haskell-dependency-order.md
Normal file
56
notes/037-haskell-dependency-order.md
Normal file
@ -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
|
||||
```
|
||||
Loading…
x
Reference in New Issue
Block a user