Add three Haskell examples (with acompanying note files)
This commit is contained in:
parent
5967d1bb61
commit
a2ec4b537c
23
43-haskell-tree-rollouts/README.md
Normal file
23
43-haskell-tree-rollouts/README.md
Normal file
@ -0,0 +1,23 @@
|
|||||||
|
# 43-haskell-tree-rollouts
|
||||||
|
|
||||||
|
This example shows rollout planning with `Data.Tree`.
|
||||||
|
|
||||||
|
It includes:
|
||||||
|
|
||||||
|
- one tree-shaped rollout plan with environments and services,
|
||||||
|
- functions that render the tree and enumerate root-to-leaf deployment paths, and
|
||||||
|
- a test suite run by `nix flake check`.
|
||||||
|
|
||||||
|
Useful commands:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
nix develop
|
||||||
|
cabal run
|
||||||
|
cabal test
|
||||||
|
|
||||||
|
nix build
|
||||||
|
./result/bin/mini-tree-rollouts
|
||||||
|
|
||||||
|
nix run
|
||||||
|
nix flake check
|
||||||
|
```
|
||||||
14
43-haskell-tree-rollouts/app/Main.hs
Normal file
14
43-haskell-tree-rollouts/app/Main.hs
Normal file
@ -0,0 +1,14 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import MiniTreeRollouts.Plan
|
||||||
|
( renderPaths
|
||||||
|
, renderPlan
|
||||||
|
, samplePlan
|
||||||
|
)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
putStrLn "plan:"
|
||||||
|
putStrLn (renderPlan samplePlan)
|
||||||
|
putStrLn "paths:"
|
||||||
|
putStr (renderPaths samplePlan)
|
||||||
27
43-haskell-tree-rollouts/flake.lock
generated
Normal file
27
43-haskell-tree-rollouts/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
|
||||||
|
}
|
||||||
37
43-haskell-tree-rollouts/flake.nix
Normal file
37
43-haskell-tree-rollouts/flake.nix
Normal file
@ -0,0 +1,37 @@
|
|||||||
|
{
|
||||||
|
# Builds a Haskell project that models a rollout hierarchy with `Data.Tree`.
|
||||||
|
description = "A Haskell project for tree-shaped rollout plans";
|
||||||
|
|
||||||
|
inputs = {
|
||||||
|
nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
|
||||||
|
};
|
||||||
|
|
||||||
|
outputs =
|
||||||
|
{ self, nixpkgs, ... }:
|
||||||
|
let
|
||||||
|
system = "x86_64-linux";
|
||||||
|
pkgs = import nixpkgs { inherit system; };
|
||||||
|
inherit (pkgs) haskellPackages;
|
||||||
|
project = haskellPackages.callCabal2nix "mini-tree-rollouts" ./. { };
|
||||||
|
checkedProject = pkgs.haskell.lib.doCheck project;
|
||||||
|
in
|
||||||
|
{
|
||||||
|
packages.${system}.default = project;
|
||||||
|
|
||||||
|
apps.${system}.default = {
|
||||||
|
type = "app";
|
||||||
|
program = "${self.packages.${system}.default}/bin/mini-tree-rollouts";
|
||||||
|
meta.description = "Run the Data.Tree rollout planning example.";
|
||||||
|
};
|
||||||
|
|
||||||
|
devShells.${system}.default = pkgs.mkShell {
|
||||||
|
packages = [
|
||||||
|
haskellPackages.ghc
|
||||||
|
pkgs.cabal-install
|
||||||
|
pkgs.haskell-language-server
|
||||||
|
];
|
||||||
|
};
|
||||||
|
|
||||||
|
checks.${system}.test-suite = checkedProject;
|
||||||
|
};
|
||||||
|
}
|
||||||
29
43-haskell-tree-rollouts/mini-tree-rollouts.cabal
Normal file
29
43-haskell-tree-rollouts/mini-tree-rollouts.cabal
Normal file
@ -0,0 +1,29 @@
|
|||||||
|
cabal-version: 2.4
|
||||||
|
name: mini-tree-rollouts
|
||||||
|
version: 0.1.0.0
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules: MiniTreeRollouts.Plan
|
||||||
|
hs-source-dirs: src
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
containers
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
executable mini-tree-rollouts
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: app
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
mini-tree-rollouts
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite mini-tree-rollouts-test
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: test
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
mini-tree-rollouts
|
||||||
|
default-language: Haskell2010
|
||||||
51
43-haskell-tree-rollouts/src/MiniTreeRollouts/Plan.hs
Normal file
51
43-haskell-tree-rollouts/src/MiniTreeRollouts/Plan.hs
Normal file
@ -0,0 +1,51 @@
|
|||||||
|
module MiniTreeRollouts.Plan where
|
||||||
|
|
||||||
|
import Data.List (intercalate)
|
||||||
|
import Data.Tree (Tree (Node), drawTree)
|
||||||
|
|
||||||
|
data RolloutNode = RolloutNode
|
||||||
|
{ nodeName :: String
|
||||||
|
, nodeOwner :: String
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
samplePlan :: Tree RolloutNode
|
||||||
|
samplePlan =
|
||||||
|
Node
|
||||||
|
(RolloutNode "checkout-release" "platform")
|
||||||
|
[ Node
|
||||||
|
(RolloutNode "staging" "release")
|
||||||
|
[ Node (RolloutNode "api" "search") []
|
||||||
|
, Node (RolloutNode "worker" "search") []
|
||||||
|
]
|
||||||
|
, Node
|
||||||
|
(RolloutNode "production" "release")
|
||||||
|
[ Node (RolloutNode "api" "search") []
|
||||||
|
, Node (RolloutNode "billing" "revenue") []
|
||||||
|
]
|
||||||
|
]
|
||||||
|
|
||||||
|
deploymentPaths :: Tree RolloutNode -> [[RolloutNode]]
|
||||||
|
deploymentPaths = go []
|
||||||
|
where
|
||||||
|
go pathPrefix (Node nextNode childNodes) =
|
||||||
|
let currentPath = pathPrefix ++ [nextNode]
|
||||||
|
in if null childNodes then
|
||||||
|
[currentPath]
|
||||||
|
else
|
||||||
|
concatMap (go currentPath) childNodes
|
||||||
|
|
||||||
|
leafServices :: Tree RolloutNode -> [String]
|
||||||
|
leafServices = map (nodeName . last) . deploymentPaths
|
||||||
|
|
||||||
|
renderPlan :: Tree RolloutNode -> String
|
||||||
|
renderPlan = drawTree . fmap renderNode
|
||||||
|
|
||||||
|
renderPaths :: Tree RolloutNode -> String
|
||||||
|
renderPaths = unlines . map renderPath . deploymentPaths
|
||||||
|
|
||||||
|
renderPath :: [RolloutNode] -> String
|
||||||
|
renderPath = intercalate " -> " . map nodeName
|
||||||
|
|
||||||
|
renderNode :: RolloutNode -> String
|
||||||
|
renderNode rolloutNode = nodeName rolloutNode ++ " (" ++ nodeOwner rolloutNode ++ ")"
|
||||||
22
43-haskell-tree-rollouts/test/Main.hs
Normal file
22
43-haskell-tree-rollouts/test/Main.hs
Normal file
@ -0,0 +1,22 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import MiniTreeRollouts.Plan
|
||||||
|
( deploymentPaths
|
||||||
|
, leafServices
|
||||||
|
, renderPath
|
||||||
|
, samplePlan
|
||||||
|
)
|
||||||
|
import System.Exit (die)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main =
|
||||||
|
if map renderPath (deploymentPaths samplePlan)
|
||||||
|
== [ "checkout-release -> staging -> api"
|
||||||
|
, "checkout-release -> staging -> worker"
|
||||||
|
, "checkout-release -> production -> api"
|
||||||
|
, "checkout-release -> production -> billing"
|
||||||
|
]
|
||||||
|
&& leafServices samplePlan == ["api", "worker", "api", "billing"] then
|
||||||
|
putStrLn "test passed"
|
||||||
|
else
|
||||||
|
die "unexpected Data.Tree result"
|
||||||
24
44-haskell-seq-queues/README.md
Normal file
24
44-haskell-seq-queues/README.md
Normal file
@ -0,0 +1,24 @@
|
|||||||
|
# 44-haskell-seq-queues
|
||||||
|
|
||||||
|
This example shows FIFO retry batching with `Data.Sequence`.
|
||||||
|
|
||||||
|
It includes:
|
||||||
|
|
||||||
|
- one queue of retry requests backed by `Seq`,
|
||||||
|
- functions that append retries and take the next batch in order, and
|
||||||
|
- a test suite run by `nix flake check`.
|
||||||
|
|
||||||
|
Useful commands:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
nix develop
|
||||||
|
cabal run
|
||||||
|
cabal run -- 3
|
||||||
|
cabal test
|
||||||
|
|
||||||
|
nix build
|
||||||
|
./result/bin/mini-seq-queues 3
|
||||||
|
|
||||||
|
nix run . -- 3
|
||||||
|
nix flake check
|
||||||
|
```
|
||||||
32
44-haskell-seq-queues/app/Main.hs
Normal file
32
44-haskell-seq-queues/app/Main.hs
Normal file
@ -0,0 +1,32 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import MiniSeqQueues.Queue
|
||||||
|
( Retry (Retry)
|
||||||
|
, enqueueRetry
|
||||||
|
, renderBatch
|
||||||
|
, renderQueue
|
||||||
|
, sampleQueue
|
||||||
|
, takeBatch
|
||||||
|
)
|
||||||
|
import System.Environment (getArgs)
|
||||||
|
import System.Exit (die)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
args <- getArgs
|
||||||
|
batchSize <-
|
||||||
|
case args of
|
||||||
|
[] -> pure 2
|
||||||
|
[rawBatchSize] ->
|
||||||
|
case reads rawBatchSize of
|
||||||
|
[(parsedBatchSize, "")]
|
||||||
|
| parsedBatchSize > 0 -> pure parsedBatchSize
|
||||||
|
| otherwise -> die "batch size must be greater than zero"
|
||||||
|
_ -> die ("invalid batch size: " ++ rawBatchSize)
|
||||||
|
_ -> die "expected either no arguments or: <batch-size>"
|
||||||
|
|
||||||
|
let queueWithNewRetry = enqueueRetry sampleQueue (Retry "auth" 1)
|
||||||
|
(nextBatch, remainingQueue) = takeBatch batchSize queueWithNewRetry
|
||||||
|
|
||||||
|
putStrLn ("batch: " ++ renderBatch nextBatch)
|
||||||
|
putStrLn ("remaining: " ++ renderQueue remainingQueue)
|
||||||
27
44-haskell-seq-queues/flake.lock
generated
Normal file
27
44-haskell-seq-queues/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
|
||||||
|
}
|
||||||
37
44-haskell-seq-queues/flake.nix
Normal file
37
44-haskell-seq-queues/flake.nix
Normal file
@ -0,0 +1,37 @@
|
|||||||
|
{
|
||||||
|
# Builds a Haskell project that models a retry queue with `Data.Sequence`.
|
||||||
|
description = "A Haskell project for sequence-backed retry queues";
|
||||||
|
|
||||||
|
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-seq-queues" ./. { };
|
||||||
|
checkedProject = pkgs.haskell.lib.doCheck project;
|
||||||
|
in
|
||||||
|
{
|
||||||
|
packages.${system}.default = project;
|
||||||
|
|
||||||
|
apps.${system}.default = {
|
||||||
|
type = "app";
|
||||||
|
program = "${self.packages.${system}.default}/bin/mini-seq-queues";
|
||||||
|
meta.description = "Run the Data.Sequence retry queue example.";
|
||||||
|
};
|
||||||
|
|
||||||
|
devShells.${system}.default = pkgs.mkShell {
|
||||||
|
packages = [
|
||||||
|
haskellPackages.ghc
|
||||||
|
pkgs.cabal-install
|
||||||
|
pkgs.haskell-language-server
|
||||||
|
];
|
||||||
|
};
|
||||||
|
|
||||||
|
checks.${system}.test-suite = checkedProject;
|
||||||
|
};
|
||||||
|
}
|
||||||
29
44-haskell-seq-queues/mini-seq-queues.cabal
Normal file
29
44-haskell-seq-queues/mini-seq-queues.cabal
Normal file
@ -0,0 +1,29 @@
|
|||||||
|
cabal-version: 2.4
|
||||||
|
name: mini-seq-queues
|
||||||
|
version: 0.1.0.0
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules: MiniSeqQueues.Queue
|
||||||
|
hs-source-dirs: src
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
containers
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
executable mini-seq-queues
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: app
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
mini-seq-queues
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite mini-seq-queues-test
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: test
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
mini-seq-queues
|
||||||
|
default-language: Haskell2010
|
||||||
47
44-haskell-seq-queues/src/MiniSeqQueues/Queue.hs
Normal file
47
44-haskell-seq-queues/src/MiniSeqQueues/Queue.hs
Normal file
@ -0,0 +1,47 @@
|
|||||||
|
module MiniSeqQueues.Queue where
|
||||||
|
|
||||||
|
import Data.Foldable (toList)
|
||||||
|
import Data.List (intercalate)
|
||||||
|
import Data.Sequence
|
||||||
|
( Seq
|
||||||
|
, ViewL (EmptyL, (:<))
|
||||||
|
, (|>)
|
||||||
|
)
|
||||||
|
import qualified Data.Sequence as Seq
|
||||||
|
|
||||||
|
data Retry = Retry
|
||||||
|
{ retryService :: String
|
||||||
|
, retryAttempt :: Int
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
sampleQueue :: Seq Retry
|
||||||
|
sampleQueue =
|
||||||
|
Seq.fromList
|
||||||
|
[ Retry "api" 2
|
||||||
|
, Retry "worker" 1
|
||||||
|
, Retry "billing" 3
|
||||||
|
, Retry "search" 1
|
||||||
|
]
|
||||||
|
|
||||||
|
enqueueRetry :: Seq Retry -> Retry -> Seq Retry
|
||||||
|
enqueueRetry queue retry = queue |> retry
|
||||||
|
|
||||||
|
takeBatch :: Int -> Seq Retry -> ([Retry], Seq Retry)
|
||||||
|
takeBatch batchSize queue
|
||||||
|
| batchSize <= 0 = ([], queue)
|
||||||
|
| otherwise =
|
||||||
|
case Seq.viewl queue of
|
||||||
|
EmptyL -> ([], queue)
|
||||||
|
nextRetry :< remainingQueue ->
|
||||||
|
let (laterBatch, finalQueue) = takeBatch (batchSize - 1) remainingQueue
|
||||||
|
in (nextRetry : laterBatch, finalQueue)
|
||||||
|
|
||||||
|
renderRetry :: Retry -> String
|
||||||
|
renderRetry retry = retryService retry ++ "#" ++ show (retryAttempt retry)
|
||||||
|
|
||||||
|
renderQueue :: Seq Retry -> String
|
||||||
|
renderQueue = intercalate ", " . map renderRetry . toList
|
||||||
|
|
||||||
|
renderBatch :: [Retry] -> String
|
||||||
|
renderBatch = intercalate ", " . map renderRetry
|
||||||
21
44-haskell-seq-queues/test/Main.hs
Normal file
21
44-haskell-seq-queues/test/Main.hs
Normal file
@ -0,0 +1,21 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import MiniSeqQueues.Queue
|
||||||
|
( Retry (Retry)
|
||||||
|
, enqueueRetry
|
||||||
|
, renderBatch
|
||||||
|
, renderQueue
|
||||||
|
, sampleQueue
|
||||||
|
, takeBatch
|
||||||
|
)
|
||||||
|
import System.Exit (die)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main =
|
||||||
|
let queueWithNewRetry = enqueueRetry sampleQueue (Retry "auth" 1)
|
||||||
|
(nextBatch, remainingQueue) = takeBatch 2 queueWithNewRetry
|
||||||
|
in if renderBatch nextBatch == "api#2, worker#1"
|
||||||
|
&& renderQueue remainingQueue == "billing#3, search#1, auth#1" then
|
||||||
|
putStrLn "test passed"
|
||||||
|
else
|
||||||
|
die "unexpected Data.Sequence result"
|
||||||
24
45-haskell-time-windows/README.md
Normal file
24
45-haskell-time-windows/README.md
Normal file
@ -0,0 +1,24 @@
|
|||||||
|
# 45-haskell-time-windows
|
||||||
|
|
||||||
|
This example shows maintenance-window status checks with `Data.Time`.
|
||||||
|
|
||||||
|
It includes:
|
||||||
|
|
||||||
|
- one set of UTC maintenance windows,
|
||||||
|
- functions that parse timestamps and classify whether a window is active or still upcoming, and
|
||||||
|
- a test suite run by `nix flake check`.
|
||||||
|
|
||||||
|
Useful commands:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
nix develop
|
||||||
|
cabal run
|
||||||
|
cabal run -- 2026-05-05T11:45:00Z
|
||||||
|
cabal test
|
||||||
|
|
||||||
|
nix build
|
||||||
|
./result/bin/mini-time-windows 2026-05-05T11:45:00Z
|
||||||
|
|
||||||
|
nix run . -- 2026-05-05T11:45:00Z
|
||||||
|
nix flake check
|
||||||
|
```
|
||||||
23
45-haskell-time-windows/app/Main.hs
Normal file
23
45-haskell-time-windows/app/Main.hs
Normal file
@ -0,0 +1,23 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import MiniTimeWindows.Window
|
||||||
|
( formatInstant
|
||||||
|
, parseInstant
|
||||||
|
, renderStatus
|
||||||
|
, sampleWindows
|
||||||
|
, statusAt
|
||||||
|
)
|
||||||
|
import System.Environment (getArgs)
|
||||||
|
import System.Exit (die)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
args <- getArgs
|
||||||
|
rawInstant <-
|
||||||
|
case args of
|
||||||
|
[] -> pure "2026-05-05T10:30:00Z"
|
||||||
|
[singleInstant] -> pure singleInstant
|
||||||
|
_ -> die "expected either no arguments or: <utc-timestamp>"
|
||||||
|
|
||||||
|
currentInstant <- either die pure (parseInstant rawInstant)
|
||||||
|
putStrLn ("at " ++ formatInstant currentInstant ++ ": " ++ renderStatus (statusAt currentInstant sampleWindows))
|
||||||
27
45-haskell-time-windows/flake.lock
generated
Normal file
27
45-haskell-time-windows/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
|
||||||
|
}
|
||||||
37
45-haskell-time-windows/flake.nix
Normal file
37
45-haskell-time-windows/flake.nix
Normal file
@ -0,0 +1,37 @@
|
|||||||
|
{
|
||||||
|
# Builds a Haskell project that parses and compares UTC windows with `Data.Time`.
|
||||||
|
description = "A Haskell project for UTC maintenance windows";
|
||||||
|
|
||||||
|
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-time-windows" ./. { };
|
||||||
|
checkedProject = pkgs.haskell.lib.doCheck project;
|
||||||
|
in
|
||||||
|
{
|
||||||
|
packages.${system}.default = project;
|
||||||
|
|
||||||
|
apps.${system}.default = {
|
||||||
|
type = "app";
|
||||||
|
program = "${self.packages.${system}.default}/bin/mini-time-windows";
|
||||||
|
meta.description = "Run the Data.Time maintenance window example.";
|
||||||
|
};
|
||||||
|
|
||||||
|
devShells.${system}.default = pkgs.mkShell {
|
||||||
|
packages = [
|
||||||
|
haskellPackages.ghc
|
||||||
|
pkgs.cabal-install
|
||||||
|
pkgs.haskell-language-server
|
||||||
|
];
|
||||||
|
};
|
||||||
|
|
||||||
|
checks.${system}.test-suite = checkedProject;
|
||||||
|
};
|
||||||
|
}
|
||||||
30
45-haskell-time-windows/mini-time-windows.cabal
Normal file
30
45-haskell-time-windows/mini-time-windows.cabal
Normal file
@ -0,0 +1,30 @@
|
|||||||
|
cabal-version: 2.4
|
||||||
|
name: mini-time-windows
|
||||||
|
version: 0.1.0.0
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules: MiniTimeWindows.Window
|
||||||
|
hs-source-dirs: src
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
time
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
executable mini-time-windows
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: app
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
mini-time-windows
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite mini-time-windows-test
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: test
|
||||||
|
build-depends:
|
||||||
|
base >=4.14 && <5,
|
||||||
|
mini-time-windows,
|
||||||
|
time
|
||||||
|
default-language: Haskell2010
|
||||||
85
45-haskell-time-windows/src/MiniTimeWindows/Window.hs
Normal file
85
45-haskell-time-windows/src/MiniTimeWindows/Window.hs
Normal file
@ -0,0 +1,85 @@
|
|||||||
|
module MiniTimeWindows.Window where
|
||||||
|
|
||||||
|
import Data.List (find, sortOn)
|
||||||
|
import Data.Time
|
||||||
|
( NominalDiffTime
|
||||||
|
, UTCTime
|
||||||
|
, defaultTimeLocale
|
||||||
|
, diffUTCTime
|
||||||
|
, formatTime
|
||||||
|
, parseTimeM
|
||||||
|
)
|
||||||
|
|
||||||
|
data MaintenanceWindow = MaintenanceWindow
|
||||||
|
{ windowName :: String
|
||||||
|
, windowStart :: UTCTime
|
||||||
|
, windowEnd :: UTCTime
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data WindowStatus
|
||||||
|
= Active MaintenanceWindow NominalDiffTime
|
||||||
|
| Waiting MaintenanceWindow NominalDiffTime
|
||||||
|
| NoMoreWindows
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
sampleWindows :: [MaintenanceWindow]
|
||||||
|
sampleWindows =
|
||||||
|
[ makeWindow "schema-migration" "2026-05-05T10:00:00Z" "2026-05-05T11:00:00Z"
|
||||||
|
, makeWindow "billing-freeze" "2026-05-05T12:30:00Z" "2026-05-05T13:00:00Z"
|
||||||
|
, makeWindow "search-rollout" "2026-05-05T15:00:00Z" "2026-05-05T16:30:00Z"
|
||||||
|
]
|
||||||
|
|
||||||
|
parseInstant :: String -> Either String UTCTime
|
||||||
|
parseInstant rawInstant =
|
||||||
|
case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" rawInstant of
|
||||||
|
Just parsedInstant -> Right parsedInstant
|
||||||
|
Nothing -> Left ("invalid UTC timestamp: " ++ rawInstant)
|
||||||
|
|
||||||
|
statusAt :: UTCTime -> [MaintenanceWindow] -> WindowStatus
|
||||||
|
statusAt currentInstant windows =
|
||||||
|
let orderedWindows = sortOn windowStart windows
|
||||||
|
in case find (contains currentInstant) orderedWindows of
|
||||||
|
Just activeWindow -> Active activeWindow (diffUTCTime (windowEnd activeWindow) currentInstant)
|
||||||
|
Nothing ->
|
||||||
|
case find (\window -> windowStart window > currentInstant) orderedWindows of
|
||||||
|
Just nextWindow -> Waiting nextWindow (diffUTCTime (windowStart nextWindow) currentInstant)
|
||||||
|
Nothing -> NoMoreWindows
|
||||||
|
|
||||||
|
renderStatus :: WindowStatus -> String
|
||||||
|
renderStatus (Active activeWindow remainingTime) =
|
||||||
|
"active "
|
||||||
|
++ windowName activeWindow
|
||||||
|
++ " for "
|
||||||
|
++ renderMinutes remainingTime
|
||||||
|
++ " more"
|
||||||
|
renderStatus (Waiting nextWindow delay) =
|
||||||
|
"next "
|
||||||
|
++ windowName nextWindow
|
||||||
|
++ " starts in "
|
||||||
|
++ renderMinutes delay
|
||||||
|
renderStatus NoMoreWindows = "no more maintenance windows"
|
||||||
|
|
||||||
|
formatInstant :: UTCTime -> String
|
||||||
|
formatInstant = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"
|
||||||
|
|
||||||
|
contains :: UTCTime -> MaintenanceWindow -> Bool
|
||||||
|
contains currentInstant window =
|
||||||
|
windowStart window <= currentInstant && currentInstant < windowEnd window
|
||||||
|
|
||||||
|
renderMinutes :: NominalDiffTime -> String
|
||||||
|
renderMinutes duration = show (floor (duration / 60) :: Integer) ++ "m"
|
||||||
|
|
||||||
|
makeWindow :: String -> String -> String -> MaintenanceWindow
|
||||||
|
makeWindow name rawStart rawEnd =
|
||||||
|
MaintenanceWindow
|
||||||
|
{ windowName = name
|
||||||
|
, windowStart = mustParse rawStart
|
||||||
|
, windowEnd = mustParse rawEnd
|
||||||
|
}
|
||||||
|
|
||||||
|
mustParse :: String -> UTCTime
|
||||||
|
mustParse rawInstant =
|
||||||
|
case parseInstant rawInstant of
|
||||||
|
Right parsedInstant -> parsedInstant
|
||||||
|
Left err -> error err
|
||||||
40
45-haskell-time-windows/test/Main.hs
Normal file
40
45-haskell-time-windows/test/Main.hs
Normal file
@ -0,0 +1,40 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import Data.Time (secondsToNominalDiffTime)
|
||||||
|
import MiniTimeWindows.Window
|
||||||
|
( WindowStatus (Active, NoMoreWindows, Waiting)
|
||||||
|
, parseInstant
|
||||||
|
, renderStatus
|
||||||
|
, sampleWindows
|
||||||
|
, statusAt
|
||||||
|
)
|
||||||
|
import System.Exit (die)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main =
|
||||||
|
case
|
||||||
|
( parseInstant "2026-05-05T10:30:00Z"
|
||||||
|
, parseInstant "2026-05-05T11:45:00Z"
|
||||||
|
, parseInstant "2026-05-05T17:00:00Z"
|
||||||
|
, parseInstant "not-a-time"
|
||||||
|
) of
|
||||||
|
( Right activeInstant
|
||||||
|
, Right waitingInstant
|
||||||
|
, Right finishedInstant
|
||||||
|
, Left _
|
||||||
|
) ->
|
||||||
|
case
|
||||||
|
( statusAt activeInstant sampleWindows
|
||||||
|
, statusAt waitingInstant sampleWindows
|
||||||
|
, statusAt finishedInstant sampleWindows
|
||||||
|
) of
|
||||||
|
( Active activeWindow remainingTime
|
||||||
|
, Waiting waitingWindow delay
|
||||||
|
, NoMoreWindows
|
||||||
|
) | renderStatus (Active activeWindow remainingTime) == "active schema-migration for 30m more"
|
||||||
|
&& renderStatus (Waiting waitingWindow delay) == "next billing-freeze starts in 45m"
|
||||||
|
&& remainingTime == secondsToNominalDiffTime 1800
|
||||||
|
&& delay == secondsToNominalDiffTime 2700 ->
|
||||||
|
putStrLn "test passed"
|
||||||
|
_ -> die "unexpected Data.Time status result"
|
||||||
|
_ -> die "unexpected Data.Time parse result"
|
||||||
@ -30,6 +30,9 @@ This note links the Haskell examples in a suggested order from first project str
|
|||||||
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`
|
23. `37-haskell-transformer-stack/`: composed effects with `ReaderT`, `ExceptT`, and `Writer`
|
||||||
24. `38-haskell-generic-json/`: generic JSON instances with Aeson options
|
24. `38-haskell-generic-json/`: generic JSON instances with Aeson options
|
||||||
|
25. `43-haskell-tree-rollouts/`: hierarchical rollout plans with `Data.Tree`
|
||||||
|
26. `44-haskell-seq-queues/`: FIFO retry batching with `Data.Sequence`
|
||||||
|
27. `45-haskell-time-windows/`: UTC maintenance-window status with `Data.Time`
|
||||||
|
|
||||||
---
|
---
|
||||||
|
|
||||||
@ -59,6 +62,9 @@ This note links the Haskell examples in a suggested order from first project str
|
|||||||
- `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
|
- `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
|
- `38-haskell-generic-json/`: how to reduce JSON boilerplate without giving up a deliberate shape
|
||||||
|
- `43-haskell-tree-rollouts/`: how to model a rollout hierarchy and derive root-to-leaf paths from it
|
||||||
|
- `44-haskell-seq-queues/`: how to represent FIFO work queues with front-removal and back-append operations
|
||||||
|
- `45-haskell-time-windows/`: how to parse UTC timestamps and classify active versus future windows
|
||||||
|
|
||||||
---
|
---
|
||||||
|
|
||||||
@ -88,3 +94,6 @@ This note links the Haskell examples in a suggested order from first project str
|
|||||||
- `notes/039-haskell-map-set-modeling.md`
|
- `notes/039-haskell-map-set-modeling.md`
|
||||||
- `notes/040-haskell-transformer-stack.md`
|
- `notes/040-haskell-transformer-stack.md`
|
||||||
- `notes/041-haskell-generic-json.md`
|
- `notes/041-haskell-generic-json.md`
|
||||||
|
- `notes/046-haskell-tree-rollouts.md`
|
||||||
|
- `notes/047-haskell-seq-queues.md`
|
||||||
|
- `notes/048-haskell-time-windows.md`
|
||||||
|
|||||||
57
notes/046-haskell-tree-rollouts.md
Normal file
57
notes/046-haskell-tree-rollouts.md
Normal file
@ -0,0 +1,57 @@
|
|||||||
|
# Haskell Tree Rollouts
|
||||||
|
|
||||||
|
This note covers `43-haskell-tree-rollouts/`, which uses `Data.Tree` to model a rollout plan as a real hierarchy instead of as a flat list.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 1. Why a Tree Fits This Domain
|
||||||
|
|
||||||
|
Some rollout structures are naturally nested:
|
||||||
|
|
||||||
|
- one release at the root,
|
||||||
|
- one environment branch under that release, and
|
||||||
|
- one or more service leaves under each environment.
|
||||||
|
|
||||||
|
That is exactly what `Tree a` expresses. Each node has one value plus zero or more child nodes.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 2. What the Example Computes from the Tree
|
||||||
|
|
||||||
|
The example does two different things with the same `samplePlan`:
|
||||||
|
|
||||||
|
- `renderPlan` turns the hierarchy into an indented ASCII tree, and
|
||||||
|
- `deploymentPaths` turns each root-to-leaf path into an ordered rollout path.
|
||||||
|
|
||||||
|
That contrast is the main teaching point. One tree can support both human-readable structure and programmatic traversal.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 3. Why the Test Checks Paths, Not Just Pretty Output
|
||||||
|
|
||||||
|
The important behavior is not the ASCII drawing by itself. It is the fact that the traversal preserves parent context.
|
||||||
|
|
||||||
|
That is why the test checks strings such as:
|
||||||
|
|
||||||
|
- `checkout-release -> staging -> api`, and
|
||||||
|
- `checkout-release -> production -> billing`.
|
||||||
|
|
||||||
|
Those paths prove the example is walking the tree shape correctly.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 4. Commands to Try
|
||||||
|
|
||||||
|
```bash
|
||||||
|
cd 43-haskell-tree-rollouts
|
||||||
|
|
||||||
|
nix develop
|
||||||
|
cabal run
|
||||||
|
cabal test
|
||||||
|
|
||||||
|
nix build
|
||||||
|
./result/bin/mini-tree-rollouts
|
||||||
|
|
||||||
|
nix run
|
||||||
|
nix flake check
|
||||||
|
```
|
||||||
60
notes/047-haskell-seq-queues.md
Normal file
60
notes/047-haskell-seq-queues.md
Normal file
@ -0,0 +1,60 @@
|
|||||||
|
# Haskell Seq Queues
|
||||||
|
|
||||||
|
This note covers `44-haskell-seq-queues/`, which uses `Data.Sequence` as a queue for retry work.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 1. Why `Seq` Instead of a Plain List
|
||||||
|
|
||||||
|
Lists are excellent for recursive processing, but queues want efficient work at both ends:
|
||||||
|
|
||||||
|
- append new retries to the back, and
|
||||||
|
- take the next retry from the front.
|
||||||
|
|
||||||
|
`Data.Sequence` provides those operations directly, so the example can talk about queue behavior without building a custom data structure first.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 2. What the Example Demonstrates
|
||||||
|
|
||||||
|
The queue starts with four retries, then appends one more with `enqueueRetry`.
|
||||||
|
|
||||||
|
After that, `takeBatch` removes the next `n` items in FIFO order and returns:
|
||||||
|
|
||||||
|
- the batch to execute now, and
|
||||||
|
- the remaining queue for later.
|
||||||
|
|
||||||
|
That keeps the example focused on the queue contract, not on concurrency or backoff policy.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 3. Why the Test Uses Rendered Queue State
|
||||||
|
|
||||||
|
The test checks:
|
||||||
|
|
||||||
|
- `api#2, worker#1` as the next batch, and
|
||||||
|
- `billing#3, search#1, auth#1` as the remaining queue.
|
||||||
|
|
||||||
|
That is enough to prove both important properties:
|
||||||
|
|
||||||
|
- newly enqueued work goes to the back, and
|
||||||
|
- batch selection keeps the original front-to-back order.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 4. Commands to Try
|
||||||
|
|
||||||
|
```bash
|
||||||
|
cd 44-haskell-seq-queues
|
||||||
|
|
||||||
|
nix develop
|
||||||
|
cabal run
|
||||||
|
cabal run -- 3
|
||||||
|
cabal test
|
||||||
|
|
||||||
|
nix build
|
||||||
|
./result/bin/mini-seq-queues 3
|
||||||
|
|
||||||
|
nix run . -- 3
|
||||||
|
nix flake check
|
||||||
|
```
|
||||||
59
notes/048-haskell-time-windows.md
Normal file
59
notes/048-haskell-time-windows.md
Normal file
@ -0,0 +1,59 @@
|
|||||||
|
# Haskell Time Windows
|
||||||
|
|
||||||
|
This note covers `45-haskell-time-windows/`, which uses `Data.Time` to parse UTC timestamps and classify maintenance windows.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 1. Why This Exists Next to the QuickCheck Window Example
|
||||||
|
|
||||||
|
`26-haskell-quickcheck/` works with abstract intervals and normalization rules.
|
||||||
|
|
||||||
|
This example teaches a different concern:
|
||||||
|
|
||||||
|
- parsing real UTC timestamps,
|
||||||
|
- comparing them against concrete windows, and
|
||||||
|
- rendering the resulting status in terms people would actually read.
|
||||||
|
|
||||||
|
The shared domain is intentional, but the concept is different.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 2. What the Status Function Returns
|
||||||
|
|
||||||
|
`statusAt` sorts the windows by start time, then returns one of three cases:
|
||||||
|
|
||||||
|
- `Active`, with the remaining time in the current window,
|
||||||
|
- `Waiting`, with the delay until the next window starts, or
|
||||||
|
- `NoMoreWindows`.
|
||||||
|
|
||||||
|
That is the useful pattern to remember. Time logic often becomes easier to explain once the raw comparison result is turned into a small sum type.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 3. Why the Test Checks Exact Delays
|
||||||
|
|
||||||
|
The test does not stop at string formatting. It also checks exact `NominalDiffTime` values:
|
||||||
|
|
||||||
|
- `1800` seconds for an active window with 30 minutes left, and
|
||||||
|
- `2700` seconds for a future window starting in 45 minutes.
|
||||||
|
|
||||||
|
That matters because time code can render the right words while still comparing the wrong timestamps underneath.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 4. Commands to Try
|
||||||
|
|
||||||
|
```bash
|
||||||
|
cd 45-haskell-time-windows
|
||||||
|
|
||||||
|
nix develop
|
||||||
|
cabal run
|
||||||
|
cabal run -- 2026-05-05T11:45:00Z
|
||||||
|
cabal test
|
||||||
|
|
||||||
|
nix build
|
||||||
|
./result/bin/mini-time-windows 2026-05-05T11:45:00Z
|
||||||
|
|
||||||
|
nix run . -- 2026-05-05T11:45:00Z
|
||||||
|
nix flake check
|
||||||
|
```
|
||||||
Loading…
x
Reference in New Issue
Block a user