From e5906d9163179b7bc6e31b444434c8e50ba94e2e Mon Sep 17 00:00:00 2001 From: Hassan Abedi Date: Thu, 30 Apr 2026 10:57:05 +0200 Subject: [PATCH] Add two more Haskell examples (with their note files) --- 37-haskell-transformer-stack/README.md | 26 +++ 37-haskell-transformer-stack/app/Main.hs | 29 +++ 37-haskell-transformer-stack/flake.lock | 27 +++ 37-haskell-transformer-stack/flake.nix | 38 ++++ 37-haskell-transformer-stack/mini-stack.cabal | 29 +++ .../src/MiniStack/Rollout.hs | 170 ++++++++++++++++++ 37-haskell-transformer-stack/test/Main.hs | 35 ++++ 38-haskell-generic-json/README.md | 25 +++ 38-haskell-generic-json/app/Main.hs | 28 +++ 38-haskell-generic-json/flake.lock | 27 +++ 38-haskell-generic-json/flake.nix | 38 ++++ .../mini-generic-json.cabal | 32 ++++ .../src/MiniGenericJson/Manifest.hs | 161 +++++++++++++++++ 38-haskell-generic-json/test/Main.hs | 35 ++++ notes/014-haskell-learning-path.md | 6 + notes/040-haskell-transformer-stack.md | 63 +++++++ notes/041-haskell-generic-json.md | 61 +++++++ 17 files changed, 830 insertions(+) create mode 100644 37-haskell-transformer-stack/README.md create mode 100644 37-haskell-transformer-stack/app/Main.hs create mode 100644 37-haskell-transformer-stack/flake.lock create mode 100644 37-haskell-transformer-stack/flake.nix create mode 100644 37-haskell-transformer-stack/mini-stack.cabal create mode 100644 37-haskell-transformer-stack/src/MiniStack/Rollout.hs create mode 100644 37-haskell-transformer-stack/test/Main.hs create mode 100644 38-haskell-generic-json/README.md create mode 100644 38-haskell-generic-json/app/Main.hs create mode 100644 38-haskell-generic-json/flake.lock create mode 100644 38-haskell-generic-json/flake.nix create mode 100644 38-haskell-generic-json/mini-generic-json.cabal create mode 100644 38-haskell-generic-json/src/MiniGenericJson/Manifest.hs create mode 100644 38-haskell-generic-json/test/Main.hs create mode 100644 notes/040-haskell-transformer-stack.md create mode 100644 notes/041-haskell-generic-json.md diff --git a/37-haskell-transformer-stack/README.md b/37-haskell-transformer-stack/README.md new file mode 100644 index 0000000..7408f35 --- /dev/null +++ b/37-haskell-transformer-stack/README.md @@ -0,0 +1,26 @@ +# 37-haskell-transformer-stack + +This example shows intermediate Haskell effect composition with a transformer stack. + +It includes: + +- a rollout environment carried by `ReaderT`, +- explicit rollout failures carried by `ExceptT`, +- ordered audit lines carried by `Writer`, +- one stacked workflow that validates and renders a rollout summary, and +- a test suite run by `nix flake check`. + +Useful commands: + +```bash +nix develop +cabal run +cabal run -- api:production:4 +cabal test + +nix build +./result/bin/mini-stack api:production:4 + +nix run . -- api:production:4 +nix flake check +``` diff --git a/37-haskell-transformer-stack/app/Main.hs b/37-haskell-transformer-stack/app/Main.hs new file mode 100644 index 0000000..012fc82 --- /dev/null +++ b/37-haskell-transformer-stack/app/Main.hs @@ -0,0 +1,29 @@ +module Main where + +import MiniStack.Rollout + ( defaultEnv + , parseRequest + , renderError + , renderLog + , renderSummary + , runRollout + ) +import System.Environment (getArgs) +import System.Exit (die) + +main :: IO () +main = do + args <- getArgs + let inputArg = + case args of + [] -> "api:production:4" + firstArg : _ -> firstArg + + case parseRequest inputArg of + Left err -> die err + Right request -> + case runRollout defaultEnv request of + (Left rolloutError, auditLog) -> die (renderError rolloutError ++ "\n" ++ renderLog auditLog) + (Right rolloutSummary, auditLog) -> do + putStrLn (renderSummary rolloutSummary) + putStrLn (renderLog auditLog) diff --git a/37-haskell-transformer-stack/flake.lock b/37-haskell-transformer-stack/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/37-haskell-transformer-stack/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/37-haskell-transformer-stack/flake.nix b/37-haskell-transformer-stack/flake.nix new file mode 100644 index 0000000..8af4367 --- /dev/null +++ b/37-haskell-transformer-stack/flake.nix @@ -0,0 +1,38 @@ +{ + # Builds a Haskell project that composes configuration, failure, and audit + # logging through a transformer stack. + description = "A Haskell project for transformer stacks"; + + 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-stack" ./. { }; + checkedProject = pkgs.haskell.lib.doCheck project; + in + { + packages.${system}.default = project; + + apps.${system}.default = { + type = "app"; + program = "${self.packages.${system}.default}/bin/mini-stack"; + meta.description = "Run the transformer stack rollout example."; + }; + + devShells.${system}.default = pkgs.mkShell { + packages = [ + haskellPackages.ghc + pkgs.cabal-install + pkgs.haskell-language-server + ]; + }; + + checks.${system}.test-suite = checkedProject; + }; +} diff --git a/37-haskell-transformer-stack/mini-stack.cabal b/37-haskell-transformer-stack/mini-stack.cabal new file mode 100644 index 0000000..5e06c3f --- /dev/null +++ b/37-haskell-transformer-stack/mini-stack.cabal @@ -0,0 +1,29 @@ +cabal-version: 2.4 +name: mini-stack +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MiniStack.Rollout + hs-source-dirs: src + build-depends: + base >=4.14 && <5, + mtl + default-language: Haskell2010 + +executable mini-stack + main-is: Main.hs + hs-source-dirs: app + build-depends: + base >=4.14 && <5, + mini-stack + default-language: Haskell2010 + +test-suite mini-stack-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base >=4.14 && <5, + mini-stack + default-language: Haskell2010 diff --git a/37-haskell-transformer-stack/src/MiniStack/Rollout.hs b/37-haskell-transformer-stack/src/MiniStack/Rollout.hs new file mode 100644 index 0000000..4143e4e --- /dev/null +++ b/37-haskell-transformer-stack/src/MiniStack/Rollout.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE FlexibleContexts #-} + +module MiniStack.Rollout where + +import Control.Monad.Except + ( ExceptT + , MonadError + , runExceptT + , throwError + ) +import Control.Monad.Reader + ( MonadReader + , ReaderT + , asks + , runReaderT + ) +import Control.Monad.Writer.Strict + ( MonadWriter + , Writer + , runWriter + , tell + ) +import Data.List (intercalate) + +data Environment + = Staging + | Production + deriving (Eq, Show) + +data RolloutRequest = RolloutRequest + { requestService :: String + , requestEnvironment :: Environment + , requestReplicas :: Int + } + deriving (Eq, Show) + +data Env = Env + { clusterName :: String + , maxProductionReplicas :: Int + , restrictedServices :: [String] + } + deriving (Eq, Show) + +data RolloutError + = ReplicasTooHigh Int + | RestrictedService String + deriving (Eq, Show) + +data RolloutSummary = RolloutSummary + { summaryService :: String + , summaryEnvironment :: Environment + , summaryCluster :: String + , summaryReplicas :: Int + } + deriving (Eq, Show) + +type App = ReaderT Env (ExceptT RolloutError (Writer [String])) + +defaultEnv :: Env +defaultEnv = + Env + { clusterName = "europe-west" + , maxProductionReplicas = 6 + , restrictedServices = ["billing"] + } + +parseRequest :: String -> Either String RolloutRequest +parseRequest rawRequest = + case splitOn ':' rawRequest of + [serviceName, environmentName, rawReplicas] -> do + environment <- parseEnvironment environmentName + replicas <- + case reads rawReplicas of + [(replicaCount, "")] + | replicaCount > 0 -> Right replicaCount + | otherwise -> Left "replicas must be greater than zero" + _ -> Left ("invalid replica count: " ++ rawReplicas) + Right + RolloutRequest + { requestService = serviceName + , requestEnvironment = environment + , requestReplicas = replicas + } + _ -> Left ("expected ::, got: " ++ rawRequest) + +runRollout :: Env -> RolloutRequest -> (Either RolloutError RolloutSummary, [String]) +runRollout env request = + runWriter (runExceptT (runReaderT (executeRollout request) env)) + +executeRollout :: + (MonadReader Env m, MonadError RolloutError m, MonadWriter [String] m) => + RolloutRequest -> + m RolloutSummary +executeRollout request = do + logStep ("start rollout for " ++ requestService request) + ensureServiceAllowed request + ensureReplicaLimit request + targetCluster <- asks clusterName + logStep ("deploy to cluster " ++ targetCluster) + logStep ("set replicas to " ++ show (requestReplicas request)) + pure + RolloutSummary + { summaryService = requestService request + , summaryEnvironment = requestEnvironment request + , summaryCluster = targetCluster + , summaryReplicas = requestReplicas request + } + +ensureServiceAllowed :: + (MonadReader Env m, MonadError RolloutError m, MonadWriter [String] m) => + RolloutRequest -> + m () +ensureServiceAllowed request = do + deniedServices <- asks restrictedServices + case requestEnvironment request of + Staging -> logStep "service is allowed in staging" + Production + | requestService request `elem` deniedServices -> + throwError (RestrictedService (requestService request)) + | otherwise -> logStep "service is allowed in production" + +ensureReplicaLimit :: + (MonadReader Env m, MonadError RolloutError m, MonadWriter [String] m) => + RolloutRequest -> + m () +ensureReplicaLimit request = + case requestEnvironment request of + Staging -> logStep "staging rollout skips production replica limit" + Production -> do + replicaLimit <- asks maxProductionReplicas + if requestReplicas request > replicaLimit then + throwError (ReplicasTooHigh replicaLimit) + else + logStep ("replica limit ok: " ++ show replicaLimit) + +renderSummary :: RolloutSummary -> String +renderSummary summary = + intercalate + ", " + [ summaryService summary ++ " -> " ++ renderEnvironment (summaryEnvironment summary) + , "cluster " ++ summaryCluster summary + , "replicas " ++ show (summaryReplicas summary) + ] + +renderError :: RolloutError -> String +renderError (ReplicasTooHigh replicaLimit) = "replicas exceed production limit of " ++ show replicaLimit +renderError (RestrictedService serviceName) = "service is restricted in production: " ++ serviceName + +renderLog :: [String] -> String +renderLog = unlines + +logStep :: MonadWriter [String] m => String -> m () +logStep message = tell [message] + +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" + +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/37-haskell-transformer-stack/test/Main.hs b/37-haskell-transformer-stack/test/Main.hs new file mode 100644 index 0000000..bbd9358 --- /dev/null +++ b/37-haskell-transformer-stack/test/Main.hs @@ -0,0 +1,35 @@ +module Main where + +import MiniStack.Rollout + ( Environment (Production) + , RolloutError (RestrictedService) + , RolloutSummary (RolloutSummary) + , defaultEnv + , parseRequest + , renderLog + , renderSummary + , runRollout + ) +import System.Exit (die) + +main :: IO () +main = + case (parseRequest "api:production:4", parseRequest "billing:production:2") of + ( Right allowedRequest + , Right deniedRequest + ) -> + case (runRollout defaultEnv allowedRequest, runRollout defaultEnv deniedRequest) of + ( (Right summary, allowedLog) + , (Left (RestrictedService "billing"), deniedLog) + ) | renderSummary summary == "api -> production, cluster europe-west, replicas 4" + && lines (renderLog allowedLog) + == [ "start rollout for api" + , "service is allowed in production" + , "replica limit ok: 6" + , "deploy to cluster europe-west" + , "set replicas to 4" + ] + && lines (renderLog deniedLog) == ["start rollout for billing"] -> + putStrLn "test passed" + _ -> die "unexpected transformer stack result" + _ -> die "unexpected rollout parse result" diff --git a/38-haskell-generic-json/README.md b/38-haskell-generic-json/README.md new file mode 100644 index 0000000..3f4f7e5 --- /dev/null +++ b/38-haskell-generic-json/README.md @@ -0,0 +1,25 @@ +# 38-haskell-generic-json + +This example shows intermediate Haskell JSON work with generic deriving. + +It includes: + +- a release manifest with `Generic`-derived JSON instances, +- a sum type for rollout strategy encoded through Aeson generic options, +- a CLI that encodes a manifest and decodes it back, and +- a test suite run by `nix flake check`. + +Useful commands: + +```bash +nix develop +cabal run +cabal run -- api production 3 platform,security stable +cabal test + +nix build +./result/bin/mini-generic-json api production 3 platform,security stable + +nix run . -- api production 3 platform,security stable +nix flake check +``` diff --git a/38-haskell-generic-json/app/Main.hs b/38-haskell-generic-json/app/Main.hs new file mode 100644 index 0000000..c73352f --- /dev/null +++ b/38-haskell-generic-json/app/Main.hs @@ -0,0 +1,28 @@ +module Main where + +import qualified Data.ByteString.Lazy.Char8 as ByteString +import MiniGenericJson.Manifest + ( decodeManifest + , encodeManifest + , parseArgs + , renderManifest + ) +import System.Environment (getArgs) +import System.Exit (die) + +main :: IO () +main = do + args <- getArgs + let inputArgs = + case args of + [] -> ["api", "production", "3", "platform,security", "stable"] + _ -> args + + case parseArgs inputArgs of + Left err -> die err + Right manifest -> do + let encodedManifest = encodeManifest manifest + ByteString.putStrLn encodedManifest + case decodeManifest encodedManifest of + Left err -> die err + Right decodedManifest -> putStrLn (renderManifest decodedManifest) diff --git a/38-haskell-generic-json/flake.lock b/38-haskell-generic-json/flake.lock new file mode 100644 index 0000000..dfdfdf9 --- /dev/null +++ b/38-haskell-generic-json/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/38-haskell-generic-json/flake.nix b/38-haskell-generic-json/flake.nix new file mode 100644 index 0000000..040614e --- /dev/null +++ b/38-haskell-generic-json/flake.nix @@ -0,0 +1,38 @@ +{ + # Builds a Haskell project that derives JSON instances generically for a + # release manifest and rollout strategy. + description = "A Haskell project for generic JSON deriving"; + + 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-generic-json" ./. { }; + checkedProject = pkgs.haskell.lib.doCheck project; + in + { + packages.${system}.default = project; + + apps.${system}.default = { + type = "app"; + program = "${self.packages.${system}.default}/bin/mini-generic-json"; + meta.description = "Run the generic JSON deriving example."; + }; + + devShells.${system}.default = pkgs.mkShell { + packages = [ + haskellPackages.ghc + pkgs.cabal-install + pkgs.haskell-language-server + ]; + }; + + checks.${system}.test-suite = checkedProject; + }; +} diff --git a/38-haskell-generic-json/mini-generic-json.cabal b/38-haskell-generic-json/mini-generic-json.cabal new file mode 100644 index 0000000..362e6d2 --- /dev/null +++ b/38-haskell-generic-json/mini-generic-json.cabal @@ -0,0 +1,32 @@ +cabal-version: 2.4 +name: mini-generic-json +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: MiniGenericJson.Manifest + hs-source-dirs: src + build-depends: + aeson, + base >=4.14 && <5, + bytestring, + text + default-language: Haskell2010 + +executable mini-generic-json + main-is: Main.hs + hs-source-dirs: app + build-depends: + base >=4.14 && <5, + bytestring, + mini-generic-json + default-language: Haskell2010 + +test-suite mini-generic-json-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base >=4.14 && <5, + mini-generic-json + default-language: Haskell2010 diff --git a/38-haskell-generic-json/src/MiniGenericJson/Manifest.hs b/38-haskell-generic-json/src/MiniGenericJson/Manifest.hs new file mode 100644 index 0000000..97a09bb --- /dev/null +++ b/38-haskell-generic-json/src/MiniGenericJson/Manifest.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module MiniGenericJson.Manifest where + +import Data.Aeson + ( FromJSON + , Options + , SumEncoding (ObjectWithSingleField) + , ToJSON + , defaultOptions + , eitherDecode + , fieldLabelModifier + , genericParseJSON + , genericToJSON + , sumEncoding + , tagSingleConstructors + , constructorTagModifier + ) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as ByteString +import Data.List (intercalate) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) + +data Environment + = Staging + | Production + deriving (Eq, Show, Generic) + +data RolloutStrategy + = Stable + | Canary Int + deriving (Eq, Show, Generic) + +data ReleaseManifest = ReleaseManifest + { manifestService :: Text + , manifestEnvironment :: Environment + , manifestReplicas :: Int + , manifestOwners :: [Text] + , manifestStrategy :: RolloutStrategy + } + deriving (Eq, Show, Generic) + +instance ToJSON Environment where + toJSON = genericToJSON enumOptions + +instance FromJSON Environment where + parseJSON = genericParseJSON enumOptions + +instance ToJSON RolloutStrategy where + toJSON = genericToJSON strategyOptions + +instance FromJSON RolloutStrategy where + parseJSON = genericParseJSON strategyOptions + +instance ToJSON ReleaseManifest where + toJSON = genericToJSON manifestOptions + +instance FromJSON ReleaseManifest where + parseJSON = genericParseJSON manifestOptions + +parseArgs :: [String] -> Either String ReleaseManifest +parseArgs [serviceName, environmentName, rawReplicas, rawOwners, strategyName] = do + environment <- parseEnvironment environmentName + replicas <- parseReplicas rawReplicas + strategy <- parseStrategy strategyName + pure + ReleaseManifest + { manifestService = Text.pack serviceName + , manifestEnvironment = environment + , manifestReplicas = replicas + , manifestOwners = map Text.pack (splitOn ',' rawOwners) + , manifestStrategy = strategy + } +parseArgs _ = + Left "expected either no arguments or: " + +encodeManifest :: ReleaseManifest -> ByteString.ByteString +encodeManifest = Aeson.encode + +decodeManifest :: ByteString.ByteString -> Either String ReleaseManifest +decodeManifest = eitherDecode + +renderManifest :: ReleaseManifest -> String +renderManifest manifest = + intercalate + ", " + [ "service " ++ Text.unpack (manifestService manifest) + , "env " ++ renderEnvironment (manifestEnvironment manifest) + , "replicas " ++ show (manifestReplicas manifest) + , "owners " ++ intercalate "/" (map Text.unpack (manifestOwners manifest)) + , "strategy " ++ renderStrategy (manifestStrategy manifest) + ] + +manifestOptions :: Options +manifestOptions = + defaultOptions + { fieldLabelModifier = drop (length ("manifest" :: String)) + } + +enumOptions :: Options +enumOptions = + defaultOptions + { constructorTagModifier = map toLowerAscii + } + +strategyOptions :: Options +strategyOptions = + defaultOptions + { constructorTagModifier = map toLowerAscii + , sumEncoding = ObjectWithSingleField + , tagSingleConstructors = True + } + +parseEnvironment :: String -> Either String Environment +parseEnvironment "staging" = Right Staging +parseEnvironment "production" = Right Production +parseEnvironment otherValue = Left ("unknown environment: " ++ 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) + +parseStrategy :: String -> Either String RolloutStrategy +parseStrategy "stable" = Right Stable +parseStrategy rawValue = + case break (== ':') rawValue of + ("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) + _ -> Left ("unknown strategy: " ++ rawValue) + +renderEnvironment :: Environment -> String +renderEnvironment Staging = "staging" +renderEnvironment Production = "production" + +renderStrategy :: RolloutStrategy -> String +renderStrategy Stable = "stable" +renderStrategy (Canary percent) = "canary " ++ show percent ++ "%" + +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 + +toLowerAscii :: Char -> Char +toLowerAscii nextChar + | 'A' <= nextChar && nextChar <= 'Z' = toEnum (fromEnum nextChar + 32) + | otherwise = nextChar diff --git a/38-haskell-generic-json/test/Main.hs b/38-haskell-generic-json/test/Main.hs new file mode 100644 index 0000000..d516c0d --- /dev/null +++ b/38-haskell-generic-json/test/Main.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import MiniGenericJson.Manifest + ( ReleaseManifest (..) + , Environment (Production) + , RolloutStrategy (Stable, Canary) + , decodeManifest + , encodeManifest + , renderManifest + ) +import System.Exit (die) + +sampleManifest :: ReleaseManifest +sampleManifest = + ReleaseManifest + { manifestService = "api" + , manifestEnvironment = Production + , manifestReplicas = 3 + , manifestOwners = ["platform", "security"] + , manifestStrategy = Canary 10 + } + +main :: IO () +main = + case + ( decodeManifest (encodeManifest sampleManifest) + , decodeManifest "{\"service\":\"api\"}" + ) of + ( Right decodedManifest + , Left _ + ) | renderManifest decodedManifest == "service api, env production, replicas 3, owners platform/security, strategy canary 10%" -> + putStrLn "test passed" + _ -> die "unexpected generic JSON result" diff --git a/notes/014-haskell-learning-path.md b/notes/014-haskell-learning-path.md index da48557..5fdf50e 100644 --- a/notes/014-haskell-learning-path.md +++ b/notes/014-haskell-learning-path.md @@ -28,6 +28,8 @@ This note links the Haskell examples in a suggested order from first project str 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` +23. `37-haskell-transformer-stack/`: composed effects with `ReaderT`, `ExceptT`, and `Writer` +24. `38-haskell-generic-json/`: generic JSON instances with Aeson options --- @@ -55,6 +57,8 @@ This note links the Haskell examples in a suggested order from first project str - `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 +- `37-haskell-transformer-stack/`: how to combine several effects in one concrete workflow +- `38-haskell-generic-json/`: how to reduce JSON boilerplate without giving up a deliberate shape --- @@ -82,3 +86,5 @@ This note links the Haskell examples in a suggested order from first project str - `notes/037-haskell-dependency-order.md` - `notes/038-haskell-monad-chaining.md` - `notes/039-haskell-map-set-modeling.md` +- `notes/040-haskell-transformer-stack.md` +- `notes/041-haskell-generic-json.md` diff --git a/notes/040-haskell-transformer-stack.md b/notes/040-haskell-transformer-stack.md new file mode 100644 index 0000000..20f771a --- /dev/null +++ b/notes/040-haskell-transformer-stack.md @@ -0,0 +1,63 @@ +# Haskell Transformer Stacks + +This note covers `37-haskell-transformer-stack/`, which composes `ReaderT`, `ExceptT`, and `Writer` in one rollout workflow. + +--- + +## 1. Why a Stack Helps Here + +The rollout workflow needs three independent capabilities: + +- configuration from an environment, +- explicit business failures, and +- ordered audit output. + +This example puts them together directly: + +```haskell +type App = ReaderT Env (ExceptT RolloutError (Writer [String])) +``` + +That is the core teaching point. The effect requirements live in one concrete stack, while the workflow stays readable. + +--- + +## 2. What the Workflow Actually Does + +The stack is not there for decoration. The rollout code: + +- reads cluster and policy settings, +- rejects restricted or oversized production rollouts, and +- records each successful step in an audit log. + +That gives each transformer a concrete job. + +--- + +## 3. Why This Complements the Earlier Examples + +Earlier notes introduced these pieces separately: + +- `ReaderT` and `Except` in `10-haskell-effects/`, and +- `Writer` in `31-haskell-writer-audit/`. + +This example shows the next practical step: combining them when one workflow needs all three. + +--- + +## 4. Commands to Try + +```bash +cd 37-haskell-transformer-stack + +nix develop +cabal run +cabal run -- api:production:4 +cabal test + +nix build +./result/bin/mini-stack api:production:4 + +nix run . -- api:production:4 +nix flake check +``` diff --git a/notes/041-haskell-generic-json.md b/notes/041-haskell-generic-json.md new file mode 100644 index 0000000..cb62195 --- /dev/null +++ b/notes/041-haskell-generic-json.md @@ -0,0 +1,61 @@ +# Haskell Generic JSON + +This note covers `38-haskell-generic-json/`, which derives JSON instances generically for a release manifest and rollout strategy. + +--- + +## 1. Why This Exists Next to the Manual JSON Example + +`27-haskell-aeson-roundtrip/` defines JSON instances by hand so the wire format stays fully explicit. + +This example shows the contrasting approach: + +- derive `Generic`, +- configure Aeson options once, and +- let `genericToJSON` and `genericParseJSON` do the repetitive instance work. + +That is useful because both styles show up in real Haskell codebases. + +--- + +## 2. What the Generic Options Control + +The example is not just `deriving anyclass`. + +It still configures the shape: + +- field labels drop the `manifest` prefix, and +- the rollout strategy sum type uses a tagged object representation. + +That is the important teaching point. Generic deriving can still produce an intentional JSON format when you provide the right options. + +--- + +## 3. When This Tradeoff Makes Sense + +Generic deriving reduces boilerplate when: + +- your Haskell fields already describe the desired structure closely, and +- you want the encoder and decoder to stay in sync with minimal manual code. + +It is less appropriate when the wire format needs heavy customization. That contrast is exactly why it is useful to pair this example with the manual +JSON example earlier in the track. + +--- + +## 4. Commands to Try + +```bash +cd 38-haskell-generic-json + +nix develop +cabal run +cabal run -- api production 3 platform,security stable +cabal test + +nix build +./result/bin/mini-generic-json api production 3 platform,security stable + +nix run . -- api production 3 platform,security stable +nix flake check +```