patrick/raft-fable
1
0
Fork 0
Code Issues Pull Requests Packages Releases Activity

Fable app

Browse Source
This commit is contained in:
Smaug123
2022-10-29 14:46:56 +01:00
parent c3f411cdda
commit 4f7ccedfd6
13 changed files with 5900 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@@ -8,3 +8,5 @@ riderModule.iml
*.DotSettings
# Fable output
*.fs.js
node_modules/
.profile*

6
Raft.sln
View File

@@ -6,6 +6,8 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Raft.Test", "Raft.Test\Raft
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "RaftExplorer", "RaftExplorer\RaftExplorer.fsproj", "{204FDA9A-F3B7-46CC-97F1-A39B55AA7A7A}"
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "RaftFable", "RaftFable\src\RaftFable.fsproj", "{0A68B09E-3BE3-42AB-A741-F65EED775D5A}"
EndProject
Global
GlobalSection(SolutionConfigurationPlatforms) = preSolution
Debug|Any CPU = Debug|Any CPU
@@ -24,5 +26,9 @@ Global
{204FDA9A-F3B7-46CC-97F1-A39B55AA7A7A}.Debug|Any CPU.Build.0 = Debug|Any CPU
{204FDA9A-F3B7-46CC-97F1-A39B55AA7A7A}.Release|Any CPU.ActiveCfg = Release|Any CPU
{204FDA9A-F3B7-46CC-97F1-A39B55AA7A7A}.Release|Any CPU.Build.0 = Release|Any CPU
{0A68B09E-3BE3-42AB-A741-F65EED775D5A}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{0A68B09E-3BE3-42AB-A741-F65EED775D5A}.Debug|Any CPU.Build.0 = Debug|Any CPU
{0A68B09E-3BE3-42AB-A741-F65EED775D5A}.Release|Any CPU.ActiveCfg = Release|Any CPU
{0A68B09E-3BE3-42AB-A741-F65EED775D5A}.Release|Any CPU.Build.0 = Release|Any CPU
EndGlobalSection
EndGlobal

7
Raft/InMemory.fs
View File

@@ -85,16 +85,17 @@ module InMemoryCluster =
cluster, network
type NetworkAction =
type NetworkAction<'a> =
| InactivityTimeout of int<ServerId>
| NetworkMessage of int<ServerId> * int
| DropMessage of int<ServerId> * int
| ClientRequest of int<ServerId> * 'a * (ClientReply -> unit)
| Heartbeat of int<ServerId>
[<RequireQualifiedAccess>]
module NetworkAction =
let perform<'a> (cluster : Cluster<'a>) (network : Network<'a>) (action : NetworkAction) : unit =
let perform<'a> (cluster : Cluster<'a>) (network : Network<'a>) (action : NetworkAction<'a>) : unit =
match action with
| InactivityTimeout serverId -> cluster.InactivityTimeout serverId
| Heartbeat serverId -> cluster.HeartbeatTimeout serverId
@@ -102,3 +103,5 @@ module NetworkAction =
| NetworkMessage (serverId, messageId) ->
network.InboundMessage serverId messageId |> cluster.SendMessage serverId
network.DropMessage serverId messageId
| ClientRequest (server, request, replyChannel) ->
Message.ClientRequest (request, replyChannel) |> cluster.SendMessage server

52
Raft/Server.fs
View File

