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

Add client data to Fable UI

Browse Source
This commit is contained in:
Smaug123
2022-10-30 09:44:06 +00:00
parent 969a51b6d2
commit 3ece92e753
5 changed files with 222 additions and 200 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
RaftFable/public/index.html
View File

@@ -1,5 +1,5 @@
<!doctype html>
<html>
<html lang="en">
<head>
<title>Fable</title>
<meta http-equiv='Content-Type' content='text/html; charset=utf-8'>
@@ -9,8 +9,21 @@
<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" />
<form>
<input type="number" class="timeout-text" />
<button id="timeout-button" class="timeout-button" type="button">Inactivity timeout server</button>
</form>
<form>
<input type="number" class="heartbeat-text" />
<button class="heartbeat-button" type="button">Heartbeat server</button>
</form>
<form>
<label for="client-server-selection">Server to send to</label>
<input type="number" id="client-server-selection" class="client-server-selection" />
<label for="client-data">Data to send</label>
<input type="number" id="client-data" class="client-data" />
<button class="client-data-submit" type="button">Submit client data</button>
</form>
<table class="button-area"></table>
<script src="bundle.js"></script>
</body>

354
RaftFable/src/App.fs
View File

@@ -1,239 +1,199 @@
module App
namespace RaftFable
open System
open Fable.Core.JS
open Raft
open Browser.Dom
let clusterSize = 5
module App =
let serverStatuses =
document.querySelector ".server-statuses" :?> Browser.Types.HTMLTableElement
let clusterSize = 5
serverStatuses.border <- "1px"
let serverStatuses =
document.querySelector ".server-statuses" :?> Browser.Types.HTMLTableElement
do
let row = document.createElement "tr" :?> Browser.Types.HTMLTableRowElement
serverStatuses.border <- "1px"
Table.createHeaderRow document [ "Server" ; "Status" ] serverStatuses
let serverHeading =
document.createElement "th" :?> Browser.Types.HTMLTableCellElement
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 statusHeading =
document.createElement "th" :?> Browser.Types.HTMLTableCellElement
let messageQueueArea =
document.querySelector ".button-area" :?> Browser.Types.HTMLTableElement
serverHeading.textContent <- "Server"
statusHeading.textContent <- "Status"
row.appendChild serverHeading |> ignore
row.appendChild statusHeading |> ignore
serverStatuses.appendChild row |> ignore
messageQueueArea.border <- "1px"
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 resetButtonArea () =
messageQueueArea.innerText <- ""
let messageQueueArea =
document.querySelector ".button-area" :?> Browser.Types.HTMLTableElement
messageQueueArea
|> Table.createHeaderRow document (List.init clusterSize (sprintf "Server %i"))
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<string> 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>
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>
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 cluster, network = InMemoryCluster.make<byte> 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) ->
Button.create
document
(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 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
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 row in allButtons' do
Table.createRow document row messageQueueArea
for col in row do
let entry = document.createElement "td" :?> Browser.Types.HTMLTableCellElement
let perform (action : NetworkAction<_>) : unit =
performWithoutPrintingNetworkState action
printNetworkState network
match col with
| None -> ()
| Some button -> entry.appendChild button |> ignore
let startupText =
document.querySelector ".startup-text" :?> Browser.Types.HTMLParagraphElement
cellRow.appendChild entry |> ignore
startupText.textContent <- "Starting up..."
messageQueueArea.appendChild cellRow |> ignore
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 perform action =
performWithoutPrintingNetworkState action
printNetworkState network
let timeoutButton =
document.querySelector ".timeout-button" :?> Browser.Types.HTMLButtonElement
let getMessage (clusterSize : int) (s : string) : (int<ServerId> * int) option =
match s.Split ',' with
| [| serverId ; messageId |] ->
let serverId = serverId.Trim ()
let messageId = messageId.Trim ()
let timeoutField =
document.querySelector ".timeout-text" :?> Browser.Types.HTMLInputElement
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
timeoutField.max <- string<int> (clusterSize - 1)
timeoutField.min <- "0"
timeoutField.defaultValue <- "0"
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
timeoutButton.onclick <-
fun _event ->
startupSequence.``then`` (fun () ->
timeoutField.valueAsNumber
|> int
|> fun i -> i * 1<ServerId>
|> InactivityTimeout
|> perform
let startupText =
document.querySelector ".startup-text" :?> Browser.Types.HTMLParagraphElement
printNetworkState network
)
startupText.textContent <- "Starting up..."
let heartbeatButton =
document.querySelector ".heartbeat-button" :?> Browser.Types.HTMLButtonElement
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 heartbeatField =
document.querySelector ".heartbeat-text" :?> Browser.Types.HTMLInputElement
let timeoutButton =
document.querySelector ".timeout-button" :?> Browser.Types.HTMLButtonElement
heartbeatField.max <- string<int> (clusterSize - 1)
heartbeatField.min <- "0"
heartbeatField.defaultValue <- "0"
let timeoutField =
document.querySelector ".timeout-text" :?> Browser.Types.HTMLInputElement
heartbeatButton.onclick <-
fun _event ->
startupSequence.``then`` (fun () ->
heartbeatField.valueAsNumber
|> int
|> fun i -> i * 1<ServerId>
|> Heartbeat
|> perform
timeoutField.max <- string<int> (clusterSize - 1)
timeoutField.min <- "0"
printNetworkState network
)
timeoutButton.onclick <-
fun _event ->
startupSequence.``then`` (fun () ->
timeoutField.valueAsNumber
|> int
|> fun i -> i * 1<ServerId>
|> InactivityTimeout
|> perform
let clientDataField =
document.querySelector ".client-data" :?> Browser.Types.HTMLInputElement
printNetworkState network
)
clientDataField.max <- "255"
clientDataField.min <- "0"
clientDataField.defaultValue <- "0"
let heartbeatButton =
document.querySelector ".heartbeat-button" :?> Browser.Types.HTMLButtonElement
let clientDataServerField =
document.querySelector ".client-server-selection" :?> Browser.Types.HTMLInputElement
let heartbeatField =
document.querySelector ".heartbeat-text" :?> Browser.Types.HTMLInputElement
clientDataServerField.max <- string<int> (clusterSize - 1)
clientDataServerField.min <- "0"
clientDataServerField.defaultValue <- "0"
heartbeatField.max <- string<int> (clusterSize - 1)
heartbeatField.min <- "0"
let clientDataSubmitButton =
document.querySelector ".client-data-submit" :?> Browser.Types.HTMLButtonElement
heartbeatButton.onclick <-
fun _event ->
startupSequence.``then`` (fun () ->
heartbeatField.valueAsNumber
|> int
|> fun i -> i * 1<ServerId>
|> Heartbeat
|> perform
clientDataSubmitButton.onclick <-
fun _event ->
startupSequence.``then`` (fun () ->
let server =
clientDataServerField.valueAsNumber |> int |> (fun i -> i * 1<ServerId>)
printNetworkState network
)
let data = clientDataField.valueAsNumber |> byte
NetworkAction.ClientRequest (server, data, printfn "%O") |> perform
printClusterState cluster
)

10
RaftFable/src/Button.fs Normal file
View File

@@ -0,0 +1,10 @@
namespace RaftFable
[<RequireQualifiedAccess>]
module Button =
let create (document : Browser.Types.Document) (text : string) (onClick : Browser.Types.HTMLButtonElement -> unit) =
let node = document.createElement "button" :?> Browser.Types.HTMLButtonElement
node.textContent <- text
node.onclick <- fun _ -> onClick node
node

2
RaftFable/src/RaftFable.fsproj
View File

@@ -3,6 +3,8 @@
<TargetFramework>net6.0</TargetFramework>
</PropertyGroup>
<ItemGroup>
<Compile Include="Table.fs" />
<Compile Include="Button.fs" />
<Compile Include="App.fs" />
</ItemGroup>
<ItemGroup>

37
RaftFable/src/Table.fs Normal file
View File

@@ -0,0 +1,37 @@
namespace RaftFable
[<RequireQualifiedAccess>]
module Table =
let createHeaderRow
(document : Browser.Types.Document)
(headings : string list)
(table : Browser.Types.HTMLTableElement)
: unit =
let row = document.createElement "tr" :?> Browser.Types.HTMLTableRowElement
for heading in headings do
let cell = document.createElement "th" :?> Browser.Types.HTMLTableCellElement
cell.textContent <- heading
row.appendChild cell |> ignore
table.appendChild row |> ignore
let createRow
(document : Browser.Types.Document)
(elements : seq<#Browser.Types.Node option>)
(table : Browser.Types.HTMLTableElement)
: unit =
let row = document.createElement "tr" :?> Browser.Types.HTMLTableRowElement
for col in elements do
let entry = document.createElement "td" :?> Browser.Types.HTMLTableCellElement
match col with
| None -> ()
| Some button -> entry.appendChild button |> ignore
row.appendChild entry |> ignore
table.appendChild row |> ignore