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
|
||||
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`
|
||||
|
||||
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