@@ -115,6 +115,21 @@ type AppendEntriesMessage<'a> =
this.LeaderTerm
this.LeaderCommitIndex
type ClientReply =
/// You asked a node that isn't the leader. Here's a hint about whom you should ask instead.
/// The hint may not be accurate even as of the time when we reply, and certainly it may not be
/// accurate as of the time *you* receive this message.
/// (Note also that an unreliable network could in principle deliver your original request
/// again at some point, so this is not a guarantee that your message will never be committed.)
| Redirect of int<ServerId> option
/// The cluster was not in a good enough state to process your request at this time.
/// (Note, though, that an unreliable network could in principle mean that your
/// original request gets delivered again at some point, so this is not a guarantee
/// that your message will never be committed.)
| Dropped
/// The cluster acknowledges your request. At some future time, it may be committed.
| Acknowledged
type Instruction<'a> =
| AppendEntries of AppendEntriesMessage<'a>
| RequestVote of RequestVoteMessage
@@ -141,11 +156,13 @@ type Reply =
type Message<'a> =
| Instruction of Instruction<'a>
| Reply of Reply
| ClientRequest of 'a * (ClientReply -> unit)
override this.ToString () =
match this with
| Instruction i -> i.ToString ()
| Reply r -> r.ToString ()
| ClientRequest (a, _) -> sprintf "Client requested insertion of: %O" a
type private CandidateState =
{
@@ -185,25 +202,9 @@ type ServerStatus =
| Candidate term -> sprintf "Candidate in term %i" term
| Follower -> "Follower"
type ClientReply =
/// You asked a node that isn't the leader. Here's a hint about whom you should ask instead.
/// The hint may not be accurate even as of the time when we reply, and certainly it may not be
/// accurate as of the time *you* receive this message.
/// (Note also that an unreliable network could in principle deliver your original request
/// again at some point, so this is not a guarantee that your message will never be committed.)
| Redirect of int<ServerId> option
/// The cluster was not in a good enough state to process your request at this time.
/// (Note, though, that an unreliable network could in principle mean that your
/// original request gets delivered again at some point, so this is not a guarantee
/// that your message will never be committed.)
| Dropped
/// The cluster acknowledges your request. At some future time, it may be committed.
| Acknowledged
type private ServerAction<'a> =
| BeginElection
| EmitHeartbeat
| ClientRequest of 'a * (ClientReply -> unit)
| Receive of Message<'a>
| Sync of AsyncReplyChannel<unit>
@@ -562,14 +563,6 @@ type Server<'a>
match m with
| ServerAction.EmitHeartbeat -> emitHeartbeat ()
| ServerAction.ClientRequest (toAdd, replyChannel) ->
match currentType with
| ServerSpecialisation.Leader _ ->
persistentState.AppendToLog toAdd persistentState.CurrentTerm
replyChannel ClientReply.Acknowledged
| ServerSpecialisation.Follower followerState ->
replyChannel (ClientReply.Redirect followerState.CurrentLeader)
| ServerSpecialisation.Candidate _ -> replyChannel ClientReply.Dropped
| ServerAction.BeginElection ->
match currentType with
| ServerSpecialisation.Leader _ -> ()
@@ -594,6 +587,14 @@ type Server<'a>
|> messageChannel (i * 1<ServerId>)
| ServerAction.Receive (Instruction m) -> processMessage m
| ServerAction.Receive (Reply r) -> processReply r
| ServerAction.Receive (Message.ClientRequest (toAdd, replyChannel)) ->
match currentType with
| ServerSpecialisation.Leader _ ->
persistentState.AppendToLog toAdd persistentState.CurrentTerm
replyChannel ClientReply.Acknowledged
| ServerSpecialisation.Follower followerState ->
replyChannel (ClientReply.Redirect followerState.CurrentLeader)
| ServerSpecialisation.Candidate _ -> replyChannel ClientReply.Dropped
| ServerAction.Sync replyChannel -> replyChannel.Reply ()
return! loop mailbox
@@ -605,6 +606,9 @@ type Server<'a>
#endif
mailbox
member this.SendClientRequest (request : 'a) (reply : ClientReply -> unit) =
mailbox.Post (ServerAction.Receive (Message.ClientRequest (request, reply)))
member this.TriggerInactivityTimeout () = mailbox.Post ServerAction.BeginElection
member this.TriggerHeartbeatTimeout () = mailbox.Post ServerAction.EmitHeartbeat

5363
RaftFable/package-lock.json generated Normal file
View File

File diff suppressed because it is too large Load Diff

14
RaftFable/package.json Normal file
View File

@@ -0,0 +1,14 @@
{
"private": true,
"scripts": {
"postinstall": "dotnet tool restore",
"start": "dotnet fable watch src --run webpack-dev-server",
"build": "dotnet fable src && webpack"
},
"devDependencies": {
"webpack": "^4.46.0",
"webpack-cli": "^3.3.0",
"webpack-dev-server": "^3.11.2"
},
"version": "1.0.0"
}

17
RaftFable/public/index.html Normal file
View File

@@ -0,0 +1,17 @@
<!doctype html>
<html>
<head>
<title>Fable</title>
<meta http-equiv='Content-Type' content='text/html; charset=utf-8'>
<meta name="viewport" content="width=device-width, initial-scale=1">
</head>
<body>
<table class="server-statuses">
</table>
<p class="startup-text">Fable is running</p>
<button class="timeout-button">Inactivity timeout server:</button> <input type="number" class="timeout-text" />
<button class="heartbeat-button">Heartbeat server:</button> <input type="number" class="heartbeat-text" />
<table class="button-area"></table>
<script src="bundle.js"></script>
</body>
</html>

286
RaftFable/src/App.fs Normal file
View File

@@ -0,0 +1,286 @@
module App
open System
open Fable.Core.JS
open Raft
open Browser.Dom
let clusterSize = 5
let serverStatuses =
document.querySelector ".server-statuses" :?> Browser.Types.HTMLTableElement
serverStatuses.border <- "1px"
do
let row = document.createElement "tr" :?> Browser.Types.HTMLTableRowElement
let serverHeading =
document.createElement "th" :?> Browser.Types.HTMLTableCellElement
let statusHeading =
document.createElement "th" :?> Browser.Types.HTMLTableCellElement
serverHeading.textContent <- "Server"
statusHeading.textContent <- "Status"
row.appendChild (serverHeading) |> ignore
row.appendChild (statusHeading) |> ignore
serverStatuses.appendChild row |> ignore
let serverStatusNodes =
fun i ->
let node = document.createElement "tr" :?> Browser.Types.HTMLTableRowElement
let child = document.createElement "td" :?> Browser.Types.HTMLTableCellElement
let statusCell = document.createElement "td" :?> Browser.Types.HTMLTableCellElement
child.textContent <- sprintf "%i" i
node.appendChild (child) |> ignore
node.appendChild (statusCell) |> ignore
serverStatuses.appendChild node |> ignore
statusCell
|> List.init clusterSize
let messageQueueArea =
document.querySelector ".button-area" :?> Browser.Types.HTMLTableElement
messageQueueArea.border <- "1px"
let resetButtonArea () =
messageQueueArea.innerText <- ""
let headerRow = document.createElement "tr" :?> Browser.Types.HTMLTableRowElement
for i in 0 .. clusterSize - 1 do
let heading = document.createElement "th" :?> Browser.Types.HTMLTableCellElement
heading.innerText <- sprintf "Server %i" i
headerRow.appendChild (heading) |> ignore
messageQueueArea.appendChild headerRow |> ignore
resetButtonArea ()
let createButton (text : string) (onClick : Browser.Types.HTMLButtonElement -> unit) =
let node = document.createElement "button" :?> Browser.Types.HTMLButtonElement
node.textContent <- text
node.onclick <- fun _ -> onClick node
node
let printClusterState<'a> (cluster : Cluster<'a>) : unit =
for i in 0 .. cluster.ClusterSize - 1 do
serverStatusNodes.[i].textContent <- cluster.State (i * 1<ServerId>) |> string<ServerStatus>
let cluster, network = InMemoryCluster.make<int> clusterSize
let performWithoutPrintingNetworkState action =
NetworkAction.perform cluster network action
printClusterState cluster
let rec printNetworkState<'a> (network : Network<'a>) : unit =
resetButtonArea ()
let allButtons =
[ 0 .. network.ClusterSize - 1 ]
|> List.map (fun i ->
let i = i * 1<ServerId>
network.UndeliveredMessages i
|> List.map (fun (messageId, message) ->
createButton
(sprintf "Server %i, message %i: %O" i messageId message)
(fun button ->
button.remove ()
NetworkMessage (i, messageId) |> performWithoutPrintingNetworkState
printNetworkState network
)
)
)
let maxQueueLength = allButtons |> Seq.map List.length |> Seq.max
let allButtons' =
allButtons
|> List.map (fun l -> List.append (List.map Some l) (List.replicate (maxQueueLength - List.length l) None))
|> List.transpose
for row in allButtons' do
let cellRow = document.createElement "tr" :?> Browser.Types.HTMLTableRowElement
for col in row do
let entry = document.createElement "td" :?> Browser.Types.HTMLTableCellElement
match col with
| None -> ()
| Some button -> entry.appendChild button |> ignore
cellRow.appendChild entry |> ignore
messageQueueArea.appendChild cellRow |> ignore
let perform action =
performWithoutPrintingNetworkState action
printNetworkState network
let getMessage (clusterSize : int) (s : string) : (int<ServerId> * int) option =
match s.Split ',' with
| [| serverId ; messageId |] ->
let serverId = serverId.Trim ()
let messageId = messageId.Trim ()
match Int32.TryParse serverId with
| true, serverId ->
match Int32.TryParse messageId with
| true, messageId ->
if serverId >= clusterSize || serverId < 0 then
printf "Server ID must be between 0 and %i inclusive. " (clusterSize - 1)
None
else
Some (serverId * 1<ServerId>, messageId)
| false, _ ->
printf "Non-integer input '%s' for message ID. " messageId
None
| false, _ ->
printf "Non-integer input '%s' for server ID. " serverId
None
| _ ->
printfn "Invalid input."
None
let rec getHeartbeater (clusterSize : int) (serverId : string) =
// TODO: restrict this to the leaders only
match Int32.TryParse serverId with
| true, serverId ->
if serverId >= clusterSize || serverId < 0 then
printf "Server ID must be between 0 and %i inclusive. " (clusterSize - 1)
None
else
Some (serverId * 1<ServerId>)
| false, _ ->
printf "Unrecognised input. "
None
(*
let rec getAction (clusterSize : int) =
printf
"Enter action. Trigger [t]imeout <server id>, [h]eartbeat a leader <server id>, [d]rop message <server id, message id>, or allow [m]essage <server id, message id>: "
let s =
let rec go () =
let s = Console.ReadLine().ToUpperInvariant ()
if String.IsNullOrEmpty s then go () else s
go ()
match s.[0] with
| 'T' ->
match getTimeout clusterSize s.[1..] with
| Some t -> t |> InactivityTimeout
| None -> getAction clusterSize
| 'D' ->
match getMessage clusterSize s.[1..] with
| Some m -> m |> DropMessage
| None -> getAction clusterSize
| 'M' ->
match getMessage clusterSize s.[1..] with
| Some m -> m |> NetworkMessage
| None -> getAction clusterSize
| 'H' ->
match getHeartbeater clusterSize s.[1..] with
| Some h -> Heartbeat h
| None -> getAction clusterSize
| _ ->
printf "Unrecognised input. "
getAction clusterSize
*)
let startupText =
document.querySelector (".startup-text") :?> Browser.Types.HTMLParagraphElement
startupText.textContent <- "Starting up..."
let startupSequence =
[
NetworkAction.InactivityTimeout 0<ServerId>
NetworkAction.InactivityTimeout 1<ServerId>
// Two servers vote for server 1...
NetworkAction.NetworkMessage (2<ServerId>, 1)
NetworkAction.NetworkMessage (3<ServerId>, 1)
// One server votes for server 0...
NetworkAction.NetworkMessage (4<ServerId>, 0)
// and the other votes are processed and discarded
NetworkAction.NetworkMessage (0<ServerId>, 0)
NetworkAction.NetworkMessage (1<ServerId>, 0)
NetworkAction.NetworkMessage (2<ServerId>, 0)
NetworkAction.NetworkMessage (3<ServerId>, 0)
NetworkAction.NetworkMessage (4<ServerId>, 1)
// Server 0 process incoming votes
NetworkAction.NetworkMessage (0<ServerId>, 1)
// Server 1 processes incoming votes, and achieves majority, electing itself leader!
NetworkAction.NetworkMessage (1<ServerId>, 1)
NetworkAction.NetworkMessage (1<ServerId>, 2)
// Get the followers' heartbeat processing out of the way
NetworkAction.NetworkMessage (2<ServerId>, 2)
NetworkAction.NetworkMessage (3<ServerId>, 2)
NetworkAction.NetworkMessage (4<ServerId>, 2)
NetworkAction.NetworkMessage (1<ServerId>, 3)
NetworkAction.NetworkMessage (1<ServerId>, 4)
NetworkAction.NetworkMessage (1<ServerId>, 5)
// Server 0 processes the leader's heartbeat and drops out of the election.
NetworkAction.NetworkMessage (0<ServerId>, 2)
NetworkAction.NetworkMessage (1<ServerId>, 6)
]
|> fun s -> (Constructors.Promise.resolve (printClusterState cluster), s)
||> List.fold (fun (inPromise : Promise<unit>) action -> inPromise.``then`` (fun () -> perform action))
|> fun p -> p.``then`` (fun () -> startupText.textContent <- "Started! Press buttons.")
let timeoutButton =
document.querySelector (".timeout-button") :?> Browser.Types.HTMLButtonElement
let timeoutField =
document.querySelector (".timeout-text") :?> Browser.Types.HTMLInputElement
timeoutField.max <- string<int> (clusterSize - 1)
timeoutField.min <- "0"
timeoutButton.onclick <-
fun evt ->
startupSequence.``then`` (fun () ->
timeoutField.valueAsNumber
|> int
|> fun i -> i * 1<ServerId>
|> InactivityTimeout
|> perform
printNetworkState network
)
let heartbeatButton =
document.querySelector (".heartbeat-button") :?> Browser.Types.HTMLButtonElement
let heartbeatField =
document.querySelector (".heartbeat-text") :?> Browser.Types.HTMLInputElement
heartbeatField.max <- string<int> (clusterSize - 1)
heartbeatField.min <- "0"
heartbeatButton.onclick <-
fun evt ->
startupSequence.``then`` (fun () ->
heartbeatField.valueAsNumber
|> int
|> fun i -> i * 1<ServerId>
|> Heartbeat
|> perform
printNetworkState network
)
//let electLeader =
// [
// NetworkAction.InactivityTimeout 0<ServerId>
// NetworkAction.NetworkMessage (1<ServerId>, 0)
// NetworkAction.NetworkMessage (2<ServerId>, 0)
// NetworkAction.DropMessage (3<ServerId>, 0)
// NetworkAction.DropMessage (4<ServerId>, 0)
// NetworkAction.NetworkMessage (0<ServerId>, 0)
// NetworkAction.NetworkMessage (0<ServerId>, 1)
// // At this point, server 0 is leader in an uncontested election.
// ]

