Add two more Haskell examples (with their note files)
This commit is contained in:
parent
f7172b38b2
commit
ab32d287a9
25
35-haskell-monad-chaining/README.md
Normal file
25
35-haskell-monad-chaining/README.md
Normal file
@ -0,0 +1,25 @@
|
|||||||
|
# 35-haskell-monad-chaining
|
||||||
|
|
||||||
|
This example shows intermediate Haskell sequencing with monadic `Either` chains.
|
||||||
|
|
||||||
|
It includes:
|
||||||
|
|
||||||
|
- a rollout request parsed from compact CLI input,
|
||||||
|
- dependent resolution steps that each need earlier successful results,
|
||||||
|
- `do` notation over `Either String` for ticket, policy, tag, and approver checks, and
|
||||||
|
- a test suite run by `nix flake check`.
|
||||||
|
|
||||||
|
Useful commands:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
nix develop
|
||||||
|
cabal run
|
||||||
|
cabal run -- api:production:stable:CHG-2048
|
||||||
|
cabal test
|
||||||
|
|
||||||
|
nix build
|
||||||
|
./result/bin/mini-monad-chain api:production:stable:CHG-2048
|
||||||
|
|
||||||
|
nix run . -- api:production:stable:CHG-2048
|
||||||
|
nix flake check
|
||||||
|
```
|
||||||
25
35-haskell-monad-chaining/app/Main.hs
Normal file
25
35-haskell-monad-chaining/app/Main.hs
Normal file
@ -0,0 +1,25 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import MiniMonadChain.Rollout
|
||||||
|
( approveRollout
|
||||||
|
, catalog
|
||||||
|
, parseRequest
|
||||||
|
, renderRollout
|
||||||
|
)
|
||||||
|
import System.Environment (getArgs)
|
||||||
|
import System.Exit (die)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
args <- getArgs
|
||||||
|
let inputArg =
|
||||||
|
case args of
|
||||||
|
[] -> "api:production:stable:CHG-2048"
|
||||||
|
firstArg : _ -> firstArg
|
||||||
|
|
||||||
|
case parseRequest inputArg of
|
||||||
|
Left err -> die err
|
||||||
|
Right request ->
|
||||||
|
case approveRollout catalog request of
|
||||||
|
Left err -> die err
|
||||||
|
Right rollout -> putStrLn (renderRollout rollout)
|
||||||
27
35-haskell-monad-chaining/flake.lock
generated
Normal file
27
35-haskell-monad-chaining/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
35-haskell-monad-chaining/flake.nix
Normal file
38
35-haskell-monad-chaining/flake.nix
Normal file
@ -0,0 +1,38 @@
|
|||||||
|
{
|
||||||
|
# Builds a Haskell project that chains dependent rollout resolution steps
|
||||||
|
# with Either and do notation.
|
||||||
|
description = "A Haskell project for monad chaining with Either";
|
||||||
|
|
||||||
|
inputs = {
|
||||||
|
nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
|
||||||
|
};
|
||||||
|
|
||||||
|
outputs =
|
||||||
|
{ self, nixpkgs, ... }:
|
||||||
|
let
|
||||||
|
system = "x86_64-linux";
|
||||||
|
pkgs = import nixpkgs { inherit system; };
|
||||||
|
inherit (pkgs) haskellPackages;
|
||||||
|
project = haskellPackages.callCabal2nix "mini-monad-chain" ./. { };
|
||||||
|
checkedProject = pkgs.haskell.lib.doCheck project;
|
||||||
|
in
|
||||||
|
{
|
||||||
|
packages.${system}.default = project;
|
||||||
|
|
||||||
|
apps.${system}.default = {
|
||||||
|
type = "app";
|
||||||
|
program = "${self.packages.${system}.default}/bin/mini-monad-chain";
|
||||||
|
meta.description = "Run the monad chaining rollout example.";
|
||||||
|
};
|
||||||
|
|
||||||
|
devShells.${system}.default = pkgs.mkShell {
|
||||||
|
packages = [
|
||||||
|
haskellPackages.ghc
|
||||||
|
pkgs.cabal-install
|
||||||
|
pkgs.haskell-language-server
|
||||||
|
];
|
||||||
|
};
|
||||||
|
|
||||||
|
checks.${system}.test-suite = checkedProject;
|
||||||
|
};
|
||||||
|
}
|
||||||
29
35-haskell-monad-chaining/mini-monad-chain.cabal
Normal file
29
35-haskell-monad-chaining/mini-monad-chain.cabal
Normal file
@ -0,0 +1,29 @@
|
|||||||
|
cabal-version: 2.4
|
||||||
|
name: mini-monad-chain
|
||||||
|
version: 0.1.0.0
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules: MiniMonadChain.Rollout
|
||||||
|
hs-source-dirs: src
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
containers
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
executable mini-monad-chain
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: app
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
mini-monad-chain
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite mini-monad-chain-test
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: test
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
mini-monad-chain
|
||||||
|
default-language: Haskell2010
|
||||||
146
35-haskell-monad-chaining/src/MiniMonadChain/Rollout.hs
Normal file
146
35-haskell-monad-chaining/src/MiniMonadChain/Rollout.hs
Normal file
@ -0,0 +1,146 @@
|
|||||||
|
module MiniMonadChain.Rollout where
|
||||||
|
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import Data.Map.Strict (Map)
|
||||||
|
import Data.List (intercalate)
|
||||||
|
|
||||||
|
data Environment
|
||||||
|
= Staging
|
||||||
|
| Production
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data ReleaseTrack
|
||||||
|
= Stable
|
||||||
|
| Candidate
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data RolloutRequest = RolloutRequest
|
||||||
|
{ requestService :: String
|
||||||
|
, requestEnvironment :: Environment
|
||||||
|
, requestTrack :: ReleaseTrack
|
||||||
|
, requestTicket :: String
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data ServiceProfile = ServiceProfile
|
||||||
|
{ stableTag :: String
|
||||||
|
, candidateTag :: Maybe String
|
||||||
|
, changeApprover :: String
|
||||||
|
, productionAllowed :: Bool
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data ApprovedRollout = ApprovedRollout
|
||||||
|
{ rolloutService :: String
|
||||||
|
, rolloutEnvironment :: Environment
|
||||||
|
, rolloutImageTag :: String
|
||||||
|
, rolloutTicket :: String
|
||||||
|
, rolloutApprover :: String
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
type Catalog = Map String ServiceProfile
|
||||||
|
|
||||||
|
catalog :: Catalog
|
||||||
|
catalog =
|
||||||
|
Map.fromList
|
||||||
|
[ ("api", ServiceProfile "2026.05.1" (Just "2026.06-rc1") "platform" True)
|
||||||
|
, ("worker", ServiceProfile "2026.05.0" (Just "2026.06-beta2") "ops" False)
|
||||||
|
, ("auth", ServiceProfile "2026.05.3" Nothing "security" True)
|
||||||
|
]
|
||||||
|
|
||||||
|
parseRequest :: String -> Either String RolloutRequest
|
||||||
|
parseRequest rawRequest =
|
||||||
|
case splitOn ':' rawRequest of
|
||||||
|
[serviceName, environmentName, trackName, ticketValue] ->
|
||||||
|
RolloutRequest
|
||||||
|
<$> pure serviceName
|
||||||
|
<*> parseEnvironment environmentName
|
||||||
|
<*> parseTrack trackName
|
||||||
|
<*> pure ticketValue
|
||||||
|
_ -> Left ("expected <service>:<environment>:<stable|candidate>:<ticket>, got: " ++ rawRequest)
|
||||||
|
|
||||||
|
approveRollout :: Catalog -> RolloutRequest -> Either String ApprovedRollout
|
||||||
|
approveRollout serviceCatalog request = do
|
||||||
|
serviceProfile <- lookupService serviceCatalog (requestService request)
|
||||||
|
ensureEnvironmentAllowed serviceProfile (requestEnvironment request)
|
||||||
|
ensureTicketMatches request
|
||||||
|
imageTag <- resolveTag serviceProfile (requestTrack request)
|
||||||
|
approver <- resolveApprover serviceProfile (requestEnvironment request)
|
||||||
|
pure
|
||||||
|
ApprovedRollout
|
||||||
|
{ rolloutService = requestService request
|
||||||
|
, rolloutEnvironment = requestEnvironment request
|
||||||
|
, rolloutImageTag = imageTag
|
||||||
|
, rolloutTicket = requestTicket request
|
||||||
|
, rolloutApprover = approver
|
||||||
|
}
|
||||||
|
|
||||||
|
lookupService :: Catalog -> String -> Either String ServiceProfile
|
||||||
|
lookupService serviceCatalog serviceName =
|
||||||
|
case Map.lookup serviceName serviceCatalog of
|
||||||
|
Just serviceProfile -> Right serviceProfile
|
||||||
|
Nothing -> Left ("unknown service: " ++ serviceName)
|
||||||
|
|
||||||
|
ensureEnvironmentAllowed :: ServiceProfile -> Environment -> Either String ()
|
||||||
|
ensureEnvironmentAllowed _ Staging = Right ()
|
||||||
|
ensureEnvironmentAllowed serviceProfile Production
|
||||||
|
| productionAllowed serviceProfile = Right ()
|
||||||
|
| otherwise = Left "service is staging-only"
|
||||||
|
|
||||||
|
ensureTicketMatches :: RolloutRequest -> Either String ()
|
||||||
|
ensureTicketMatches request =
|
||||||
|
case requestEnvironment request of
|
||||||
|
Staging -> Right ()
|
||||||
|
Production
|
||||||
|
| "CHG-" `prefixOf` requestTicket request -> Right ()
|
||||||
|
| otherwise -> Left "production rollouts require a CHG- ticket"
|
||||||
|
|
||||||
|
resolveTag :: ServiceProfile -> ReleaseTrack -> Either String String
|
||||||
|
resolveTag serviceProfile Stable = Right (stableTag serviceProfile)
|
||||||
|
resolveTag serviceProfile Candidate =
|
||||||
|
case candidateTag serviceProfile of
|
||||||
|
Just tagValue -> Right tagValue
|
||||||
|
Nothing -> Left "service does not publish a candidate tag"
|
||||||
|
|
||||||
|
resolveApprover :: ServiceProfile -> Environment -> Either String String
|
||||||
|
resolveApprover serviceProfile Staging = Right ("staging-" ++ changeApprover serviceProfile)
|
||||||
|
resolveApprover serviceProfile Production = Right (changeApprover serviceProfile)
|
||||||
|
|
||||||
|
renderRollout :: ApprovedRollout -> String
|
||||||
|
renderRollout rollout =
|
||||||
|
intercalate
|
||||||
|
", "
|
||||||
|
[ rolloutService rollout ++ " -> " ++ renderEnvironment (rolloutEnvironment rollout)
|
||||||
|
, "tag " ++ rolloutImageTag rollout
|
||||||
|
, "ticket " ++ rolloutTicket rollout
|
||||||
|
, "approver " ++ rolloutApprover rollout
|
||||||
|
]
|
||||||
|
|
||||||
|
parseEnvironment :: String -> Either String Environment
|
||||||
|
parseEnvironment "staging" = Right Staging
|
||||||
|
parseEnvironment "production" = Right Production
|
||||||
|
parseEnvironment otherValue = Left ("unknown environment: " ++ otherValue)
|
||||||
|
|
||||||
|
parseTrack :: String -> Either String ReleaseTrack
|
||||||
|
parseTrack "stable" = Right Stable
|
||||||
|
parseTrack "candidate" = Right Candidate
|
||||||
|
parseTrack otherValue = Left ("unknown track: " ++ otherValue)
|
||||||
|
|
||||||
|
renderEnvironment :: Environment -> String
|
||||||
|
renderEnvironment Staging = "staging"
|
||||||
|
renderEnvironment Production = "production"
|
||||||
|
|
||||||
|
prefixOf :: String -> String -> Bool
|
||||||
|
prefixOf [] _ = True
|
||||||
|
prefixOf _ [] = False
|
||||||
|
prefixOf (leftChar : leftRest) (rightChar : rightRest) =
|
||||||
|
leftChar == rightChar && prefixOf leftRest rightRest
|
||||||
|
|
||||||
|
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
|
||||||
37
35-haskell-monad-chaining/test/Main.hs
Normal file
37
35-haskell-monad-chaining/test/Main.hs
Normal file
@ -0,0 +1,37 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import MiniMonadChain.Rollout
|
||||||
|
( ApprovedRollout (ApprovedRollout)
|
||||||
|
, Environment (Production, Staging)
|
||||||
|
, ReleaseTrack (Candidate, Stable)
|
||||||
|
, RolloutRequest (RolloutRequest)
|
||||||
|
, approveRollout
|
||||||
|
, catalog
|
||||||
|
, parseRequest
|
||||||
|
, renderRollout
|
||||||
|
)
|
||||||
|
import System.Exit (die)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main =
|
||||||
|
case
|
||||||
|
( parseRequest "api:production:stable:CHG-2048"
|
||||||
|
, parseRequest "worker:production:candidate:CHG-3000"
|
||||||
|
, parseRequest "auth:production:candidate:CHG-4000"
|
||||||
|
) of
|
||||||
|
( Right apiRequest
|
||||||
|
, Right workerRequest
|
||||||
|
, Right authRequest
|
||||||
|
) ->
|
||||||
|
case
|
||||||
|
( approveRollout catalog apiRequest
|
||||||
|
, approveRollout catalog workerRequest
|
||||||
|
, approveRollout catalog authRequest
|
||||||
|
) of
|
||||||
|
( Right rollout@(ApprovedRollout "api" Production "2026.05.1" "CHG-2048" "platform")
|
||||||
|
, Left _
|
||||||
|
, Left _
|
||||||
|
) | renderRollout rollout == "api -> production, tag 2026.05.1, ticket CHG-2048, approver platform" ->
|
||||||
|
putStrLn "test passed"
|
||||||
|
_ -> die "unexpected monad chain result"
|
||||||
|
_ -> die "unexpected request parse result"
|
||||||
25
36-haskell-map-set-modeling/README.md
Normal file
25
36-haskell-map-set-modeling/README.md
Normal file
@ -0,0 +1,25 @@
|
|||||||
|
# 36-haskell-map-set-modeling
|
||||||
|
|
||||||
|
This example shows intermediate Haskell domain modeling with `Map` and `Set`.
|
||||||
|
|
||||||
|
It includes:
|
||||||
|
|
||||||
|
- a release-access policy stored in maps and sets,
|
||||||
|
- team membership, service ownership, and environment grants,
|
||||||
|
- a CLI that reports required owners and unexpected approvers, and
|
||||||
|
- a test suite run by `nix flake check`.
|
||||||
|
|
||||||
|
Useful commands:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
nix develop
|
||||||
|
cabal run
|
||||||
|
cabal run -- api:production:platform,security
|
||||||
|
cabal test
|
||||||
|
|
||||||
|
nix build
|
||||||
|
./result/bin/mini-access-policy api:production:platform,security
|
||||||
|
|
||||||
|
nix run . -- api:production:platform,security
|
||||||
|
nix flake check
|
||||||
|
```
|
||||||
26
36-haskell-map-set-modeling/app/Main.hs
Normal file
26
36-haskell-map-set-modeling/app/Main.hs
Normal file
@ -0,0 +1,26 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import MiniAccessPolicy.Policy
|
||||||
|
( accessMatrix
|
||||||
|
, buildApprovalReport
|
||||||
|
, ownershipIndex
|
||||||
|
, parseRequest
|
||||||
|
, renderReport
|
||||||
|
)
|
||||||
|
import System.Environment (getArgs)
|
||||||
|
import System.Exit (die)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
args <- getArgs
|
||||||
|
let inputArg =
|
||||||
|
case args of
|
||||||
|
[] -> "api:production:platform,security"
|
||||||
|
firstArg : _ -> firstArg
|
||||||
|
|
||||||
|
case parseRequest inputArg of
|
||||||
|
Left err -> die err
|
||||||
|
Right request ->
|
||||||
|
case buildApprovalReport ownershipIndex accessMatrix request of
|
||||||
|
Left err -> die err
|
||||||
|
Right report -> putStrLn (renderReport report)
|
||||||
27
36-haskell-map-set-modeling/flake.lock
generated
Normal file
27
36-haskell-map-set-modeling/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
36-haskell-map-set-modeling/flake.nix
Normal file
38
36-haskell-map-set-modeling/flake.nix
Normal file
@ -0,0 +1,38 @@
|
|||||||
|
{
|
||||||
|
# Builds a Haskell project that models release access policy directly with
|
||||||
|
# Map and Set.
|
||||||
|
description = "A Haskell project for Map and Set domain modeling";
|
||||||
|
|
||||||
|
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-access-policy" ./. { };
|
||||||
|
checkedProject = pkgs.haskell.lib.doCheck project;
|
||||||
|
in
|
||||||
|
{
|
||||||
|
packages.${system}.default = project;
|
||||||
|
|
||||||
|
apps.${system}.default = {
|
||||||
|
type = "app";
|
||||||
|
program = "${self.packages.${system}.default}/bin/mini-access-policy";
|
||||||
|
meta.description = "Run the Map and Set access policy example.";
|
||||||
|
};
|
||||||
|
|
||||||
|
devShells.${system}.default = pkgs.mkShell {
|
||||||
|
packages = [
|
||||||
|
haskellPackages.ghc
|
||||||
|
pkgs.cabal-install
|
||||||
|
pkgs.haskell-language-server
|
||||||
|
];
|
||||||
|
};
|
||||||
|
|
||||||
|
checks.${system}.test-suite = checkedProject;
|
||||||
|
};
|
||||||
|
}
|
||||||
30
36-haskell-map-set-modeling/mini-access-policy.cabal
Normal file
30
36-haskell-map-set-modeling/mini-access-policy.cabal
Normal file
@ -0,0 +1,30 @@
|
|||||||
|
cabal-version: 2.4
|
||||||
|
name: mini-access-policy
|
||||||
|
version: 0.1.0.0
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules: MiniAccessPolicy.Policy
|
||||||
|
hs-source-dirs: src
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
containers
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
executable mini-access-policy
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: app
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
mini-access-policy
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite mini-access-policy-test
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: test
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
containers,
|
||||||
|
mini-access-policy
|
||||||
|
default-language: Haskell2010
|
||||||
121
36-haskell-map-set-modeling/src/MiniAccessPolicy/Policy.hs
Normal file
121
36-haskell-map-set-modeling/src/MiniAccessPolicy/Policy.hs
Normal file
@ -0,0 +1,121 @@
|
|||||||
|
module MiniAccessPolicy.Policy where
|
||||||
|
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import Data.Map.Strict (Map)
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import Data.Set (Set)
|
||||||
|
import Data.List (intercalate)
|
||||||
|
|
||||||
|
data Environment
|
||||||
|
= Staging
|
||||||
|
| Production
|
||||||
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
data ApprovalRequest = ApprovalRequest
|
||||||
|
{ requestService :: String
|
||||||
|
, requestEnvironment :: Environment
|
||||||
|
, providedTeams :: Set String
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data ApprovalReport = ApprovalReport
|
||||||
|
{ reportService :: String
|
||||||
|
, reportEnvironment :: Environment
|
||||||
|
, requiredTeams :: Set String
|
||||||
|
, suppliedTeams :: Set String
|
||||||
|
, missingTeams :: Set String
|
||||||
|
, unexpectedTeams :: Set String
|
||||||
|
, allowed :: Bool
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
type OwnershipIndex = Map String (Set String)
|
||||||
|
type AccessMatrix = Map Environment (Set String)
|
||||||
|
|
||||||
|
ownershipIndex :: OwnershipIndex
|
||||||
|
ownershipIndex =
|
||||||
|
Map.fromList
|
||||||
|
[ ("api", Set.fromList ["platform", "security"])
|
||||||
|
, ("worker", Set.fromList ["ops"])
|
||||||
|
, ("auth", Set.fromList ["security", "platform"])
|
||||||
|
, ("frontend", Set.fromList ["frontend", "platform"])
|
||||||
|
]
|
||||||
|
|
||||||
|
accessMatrix :: AccessMatrix
|
||||||
|
accessMatrix =
|
||||||
|
Map.fromList
|
||||||
|
[ (Staging, Set.fromList ["platform", "ops", "security", "frontend"])
|
||||||
|
, (Production, Set.fromList ["platform", "security"])
|
||||||
|
]
|
||||||
|
|
||||||
|
parseRequest :: String -> Either String ApprovalRequest
|
||||||
|
parseRequest rawRequest =
|
||||||
|
case splitOn ':' rawRequest of
|
||||||
|
[serviceName, environmentName, rawTeams] ->
|
||||||
|
ApprovalRequest
|
||||||
|
<$> pure serviceName
|
||||||
|
<*> parseEnvironment environmentName
|
||||||
|
<*> pure (Set.fromList (splitOn ',' rawTeams))
|
||||||
|
_ -> Left ("expected <service>:<environment>:<team,team,...>, got: " ++ rawRequest)
|
||||||
|
|
||||||
|
buildApprovalReport :: OwnershipIndex -> AccessMatrix -> ApprovalRequest -> Either String ApprovalReport
|
||||||
|
buildApprovalReport serviceOwners environmentAccess approvalRequest = do
|
||||||
|
owners <-
|
||||||
|
case Map.lookup (requestService approvalRequest) serviceOwners of
|
||||||
|
Just serviceTeams -> Right serviceTeams
|
||||||
|
Nothing -> Left ("unknown service: " ++ requestService approvalRequest)
|
||||||
|
allowedTeamsForEnvironment <-
|
||||||
|
case Map.lookup (requestEnvironment approvalRequest) environmentAccess of
|
||||||
|
Just allowedTeams -> Right allowedTeams
|
||||||
|
Nothing -> Left "missing environment access configuration"
|
||||||
|
let requiredApprovers = Set.intersection owners allowedTeamsForEnvironment
|
||||||
|
missingApprovers = Set.difference requiredApprovers (providedTeams approvalRequest)
|
||||||
|
unexpectedApprovers = Set.difference (providedTeams approvalRequest) allowedTeamsForEnvironment
|
||||||
|
pure
|
||||||
|
ApprovalReport
|
||||||
|
{ reportService = requestService approvalRequest
|
||||||
|
, reportEnvironment = requestEnvironment approvalRequest
|
||||||
|
, requiredTeams = requiredApprovers
|
||||||
|
, suppliedTeams = providedTeams approvalRequest
|
||||||
|
, missingTeams = missingApprovers
|
||||||
|
, unexpectedTeams = unexpectedApprovers
|
||||||
|
, allowed = Set.null missingApprovers && Set.null unexpectedApprovers
|
||||||
|
}
|
||||||
|
|
||||||
|
renderReport :: ApprovalReport -> String
|
||||||
|
renderReport report =
|
||||||
|
intercalate
|
||||||
|
", "
|
||||||
|
[ reportService report ++ " -> " ++ renderEnvironment (reportEnvironment report)
|
||||||
|
, "required " ++ renderSet (requiredTeams report)
|
||||||
|
, "supplied " ++ renderSet (suppliedTeams report)
|
||||||
|
, "missing " ++ renderSet (missingTeams report)
|
||||||
|
, "unexpected " ++ renderSet (unexpectedTeams report)
|
||||||
|
, "allowed " ++ renderBool (allowed report)
|
||||||
|
]
|
||||||
|
|
||||||
|
parseEnvironment :: String -> Either String Environment
|
||||||
|
parseEnvironment "staging" = Right Staging
|
||||||
|
parseEnvironment "production" = Right Production
|
||||||
|
parseEnvironment otherValue = Left ("unknown environment: " ++ otherValue)
|
||||||
|
|
||||||
|
renderEnvironment :: Environment -> String
|
||||||
|
renderEnvironment Staging = "staging"
|
||||||
|
renderEnvironment Production = "production"
|
||||||
|
|
||||||
|
renderSet :: Set String -> String
|
||||||
|
renderSet values
|
||||||
|
| Set.null values = "none"
|
||||||
|
| otherwise = intercalate "/" (Set.toAscList values)
|
||||||
|
|
||||||
|
renderBool :: Bool -> String
|
||||||
|
renderBool True = "yes"
|
||||||
|
renderBool False = "no"
|
||||||
|
|
||||||
|
splitOn :: Char -> String -> [String]
|
||||||
|
splitOn separator = go []
|
||||||
|
where
|
||||||
|
go current [] = [reverse current]
|
||||||
|
go current (nextChar : remainingChars)
|
||||||
|
| nextChar == separator = reverse current : go [] remainingChars
|
||||||
|
| otherwise = go (nextChar : current) remainingChars
|
||||||
38
36-haskell-map-set-modeling/test/Main.hs
Normal file
38
36-haskell-map-set-modeling/test/Main.hs
Normal file
@ -0,0 +1,38 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import MiniAccessPolicy.Policy
|
||||||
|
( ApprovalReport (ApprovalReport)
|
||||||
|
, Environment (Production, Staging)
|
||||||
|
, accessMatrix
|
||||||
|
, buildApprovalReport
|
||||||
|
, ownershipIndex
|
||||||
|
, parseRequest
|
||||||
|
, renderReport
|
||||||
|
)
|
||||||
|
import System.Exit (die)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main =
|
||||||
|
case
|
||||||
|
( parseRequest "api:production:platform,security"
|
||||||
|
, parseRequest "frontend:production:frontend,platform"
|
||||||
|
) of
|
||||||
|
( Right allowedRequest
|
||||||
|
, Right deniedRequest
|
||||||
|
) ->
|
||||||
|
case
|
||||||
|
( buildApprovalReport ownershipIndex accessMatrix allowedRequest
|
||||||
|
, buildApprovalReport ownershipIndex accessMatrix deniedRequest
|
||||||
|
) of
|
||||||
|
( Right allowedReport@(ApprovalReport "api" Production required supplied missing unexpected True)
|
||||||
|
, Right deniedReport@(ApprovalReport "frontend" Production _ _ _ deniedUnexpected False)
|
||||||
|
) | required == Set.fromList ["platform", "security"]
|
||||||
|
&& missing == Set.empty
|
||||||
|
&& unexpected == Set.empty
|
||||||
|
&& deniedUnexpected == Set.fromList ["frontend"]
|
||||||
|
&& renderReport deniedReport
|
||||||
|
== "frontend -> production, required platform, supplied frontend/platform, missing none, unexpected frontend, allowed no" ->
|
||||||
|
putStrLn "test passed"
|
||||||
|
_ -> die "unexpected Map/Set modeling result"
|
||||||
|
_ -> die "unexpected access policy parse result"
|
||||||
@ -26,6 +26,8 @@ This note links the Haskell examples in a suggested order from first project str
|
|||||||
18. `32-haskell-nonempty-waves/`: rollout planning with `NonEmpty`
|
18. `32-haskell-nonempty-waves/`: rollout planning with `NonEmpty`
|
||||||
19. `33-haskell-optparse-cli/`: command-line parsing with `optparse-applicative`
|
19. `33-haskell-optparse-cli/`: command-line parsing with `optparse-applicative`
|
||||||
20. `34-haskell-dependency-order/`: dependency-ordered planning with cycle checks
|
20. `34-haskell-dependency-order/`: dependency-ordered planning with cycle checks
|
||||||
|
21. `35-haskell-monad-chaining/`: dependent rollout approval with monadic `Either`
|
||||||
|
22. `36-haskell-map-set-modeling/`: access-policy modeling with `Map` and `Set`
|
||||||
|
|
||||||
---
|
---
|
||||||
|
|
||||||
@ -51,6 +53,8 @@ This note links the Haskell examples in a suggested order from first project str
|
|||||||
- `32-haskell-nonempty-waves/`: how to encode “at least one rollout step” in the type
|
- `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
|
- `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
|
- `34-haskell-dependency-order/`: how to derive a correct deployment order from dependencies
|
||||||
|
- `35-haskell-monad-chaining/`: how to express fail-fast workflows where each step depends on earlier results
|
||||||
|
- `36-haskell-map-set-modeling/`: how to use `Map` and `Set` as primary domain structures, not just helpers
|
||||||
|
|
||||||
---
|
---
|
||||||
|
|
||||||
@ -76,3 +80,5 @@ This note links the Haskell examples in a suggested order from first project str
|
|||||||
- `notes/035-haskell-nonempty-waves.md`
|
- `notes/035-haskell-nonempty-waves.md`
|
||||||
- `notes/036-haskell-optparse-cli.md`
|
- `notes/036-haskell-optparse-cli.md`
|
||||||
- `notes/037-haskell-dependency-order.md`
|
- `notes/037-haskell-dependency-order.md`
|
||||||
|
- `notes/038-haskell-monad-chaining.md`
|
||||||
|
- `notes/039-haskell-map-set-modeling.md`
|
||||||
|
|||||||
65
notes/038-haskell-monad-chaining.md
Normal file
65
notes/038-haskell-monad-chaining.md
Normal file
@ -0,0 +1,65 @@
|
|||||||
|
# Haskell Monad Chaining
|
||||||
|
|
||||||
|
This note covers `35-haskell-monad-chaining/`, which sequences several dependent rollout checks with `Either` and `do` notation.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 1. Why Monad Chaining Matters
|
||||||
|
|
||||||
|
Some workflows cannot be expressed as independent field checks.
|
||||||
|
|
||||||
|
In this example, later steps depend on earlier successful results:
|
||||||
|
|
||||||
|
- find the service profile first,
|
||||||
|
- then check whether the environment is allowed,
|
||||||
|
- then validate the production change ticket,
|
||||||
|
- then choose the image tag for the requested track, and
|
||||||
|
- finally choose the approver.
|
||||||
|
|
||||||
|
That dependency chain is the point. Each step needs the result of the previous one.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 2. Why `Either` Still Fits
|
||||||
|
|
||||||
|
This example does not need accumulated errors. It needs short-circuiting business logic.
|
||||||
|
|
||||||
|
That makes `Either String` a good fit:
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
approveRollout :: Catalog -> RolloutRequest -> Either String ApprovedRollout
|
||||||
|
```
|
||||||
|
|
||||||
|
`do` notation keeps the happy path readable while preserving the fail-fast semantics.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 3. How This Complements the Validation Example
|
||||||
|
|
||||||
|
`28-haskell-applicative-validation/` teaches independent checks that all run so several errors can be reported together.
|
||||||
|
|
||||||
|
This example teaches the opposite shape:
|
||||||
|
|
||||||
|
- one decision unlocks the next, and
|
||||||
|
- the workflow stops once a prerequisite fails.
|
||||||
|
|
||||||
|
That contrast is useful. It shows why “Applicative versus Monad” is not just theory. The control flow shape changes the design.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 4. Commands to Try
|
||||||
|
|
||||||
|
```bash
|
||||||
|
cd 35-haskell-monad-chaining
|
||||||
|
|
||||||
|
nix develop
|
||||||
|
cabal run
|
||||||
|
cabal run -- api:production:stable:CHG-2048
|
||||||
|
cabal test
|
||||||
|
|
||||||
|
nix build
|
||||||
|
./result/bin/mini-monad-chain api:production:stable:CHG-2048
|
||||||
|
|
||||||
|
nix run . -- api:production:stable:CHG-2048
|
||||||
|
nix flake check
|
||||||
|
```
|
||||||
61
notes/039-haskell-map-set-modeling.md
Normal file
61
notes/039-haskell-map-set-modeling.md
Normal file
@ -0,0 +1,61 @@
|
|||||||
|
# Haskell Map and Set Modeling
|
||||||
|
|
||||||
|
This note covers `36-haskell-map-set-modeling/`, which models release approval policy directly with `Map` and `Set`.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 1. Why These Structures Deserve Their Own Example
|
||||||
|
|
||||||
|
Several earlier examples already use `containers`, but only as support code.
|
||||||
|
|
||||||
|
This example makes the data structures themselves the teaching point:
|
||||||
|
|
||||||
|
- `Map` for service ownership and environment access rules, and
|
||||||
|
- `Set` for required, supplied, missing, and unexpected approver groups.
|
||||||
|
|
||||||
|
That is a practical step up from list-based toy models.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 2. What the Policy Computation Shows
|
||||||
|
|
||||||
|
The report logic uses set operations directly:
|
||||||
|
|
||||||
|
- intersection for required approvers that are valid in the environment,
|
||||||
|
- difference for missing approvers, and
|
||||||
|
- difference again for unexpected approvers.
|
||||||
|
|
||||||
|
That makes the policy behavior compact and declarative. The code describes the relationships instead of manually looping over lists.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 3. Why This Is Good Domain Modeling
|
||||||
|
|
||||||
|
Ownership, access grants, and approval groups are not “just lists”.
|
||||||
|
|
||||||
|
They have semantics:
|
||||||
|
|
||||||
|
- service names map to owner teams,
|
||||||
|
- environments map to allowed teams, and
|
||||||
|
- approver groups should not contain duplicates.
|
||||||
|
|
||||||
|
Using `Map` and `Set` makes those semantics explicit in the type choices.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 4. Commands to Try
|
||||||
|
|
||||||
|
```bash
|
||||||
|
cd 36-haskell-map-set-modeling
|
||||||
|
|
||||||
|
nix develop
|
||||||
|
cabal run
|
||||||
|
cabal run -- api:production:platform,security
|
||||||
|
cabal test
|
||||||
|
|
||||||
|
nix build
|
||||||
|
./result/bin/mini-access-policy api:production:platform,security
|
||||||
|
|
||||||
|
nix run . -- api:production:platform,security
|
||||||
|
nix flake check
|
||||||
|
```
|
||||||
Loading…
x
Reference in New Issue
Block a user