Add two more Haskell examples (with their note files)
This commit is contained in:
parent
ab32d287a9
commit
e5906d9163
26
37-haskell-transformer-stack/README.md
Normal file
26
37-haskell-transformer-stack/README.md
Normal file
@ -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
|
||||||
|
```
|
||||||
29
37-haskell-transformer-stack/app/Main.hs
Normal file
29
37-haskell-transformer-stack/app/Main.hs
Normal file
@ -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)
|
||||||
27
37-haskell-transformer-stack/flake.lock
generated
Normal file
27
37-haskell-transformer-stack/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
37-haskell-transformer-stack/flake.nix
Normal file
38
37-haskell-transformer-stack/flake.nix
Normal file
@ -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;
|
||||||
|
};
|
||||||
|
}
|
||||||
29
37-haskell-transformer-stack/mini-stack.cabal
Normal file
29
37-haskell-transformer-stack/mini-stack.cabal
Normal file
@ -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
|
||||||
170
37-haskell-transformer-stack/src/MiniStack/Rollout.hs
Normal file
170
37-haskell-transformer-stack/src/MiniStack/Rollout.hs
Normal file
@ -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 <service>:<environment>:<replicas>, 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
|
||||||
35
37-haskell-transformer-stack/test/Main.hs
Normal file
35
37-haskell-transformer-stack/test/Main.hs
Normal file
@ -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"
|
||||||
25
38-haskell-generic-json/README.md
Normal file
25
38-haskell-generic-json/README.md
Normal file
@ -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
|
||||||
|
```
|
||||||
28
38-haskell-generic-json/app/Main.hs
Normal file
28
38-haskell-generic-json/app/Main.hs
Normal file
@ -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)
|
||||||
27
38-haskell-generic-json/flake.lock
generated
Normal file
27
38-haskell-generic-json/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
38-haskell-generic-json/flake.nix
Normal file
38
38-haskell-generic-json/flake.nix
Normal file
@ -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;
|
||||||
|
};
|
||||||
|
}
|
||||||
32
38-haskell-generic-json/mini-generic-json.cabal
Normal file
32
38-haskell-generic-json/mini-generic-json.cabal
Normal file
@ -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
|
||||||
161
38-haskell-generic-json/src/MiniGenericJson/Manifest.hs
Normal file
161
38-haskell-generic-json/src/MiniGenericJson/Manifest.hs
Normal file
@ -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: <service> <environment> <replicas> <owners> <stable|canary:percent>"
|
||||||
|
|
||||||
|
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
|
||||||
35
38-haskell-generic-json/test/Main.hs
Normal file
35
38-haskell-generic-json/test/Main.hs
Normal file
@ -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"
|
||||||
@ -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
|
20. `34-haskell-dependency-order/`: dependency-ordered planning with cycle checks
|
||||||
21. `35-haskell-monad-chaining/`: dependent rollout approval with monadic `Either`
|
21. `35-haskell-monad-chaining/`: dependent rollout approval with monadic `Either`
|
||||||
22. `36-haskell-map-set-modeling/`: access-policy modeling with `Map` and `Set`
|
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
|
- `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
|
- `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
|
- `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/037-haskell-dependency-order.md`
|
||||||
- `notes/038-haskell-monad-chaining.md`
|
- `notes/038-haskell-monad-chaining.md`
|
||||||
- `notes/039-haskell-map-set-modeling.md`
|
- `notes/039-haskell-map-set-modeling.md`
|
||||||
|
- `notes/040-haskell-transformer-stack.md`
|
||||||
|
- `notes/041-haskell-generic-json.md`
|
||||||
|
|||||||
63
notes/040-haskell-transformer-stack.md
Normal file
63
notes/040-haskell-transformer-stack.md
Normal file
@ -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
|
||||||
|
```
|
||||||
61
notes/041-haskell-generic-json.md
Normal file
61
notes/041-haskell-generic-json.md
Normal file
@ -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
|
||||||
|
```
|
||||||
Loading…
x
Reference in New Issue
Block a user