16
RaftFable/src/RaftFable.fsproj Normal file
View File

@@ -0,0 +1,16 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>net6.0</TargetFramework>
</PropertyGroup>
<ItemGroup>
<Compile Include="App.fs" />
</ItemGroup>
<ItemGroup>
<PackageReference Include="Fable.Browser.Dom" Version="2.2.0" />
<PackageReference Include="Fable.Core" Version="3.7.1" />
<PackageReference Include="Fable.Promise" Version="3.2.0" />
</ItemGroup>
<ItemGroup>
<ProjectReference Include="..\..\Raft\Raft.fsproj" />
</ItemGroup>
</Project>

21
RaftFable/webpack.config.js Normal file
View File

@@ -0,0 +1,21 @@
// Note this only includes basic configuration for development mode.
// For a more comprehensive configuration check:
// https://github.com/fable-compiler/webpack-config-template
var path = require("path");
module.exports = {
mode: "development",
entry: "./src/App.fs.js",
output: {
path: path.join(__dirname, "./public"),
filename: "bundle.js",
},
devServer: {
publicPath: "/",
contentBase: "./public",
port: 8080,
},
module: {
}
}

12
dotnet-tools.json
View File

@@ -7,6 +7,18 @@
"commands": [
"fantomas"
]
},
"fable": {
"version": "3.2.9",
"commands": [
"fable"
]
},
"femto": {
"version": "0.12.0",
"commands": [
"femto"
]
}
}
}

