diff --git a/RaftFable/public/index.html b/RaftFable/public/index.html index b0bc00f..e204f70 100644 --- a/RaftFable/public/index.html +++ b/RaftFable/public/index.html @@ -33,7 +33,7 @@

Clients

-
+
diff --git a/RaftFable/src/App.fs b/RaftFable/src/App.fs index ad1e1d0..13559f0 100644 --- a/RaftFable/src/App.fs +++ b/RaftFable/src/App.fs @@ -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 - = - 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 - = - 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 ref = - ref (Ui.getUserPrefs parseByte handleRegisterClientResponse handleClientResponse clusterSize ui) - - let mutable cluster, network = InMemoryCluster.make clusterSize - - let leaderStateButton = - document.querySelector ".leader-select-button" :?> Browser.Types.HTMLButtonElement - - leaderStateButton.onclick <- fun _ -> fullyRerender parseByte userPrefs cluster network - let startupActions : NetworkAction list = [ NetworkAction.InactivityTimeout 0 @@ -103,7 +44,97 @@ module App = NetworkAction.NetworkMessage (1, 6) ] - ui.ActionHistory.textContent <- startupActions |> Seq.map NetworkAction.toString |> String.concat "\n" + let userPrefs = + ref + { + ActionHistory = startupActions + ShowConsumedMessages = false + LeaderUnderConsideration = 0 + } + + Ui.renderPrefs userPrefs.Value ui + + let clients = Dictionary, int 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 + = + 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 + = + 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 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 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 diff --git a/RaftFable/src/Ui.fs b/RaftFable/src/Ui.fs index 4c98d4e..ae3e1b4 100644 --- a/RaftFable/src/Ui.fs +++ b/RaftFable/src/Ui.fs @@ -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 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 = [] 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) (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 // 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] + state.ClusterState.InternalState.[userPrefs.LeaderUnderConsideration / 1] 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> 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>