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

More correct handling of user preferences

Browse Source
This commit is contained in:
Smaug123
2022-11-12 20:27:32 +00:00
parent 5df2910b7f
commit 0accc01126
3 changed files with 146 additions and 81 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
RaftFable/public/index.html
View File

@@ -33,7 +33,7 @@
<button class="heartbeat-button" type="button">Heartbeat server</button>
</form>
<h3>Clients</h3>
<div class="clients"></div>
<table class="clients"></table>
<form>
<label for="client-server-selection">Server to send to</label>
<input type="number" id="client-server-selection" class="client-server-selection" />

160
RaftFable/src/App.fs
View File

@@ -1,5 +1,7 @@
namespace RaftFable
open System.Collections.Generic
open System.Security.Cryptography
open Fable.Core.JS
open Raft
open Browser.Dom
@@ -8,69 +10,8 @@ open Fable.Core
module App =
let clusterSize = 5
let ui = Ui.initialise document
let handleRegisterClientResponse (response : RegisterClientResponse) : unit = printfn "%O" response
let handleClientResponse (response : ClientResponse) : unit = printfn "%O" response
let rec fullyRerender<'a>
(parse : string -> Result<'a, string>)
(userPrefs : UserPreferences<'a> ref)
(cluster : Cluster<'a>)
(network : Network<'a>)
: Promise<unit>
=
userPrefs.Value <-
Ui.getUserPrefs<'a> parse handleRegisterClientResponse handleClientResponse cluster.ClusterSize ui
Ui.freezeState cluster network
|> Async.StartAsPromise
|> fun p ->
p.``then`` (fun clusterState ->
Ui.render<'a>
(perform<'a> parse userPrefs cluster network)
document
ui
{
UserPreferences = userPrefs.Value
ClusterState = clusterState
}
)
and perform<'a>
(parse : string -> Result<'a, string>)
(userPrefs : UserPreferences<'a> ref)
(cluster : Cluster<'a>)
(network : Network<'a>)
(action : NetworkAction<'a>)
: Promise<unit>
=
NetworkAction.perform cluster network action
userPrefs.Value <-
{ userPrefs.Value with
ActionHistory = action :: userPrefs.Value.ActionHistory
}
fullyRerender parse userPrefs cluster network
let parseByte (s : string) =
match System.Byte.TryParse s with
| false, _ -> Error (sprintf "Expected byte, got '%s'" s)
| true, v -> Ok v
let userPrefs : UserPreferences<byte> ref =
ref (Ui.getUserPrefs parseByte handleRegisterClientResponse handleClientResponse clusterSize ui)
let mutable cluster, network = InMemoryCluster.make<byte> clusterSize
let leaderStateButton =
document.querySelector ".leader-select-button" :?> Browser.Types.HTMLButtonElement
leaderStateButton.onclick <- fun _ -> fullyRerender parseByte userPrefs cluster network
let startupActions : NetworkAction<byte> list =
[
NetworkAction.InactivityTimeout 0<ServerId>
@@ -103,7 +44,97 @@ module App =
NetworkAction.NetworkMessage (1<ServerId>, 6)
]
ui.ActionHistory.textContent <- startupActions |> Seq.map NetworkAction.toString |> String.concat "\n"
let userPrefs =
ref
{
ActionHistory = startupActions
ShowConsumedMessages = false
LeaderUnderConsideration = 0<ServerId>
}
Ui.renderPrefs userPrefs.Value ui
let clients = Dictionary<int<ClientId>, int<ClientSequence> HashSet> ()
let handleRegisterClientResponse (response : RegisterClientResponse) : unit =
lock
clients
(fun () ->
match response with
| RegisterClientResponse.Success client ->
if clients.TryAdd (client, HashSet ()) then
()
else
failwith "got a response a second time - need to handle this in the UI"
| RegisterClientResponse.NotLeader hint -> failwith "asked a non-leader, have to handle it"
)
let handleClientResponse (response : ClientResponse) : unit =
lock
clients
(fun () ->
match response with
| ClientResponse.SessionExpired -> failwith "session expired, have to handle it"
| ClientResponse.NotLeader hint -> failwith "asked a non-leader, have to handle it"
| ClientResponse.Success (client, sequence) ->
match clients.TryGetValue client with
| false, _ ->
failwithf "Logic error: committed a client request for a non-existent client %i" client
| true, v -> v.Add sequence |> ignore
)
let rec fullyRerender<'a>
(parse : string -> Result<'a, string>)
(userPrefs : UserPreferences<'a> ref)
(cluster : Cluster<'a>)
(network : Network<'a>)
: Promise<unit>
=
Ui.freezeState cluster network
|> Async.StartAsPromise
|> fun p ->
p.``then`` (fun clusterState ->
Ui.render<'a>
(perform<'a> parse userPrefs cluster network)
document
ui
{
UserPreferences = userPrefs.Value
ClusterState = clusterState
Clients = clients :> IReadOnlyDictionary<_, _>
}
Ui.renderPrefs userPrefs.Value ui
)
and perform<'a>
(parse : string -> Result<'a, string>)
(userPrefs : UserPreferences<'a> ref)
(cluster : Cluster<'a>)
(network : Network<'a>)
(action : NetworkAction<'a>)
: Promise<unit>
=
NetworkAction.perform cluster network action
userPrefs.Value <-
{ userPrefs.Value with
ActionHistory = userPrefs.Value.ActionHistory @ [ action ]
}
fullyRerender parse userPrefs cluster network
let parseByte (s : string) =
match System.Byte.TryParse s with
| false, _ -> Error (sprintf "Expected byte, got '%s'" s)
| true, v -> Ok v
let mutable cluster, network = InMemoryCluster.make<byte> clusterSize
let leaderStateButton =
document.querySelector ".leader-select-button" :?> Browser.Types.HTMLButtonElement
leaderStateButton.onclick <- fun _ -> fullyRerender parseByte userPrefs cluster network
let reloadActions () =
let newCluster, newNetwork = InMemoryCluster.make<byte> clusterSize
@@ -183,4 +214,7 @@ module App =
NetworkAction.ClientRequest (server, ClientRequest.RegisterClient handleRegisterClientResponse)
|> perform parseByte userPrefs cluster network
ui.ShowConsumedMessages.onchange <- fun _event -> fullyRerender parseByte userPrefs cluster network
ui.ShowConsumedMessages.onchange <-
fun _event ->
printfn "rerendering"
fullyRerender parseByte userPrefs cluster network

65
RaftFable/src/Ui.fs
View File

@@ -1,5 +1,6 @@
namespace RaftFable
open System.Collections.Generic
open Raft
type ClusterState<'a> =
@@ -22,6 +23,8 @@ type UiBackingState<'a> =
{
ClusterState : ClusterState<'a>
UserPreferences : UserPreferences<'a>
/// TODO - make this be IReadOnlySet, not HashSet
Clients : IReadOnlyDictionary<int<ClientId>, int<ClientSequence> HashSet>
}
type ClientDataSection =
@@ -43,8 +46,8 @@ type UiElements =
HeartbeatField : Browser.Types.HTMLInputElement
SelectedLeaderId : Browser.Types.HTMLInputElement
ShowConsumedMessages : Browser.Types.HTMLInputElement
ActionHistory : Browser.Types.HTMLTextAreaElement
ClientsList : Browser.Types.HTMLDivElement
ActionHistoryList : Browser.Types.HTMLTextAreaElement
ClientsList : Browser.Types.HTMLTableElement
ClientData : ClientDataSection
ClientCreateServer : Browser.Types.HTMLInputElement
}
@@ -57,7 +60,7 @@ type RequiresPopulation =
[<RequireQualifiedAccess>]
module Ui =
let initialise (document : Browser.Types.Document) : UiElements =
let initialise<'a> (document : Browser.Types.Document) : UiElements =
let serverStatuses =
document.querySelector ".server-statuses" :?> Browser.Types.HTMLTableElement
@@ -96,7 +99,8 @@ module Ui =
let actionHistory =
document.querySelector ".action-history" :?> Browser.Types.HTMLTextAreaElement
let clientsList = document.querySelector ".clients" :?> Browser.Types.HTMLDivElement
let clientsList =
document.querySelector ".clients" :?> Browser.Types.HTMLTableElement
let clientCreateServer =
document.querySelector ".create-client-server" :?> Browser.Types.HTMLInputElement
@@ -119,7 +123,7 @@ module Ui =
HeartbeatField = heartbeatField
SelectedLeaderId = selectedLeaderId
ShowConsumedMessages = showConsumed
ActionHistory = actionHistory
ActionHistoryList = actionHistory
ClientsList = clientsList
ClientData = clientInfo
ClientCreateServer = clientCreateServer
@@ -184,12 +188,21 @@ module Ui =
ui.ShowConsumedMessages.defaultChecked <- false
ui.ClientsList.border <- "1px"
ui.ClientsList.innerText <- ""
{
ServerStatusNodes = serverStatusNodes
}
let renderPrefs<'a> (prefs : UserPreferences<'a>) (ui : UiElements) : unit =
// Action list
let actionList =
prefs.ActionHistory |> Seq.map NetworkAction.toString |> String.concat "\n"
ui.ActionHistoryList.textContent <- actionList
let render<'a>
(perform : NetworkAction<'a> -> Fable.Core.JS.Promise<unit>)
(document : Browser.Types.Document)
@@ -198,13 +211,11 @@ module Ui =
: unit
=
let userPrefs = state.UserPreferences
let state = state.ClusterState
let requiresPopulation = reset state.ClusterSize ui
let requiresPopulation = reset state.ClusterState.ClusterSize ui
let rows =
List.init
state.ClusterSize
state.ClusterState.ClusterSize
(fun i ->
let cell = document.createElement "th" :?> Browser.Types.HTMLTableCellElement
cell.textContent <- sprintf "Server %i" i
@@ -213,7 +224,7 @@ module Ui =
rows
|> List.iteri (fun i row ->
let state = state.InternalState.[i]
let state = state.ClusterState.InternalState.[i]
for logEntry in state.Log do
let cell = document.createElement "td" :?> Browser.Types.HTMLTableCellElement
@@ -225,18 +236,18 @@ module Ui =
row.appendChild cell |> ignore
)
for i in 0 .. state.ClusterSize - 1 do
let status = state.Statuses.[i]
for i in 0 .. state.ClusterState.ClusterSize - 1 do
let status = state.ClusterState.Statuses.[i]
requiresPopulation.ServerStatusNodes.[i].textContent <- status |> string<ServerStatus>
// Network status
let allButtons =
[ 0 .. state.ClusterSize - 1 ]
[ 0 .. state.ClusterState.ClusterSize - 1 ]
|> List.map (fun i ->
if userPrefs.ShowConsumedMessages then
state.AllMessages.[i] |> List.indexed
state.ClusterState.AllMessages.[i] |> List.indexed
else
state.UndeliveredMessages.[i]
state.ClusterState.UndeliveredMessages.[i]
|> List.map (fun (messageId, message) ->
Button.create
document
@@ -267,7 +278,7 @@ module Ui =
leaderIdBox.innerText <- sprintf "%i" userPrefs.LeaderUnderConsideration
let leaderState =
state.InternalState.[userPrefs.LeaderUnderConsideration / 1<ServerId>]
state.ClusterState.InternalState.[userPrefs.LeaderUnderConsideration / 1<ServerId>]
match leaderState.LeaderState with
| None -> leaderIdBox.innerText <- sprintf "%i: not a leader" userPrefs.LeaderUnderConsideration
@@ -313,6 +324,26 @@ module Ui =
Table.createRow document nextToSend ui.LeaderStateTable |> ignore
Table.createHeaderRow document [ "Client ID" ; "Successful requests" ] ui.ClientsList
// Clients
for KeyValue (clientId, committed) in state.Clients do
let clientNode =
let node = document.createElement "div"
node.innerText <- sprintf "%i" clientId
node
let messagesNode =
let node = document.createElement "div"
let text = committed |> Seq.map (sprintf "%i") |> String.concat ","
node.innerText <- text
node
printfn "hi!"
Table.createRow document [ Some clientNode ; Some messagesNode ] ui.ClientsList
|> ignore
let freezeState<'a> (cluster : Cluster<'a>) (network : Network<'a>) : ClusterState<'a> Async =
let internalState =
let states = Array.zeroCreate<ServerInternalState<'a>> cluster.ClusterSize
@@ -376,7 +407,7 @@ module Ui =
ShowConsumedMessages = ui.ShowConsumedMessages.``checked``
ActionHistory =
// TODO write these back out again, and give a button to Load
ui.ActionHistory.textContent.Split "\n"
ui.ActionHistoryList.textContent.Split "\n"
|> Seq.filter (not << System.String.IsNullOrEmpty)
|> Seq.map (
NetworkAction.tryParse<'a>