105
flake.lock generated Normal file
View File

@@ -0,0 +1,105 @@
{
"nodes": {
"alejandra": {
"inputs": {
"fenix": "fenix",
"flakeCompat": "flakeCompat",
"nixpkgs": [
"nixpkgs"
]
},
"locked": {
"lastModified": 1660510326,
"narHash": "sha256-xFumnivtVwu5fFBOrTxrv6fv3geHKF04RGP23EsDVaI=",
"owner": "kamadorueda",
"repo": "alejandra",
"rev": "ef03f7ef74ec97fd91a016a51c9c9667fb315652",
"type": "github"
},
"original": {
"owner": "kamadorueda",
"ref": "3.0.0",
"repo": "alejandra",
"type": "github"
}
},
"fenix": {
"inputs": {
"nixpkgs": [
"alejandra",
"nixpkgs"
],
"rust-analyzer-src": "rust-analyzer-src"
},
"locked": {
"lastModified": 1657607339,
"narHash": "sha256-HaqoAwlbVVZH2n4P3jN2FFPMpVuhxDy1poNOR7kzODc=",
"owner": "nix-community",
"repo": "fenix",
"rev": "b814c83d9e6aa5a28d0cf356ecfdafb2505ad37d",
"type": "github"
},
"original": {
"owner": "nix-community",
"repo": "fenix",
"type": "github"
}
},
"flakeCompat": {
"flake": false,
"locked": {
"lastModified": 1650374568,
"narHash": "sha256-Z+s0J8/r907g149rllvwhb4pKi8Wam5ij0st8PwAh+E=",
"owner": "edolstra",
"repo": "flake-compat",
"rev": "b4a34015c698c7793d592d66adbab377907a2be8",
"type": "github"
},
"original": {
"owner": "edolstra",
"repo": "flake-compat",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1666955682,
"narHash": "sha256-/6mn8QquERtjLsIyClyFQ6UYjttk8OXOjKGM3I/NYvU=",
"owner": "nixos",
"repo": "nixpkgs",
"rev": "3453f5713ad1c79c4ae10671dcaf30241b102249",
"type": "github"
},
"original": {
"owner": "nixos",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"alejandra": "alejandra",
"nixpkgs": "nixpkgs"
}
},
"rust-analyzer-src": {
"flake": false,
"locked": {
"lastModified": 1657557289,
"narHash": "sha256-PRW+nUwuqNTRAEa83SfX+7g+g8nQ+2MMbasQ9nt6+UM=",
"owner": "rust-lang",
"repo": "rust-analyzer",
"rev": "caf23f29144b371035b864a1017dbc32573ad56d",
"type": "github"
},
"original": {
"owner": "rust-lang",
"ref": "nightly",
"repo": "rust-analyzer",
"type": "github"
}
}
},
"root": "root",
"version": 7
}

25
flake.nix Normal file
View File

@@ -0,0 +1,25 @@
{
inputs = {
nixpkgs.url = "github:nixos/nixpkgs";
alejandra = {
inputs.nixpkgs.follows = "nixpkgs";
url = "github:kamadorueda/alejandra/3.0.0";
};
};
outputs = inputs @ {
self,
nixpkgs,
alejandra,
...
}: {
devShell.aarch64-darwin = let
system = "aarch64-darwin";
in let
pkgs = nixpkgs.legacyPackages.aarch64-darwin;
in
pkgs.mkShell {
buildInputs = [alejandra.defaultPackage.aarch64-darwin pkgs.nodejs-14_x pkgs.dotnet-sdk_6 pkgs.darwin.apple_sdk.frameworks.CoreServices];
};
};
}