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

Plumb through client requests to UI

Browse Source
This commit is contained in:
Smaug123
2022-11-07 09:40:18 +00:00
parent e7b2f65596
commit 5df2910b7f
11 changed files with 413 additions and 86 deletions
Download Patch File Download Diff File Expand all files Collapse all files

60
Raft.Test/TestInMemoryPersistentState.fs
View File

@@ -15,18 +15,24 @@ module TestInMemoryPersistentState =
s.CurrentLogIndex |> shouldEqual 0<LogIndex>
for i in -2 .. 10 do
s.GetLogEntry (i * 1<LogIndex>) |> shouldEqual None
match s.GetLogEntry (i * 1<LogIndex>) with
| Some _ -> failwith "should not have had a log entry"
| None -> ()
s.CurrentTerm |> shouldEqual 0<Term>
s.VotedFor |> shouldEqual None
s.GetLastLogEntry () |> shouldEqual None
match s.GetLastLogEntry () with
| Some _ -> failwith "should not have had a log entry"
| None -> ()
let ofList<'a> (xs : ('a * int<Term>) list) : InMemoryPersistentState<'a> =
let s = InMemoryPersistentState<'a> ()
for x, term in xs do
(s :> IPersistentState<_>).AppendToLog x term
(s :> IPersistentState<_>).AppendToLog
(LogEntry.ClientEntry (x, 1<ClientId>, 1<ClientSequence>, ignore))
term
s
@@ -38,26 +44,39 @@ module TestInMemoryPersistentState =
[<Test>]
let ``Nonzero truncation followed by Get succeeds`` () =
let property (truncate : int<LogIndex>) (xs : (int * int<Term>) list) : bool =
let property (truncate : int<LogIndex>) (xs : (byte * int<Term>) list) : bool =
let truncate = abs truncate + 1<LogIndex>
let uut = ofList xs
let oldLog = uut.GetLog ()
let oldLog =
uut.GetLog ()
|> List.map (fun (entry, term) -> SerialisedLogEntry.Make entry, term)
match (uut :> IPersistentState<_>).GetLogEntry truncate with
| None ->
(uut :> IPersistentState<_>).TruncateLog truncate
uut.GetLog () = oldLog
let newLog =
uut.GetLog ()
|> List.map (fun (entry, term) -> SerialisedLogEntry.Make entry, term)
newLog = oldLog
| Some (itemStored, entry) ->
(uut :> IPersistentState<_>).TruncateLog truncate
(uut :> IPersistentState<_>).GetLastLogEntry () = Some (
itemStored,
{
Index = truncate
Term = entry
}
)
&& isPrefix (uut.GetLog ()) oldLog
let newLog =
uut.GetLog ()
|> List.map (fun (entry, term) -> SerialisedLogEntry.Make entry, term)
let retrieved, logEntry =
Option.get ((uut :> IPersistentState<_>).GetLastLogEntry ())
logEntry = {
Index = truncate
Term = entry
}
&& (SerialisedLogEntry.Make retrieved = SerialisedLogEntry.Make itemStored)
&& isPrefix newLog oldLog
&& (uut :> IPersistentState<_>).CurrentLogIndex = truncate
Check.QuickThrowOnFailure property
@@ -69,13 +88,20 @@ module TestInMemoryPersistentState =
let uut = ofList xs
// It's not meaningful to take the 0th element
(uut :> IPersistentState<_>).GetLogEntry truncate |> shouldEqual None
match (uut :> IPersistentState<_>).GetLogEntry truncate with
| Some _ -> failwith "should not have had any elements"
| None -> ()
(uut :> IPersistentState<_>).TruncateLog truncate
uut.GetLog () |> shouldEqual []
match uut.GetLog () with
| [] -> ()
| _ -> failwith "should not have had log entries"
let uut = uut :> IPersistentState<_>
uut.GetLastLogEntry () = None && uut.CurrentLogIndex = 0<LogIndex>
match uut.GetLastLogEntry () with
| Some _ -> false
| None -> uut.CurrentLogIndex = 0<LogIndex>
Check.QuickThrowOnFailure property

23
Raft.Test/TestInMemoryServer.fs
View File

@@ -262,6 +262,20 @@ module TestInMemoryServer =
let clusterSize = 5
let cluster, network = InMemoryCluster.make<byte> clusterSize
let registeredSuccessfully = ref 0
let registerResponse (response : RegisterClientResponse) : unit =
response |> shouldEqual (RegisterClientResponse.Success 1<ClientId>)
Interlocked.Increment registeredSuccessfully |> ignore
let respondedSuccessfully = ref 0
let requestResponse (response : ClientResponse) : unit =
response
|> shouldEqual (ClientResponse.Success (1<ClientId>, 1<ClientSequence>))
Interlocked.Increment registeredSuccessfully |> ignore
let startupSequence =
[
NetworkAction.InactivityTimeout 1<ServerId>
@@ -287,7 +301,11 @@ module TestInMemoryServer =
NetworkAction.NetworkMessage (1<ServerId>, 7)
// Submit data to leader. This has the effect of heartbeating the other
// nodes, with a heartbeat that contains the new data.
NetworkAction.ClientRequest (1<ServerId>, byte 3)
NetworkAction.ClientRequest (1<ServerId>, ClientRequest.RegisterClient registerResponse)
NetworkAction.ClientRequest (
1<ServerId>,
ClientRequest.ClientRequest (1<ClientId>, 1<ClientSequence>, byte 3, requestResponse)
)
// Deliver the data messages.
NetworkAction.NetworkMessage (0<ServerId>, 2)
@@ -330,6 +348,9 @@ module TestInMemoryServer =
}
]
respondedSuccessfully.Value |> shouldEqual 1
registeredSuccessfully.Value |> shouldEqual 1
let freeze<'a> (cluster : Cluster<'a>) =
List.init
cluster.ClusterSize

6
Raft.Test/ValidHistory.fs
View File

@@ -57,12 +57,14 @@ module ValidHistory =
yield NetworkAction.InactivityTimeout server
]
(*
let clientRequestGen =
gen {
let! element = elementGen
let! id = Gen.choose (0, clusterSize - 1)
return NetworkAction.ClientRequest (id * 1<ServerId>, element)
}
*)
let rec go (len : int) =
gen {
@@ -71,9 +73,11 @@ module ValidHistory =
else
let! smaller = go (len - 1)
let! next =
let! next = Gen.elements (permissibleNext ())
(*
clientRequestGen :: List.replicate 5 (Gen.elements (permissibleNext ()))
|> Gen.oneof
*)
NetworkAction.perform cluster network next
return next :: smaller

52
Raft/Domain.fs
View File

@@ -10,7 +10,13 @@ type Term
[<Measure>]
type ServerId
type LogEntry =
[<Measure>]
type ClientId
[<Measure>]
type ClientSequence
type LogEntryMetadata =
{
Index : int<LogIndex>
Term : int<Term>
@@ -18,3 +24,47 @@ type LogEntry =
override this.ToString () =
sprintf "Log entry %i at subjective term %i" this.Index this.Term
type ClientResponse =
| NotLeader of leaderHint : int<ServerId> option
| SessionExpired
| Success of int<ClientId> * int<ClientSequence>
override this.ToString () =
match this with
| ClientResponse.NotLeader hint ->
let hint =
match hint with
| None -> ""
| Some leader -> sprintf " (leader hint: %i)" leader
sprintf "Failed to send data due to not asking leader%s" hint
| ClientResponse.SessionExpired -> "Failed to send data as session expired"
| ClientResponse.Success (client, sequence) -> sprintf "Client %i's request %i succeeded" client sequence
type RegisterClientResponse =
| NotLeader of leaderHint : int<ServerId> option
| Success of int<ClientId>
override this.ToString () =
match this with
| RegisterClientResponse.Success client -> sprintf "Registered client with ID %i" client
| RegisterClientResponse.NotLeader hint ->
let hint =
match hint with
| None -> ""
| Some leader -> sprintf " (leader hint: %i)" leader
sprintf "Failed to register client due to not asking leader%s" hint
type InternalRaftCommunication = | NewClientRegistered of (RegisterClientResponse -> unit)
type LogEntry<'a> =
| ClientEntry of 'a * int<ClientId> * int<ClientSequence> * (ClientResponse -> unit)
| RaftOverhead of InternalRaftCommunication
override this.ToString () =
match this with
| LogEntry.ClientEntry (data, client, sequence, _) ->
sprintf "Client %i, sequence number %i, sends data %O" client sequence data
| LogEntry.RaftOverhead (InternalRaftCommunication.NewClientRegistered _) -> "New client registration"

77
Raft/InMemory.fs
View File

@@ -105,7 +105,7 @@ type NetworkAction<'a> =
| InactivityTimeout of int<ServerId>
| NetworkMessage of int<ServerId> * int
| DropMessage of int<ServerId> * int
| ClientRequest of int<ServerId> * 'a
| ClientRequest of int<ServerId> * ClientRequest<'a>
| Heartbeat of int<ServerId>
[<RequireQualifiedAccess>]
@@ -172,35 +172,65 @@ module NetworkAction =
else
sprintf "Cannot heartbeat a non-leader (%i)." serverId |> Error
let private getClientData<'a>
let private getNewClientTarget<'a> (clusterSize : int) (serverId : string) : Result<int<ServerId>, string> =
match Int32.TryParse serverId with
| false, _ -> sprintf "Expected an int for a server ID, got '%s'" serverId |> Error
| true, serverId ->
if serverId >= clusterSize || serverId < 0 then
sprintf "Server ID must be between 0 and %i inclusive, got %i." (clusterSize - 1) serverId
|> Error
else
Ok (serverId * 1<ServerId>)
let private getClientSubmitData<'a>
(parse : string -> Result<'a, string>)
(clusterSize : int)
(s : string)
: Result<int<ServerId> * 'a, string>
: Result<int<ServerId> * int<ClientId> * int<ClientSequence> * 'a, string>
=
match s.Split ',' |> List.ofArray with
| serverId :: (_ :: _ as rest) ->
| serverId :: clientId :: clientSequenceNumber :: (_ :: _ as rest) ->
let rest = String.concat "," rest |> fun s -> s.TrimStart ()
match Int32.TryParse serverId with
| true, serverId ->
if serverId >= clusterSize || serverId < 0 then
sprintf "Server ID must be between 0 and %i inclusive, got %i." (clusterSize - 1) serverId
|> Error
else
match parse rest with
| Ok b -> Ok (serverId * 1<ServerId>, b)
| Error e -> sprintf "Failed to parse client data: %s" e |> Error
match Int32.TryParse (serverId.Trim ()) with
| false, _ ->
sprintf "Server ID expected as first comma-separated component, got '%s'." serverId
|> Error
| _ -> sprintf "Expected a comma in client data string, got '%s'" s |> Error
| true, serverId ->
if serverId >= clusterSize || serverId < 0 then
sprintf "Server ID must be between 0 and %i inclusive, got %i." (clusterSize - 1) serverId
|> Error
else
match Int32.TryParse (clientId.Trim ()) with
| false, _ ->
sprintf "Client ID expected as second comma-separated component, got '%s'." clientId
|> Error
| true, clientId ->
match Int32.TryParse (clientSequenceNumber.Trim ()) with
| false, _ ->
sprintf
"Client sequence number expected as third comma-separated component, got '%s'."
clientSequenceNumber
|> Error
| true, clientSequenceNumber ->
match parse rest with
| Ok b -> Ok (serverId * 1<ServerId>, clientId * 1<ClientId>, clientSequenceNumber * 1<ClientSequence>, b)
| Error e -> sprintf "Failed to parse client data: %s" e |> Error
| _ ->
sprintf "Expected serverId,clientId,clientSequenceNumber,data; got '%s'" s
|> Error
/// Optionally also validates leaders against the input set of leaders.
let tryParse<'a>
(parse : string -> Result<'a, string>)
(leaders : Set<int<ServerId>> option)
(handleRegisterClientResponse : RegisterClientResponse -> unit)
(handleClientDataResponse : ClientResponse -> unit)
(clusterSize : int)
(s : string)
: Result<NetworkAction<'a>, string>
@@ -226,8 +256,17 @@ module NetworkAction =
| Ok h -> Heartbeat h |> Ok
| Error e -> Error e
| 'S' ->
match getClientData parse clusterSize (s.[1..].TrimStart ()) with
| Ok (server, data) -> ClientRequest (server, data) |> Ok
match getNewClientTarget clusterSize (s.[1..].TrimStart ()) with
| Ok target ->
ClientRequest (target, ClientRequest.RegisterClient handleRegisterClientResponse)
|> Ok
| Error e -> Error e
| 'R' ->
match getClientSubmitData parse clusterSize (s.[1..].TrimStart ()) with
| Ok (server, client, sequence, data) ->
(server, ClientRequest.ClientRequest (client, sequence, data, handleClientDataResponse))
|> ClientRequest
|> Ok
| Error e -> Error e
| c -> Error (sprintf "unexpected start char '%c'" c)
@@ -237,4 +276,6 @@ module NetworkAction =
| NetworkAction.NetworkMessage (server, id) -> sprintf "m %i,%i" server id
| NetworkAction.DropMessage (server, id) -> sprintf "d %i,%i" server id
| NetworkAction.InactivityTimeout server -> sprintf "t %i" server
| NetworkAction.ClientRequest (server, data) -> sprintf "s %i,%O" server data
| NetworkAction.ClientRequest (server, ClientRequest.RegisterClient _) -> sprintf "s %i" server
| NetworkAction.ClientRequest (server, ClientRequest.ClientRequest (client, sequence, data, _)) ->
sprintf "r %i,%i,%i,%O" server client sequence data

12
Raft/PersistentState.fs
View File

@@ -6,15 +6,15 @@ type IPersistentState<'a> =
abstract CurrentTerm : int<Term>
/// If I know about an election in my CurrentTerm, who did I vote for during that election?
abstract VotedFor : int<ServerId> option
abstract AppendToLog : 'a -> int<Term> -> unit
abstract AppendToLog : LogEntry<'a> -> int<Term> -> unit
/// Truncate away the most recent entries of the log.
/// If `GetLogEntry x` would succeed, and then we call `TruncateLog x`,
/// then `GetLogEntry x` will still succeed (but `GetLogEntry (x + 1)` will not).
abstract TruncateLog : int<LogIndex> -> unit
abstract GetLogEntry : int<LogIndex> -> ('a * int<Term>) option
abstract GetLogEntry : int<LogIndex> -> (LogEntry<'a> * int<Term>) option
abstract CurrentLogIndex : int<LogIndex>
abstract GetLastLogEntry : unit -> ('a * LogEntry) option
abstract GetLastLogEntry : unit -> (LogEntry<'a> * LogEntryMetadata) option
abstract AdvanceToTerm : int<Term> -> unit
abstract IncrementTerm : unit -> unit
abstract Vote : int<ServerId> -> unit
@@ -24,7 +24,7 @@ type IPersistentState<'a> =
type InMemoryPersistentState<'a> () =
let mutable currentTerm = 0
let mutable votedFor : int<ServerId> option = None
let log = ResizeArray<'a * int<Term>> ()
let log = ResizeArray<LogEntry<'a> * int<Term>> ()
member this.GetLog () = log |> List.ofSeq
@@ -45,7 +45,7 @@ type InMemoryPersistentState<'a> () =
currentTerm <- term / 1<Term>
votedFor <- None
member this.AppendToLog entry term = log.Add (entry, term)
member this.AppendToLog (entry : LogEntry<'a>) term = log.Add (entry, term)
member this.TruncateLog position =
let position = position / 1<LogIndex>
@@ -54,7 +54,7 @@ type InMemoryPersistentState<'a> () =
let position = if position < 0 then 0 else position
log.RemoveRange (position, log.Count - position)
member this.GetLastLogEntry () : ('a * LogEntry) option =
member this.GetLastLogEntry () : (LogEntry<'a> * LogEntryMetadata) option =
if log.Count = 0 then
None
else

127
Raft/Server.fs
View File

@@ -1,7 +1,7 @@
namespace Raft
/// Server state which need not survive a server crash.
type VolatileState =
type VolatileState<'a> =
{
/// The index of the highest log entry we know is persisted to a majority of the cluster.
// Why is it correct for this to be volatile?
@@ -9,13 +9,16 @@ type VolatileState =
// we *don't* know that any of our log is reflected in the other nodes.
// (We'll soon learn a better value of CommitIndex as we start receiving messages again.)
CommitIndex : int<LogIndex>
/// TODO: do this, and model applying to state machine
LastApplied : int<LogIndex>
Clients : Map<int<ClientId>, Map<int<ClientSequence>, 'a>>
}
static member New : VolatileState =
static member New : VolatileState<'a> =
{
CommitIndex = 0<LogIndex>
LastApplied = 0<LogIndex>
Clients = Map.empty
}
type LeaderState =
@@ -30,7 +33,7 @@ type LeaderState =
MatchIndex : int<LogIndex> array
}
static member New (clusterSize : int) (currentIndex : int<LogIndex>) : LeaderState =
static member New<'a> (clusterSize : int) (currentIndex : int<LogIndex>) : LeaderState =
{
// +1, because these are indexed from 1.
ToSend = Array.create clusterSize (currentIndex + 1<LogIndex>)
@@ -71,7 +74,7 @@ type RequestVoteMessage =
{
CandidateTerm : int<Term>
CandidateId : int<ServerId>
CandidateLastLogEntry : LogEntry option
CandidateLastLogEntry : LogEntryMetadata option
ReplyChannel : RequestVoteReply -> unit
}
@@ -109,11 +112,11 @@ type AppendEntriesMessage<'a> =
/// I am your leader! This is me! (so everyone knows where to send clients to)
LeaderId : int<ServerId>
/// The entry immediately preceding the entry I'm sending you, so you can tell if we've got out of sync.
PrevLogEntry : LogEntry option
PrevLogEntry : LogEntryMetadata option
/// Followers, append this entry to your log. (Or, if None, this is just a heartbeat.)
/// It was determined at the given term - recall that we might need to bring a restarted node up to speed
/// with what happened during terms that took place while it was down.
NewEntry : ('a * int<Term>) option
NewEntry : (LogEntry<'a> * int<Term>) option
LeaderCommitIndex : int<LogIndex>
/// TODO - we don't need this, the responder should just construct
/// the appropriate Message and send it themselves
@@ -133,13 +136,27 @@ type AppendEntriesMessage<'a> =
this.LeaderTerm
this.LeaderCommitIndex
type SerialisedLogEntry<'a> =
| SerialisedClientEntry of 'a * int<ClientId> * int<ClientSequence>
| SerialisedClientRegister
static member Make (entry : LogEntry<'a>) : SerialisedLogEntry<'a> =
match entry with
| ClientEntry (a, client, sequence, _) -> SerialisedClientEntry (a, client, sequence)
| RaftOverhead (NewClientRegistered _) -> SerialisedClientRegister
override this.ToString () =
match this with
| SerialisedClientRegister -> "<client registration>"
| SerialisedClientEntry (data, client, sequence) -> sprintf "Client %i (%i) puts data: %O" client sequence data
/// A readout of the server's internal state, suitable for e.g. debugging tools.
type ServerInternalState<'a> =
{
LogIndex : int<LogIndex>
CurrentTerm : int<Term>
CurrentVote : int<ServerId> option
Log : ('a * int<Term>) option list
Log : (SerialisedLogEntry<'a> * int<Term>) option list
/// A clone of the leader state, if this is a leader.
LeaderState : LeaderState option
}
@@ -182,11 +199,15 @@ type Reply =
| RequestVoteReply v -> v.ToString ()
| AppendEntriesReply r -> r.ToString ()
type ClientRequest<'a> =
| RegisterClient of (RegisterClientResponse -> unit)
| ClientRequest of int<ClientId> * int<ClientSequence> * 'a * (ClientResponse -> unit)
[<RequireQualifiedAccess>]
type Message<'a> =
| Instruction of Instruction<'a>
| Reply of Reply
| ClientRequest of 'a
| ClientRequest of ClientRequest<'a>
override this.ToString () =
match this with
@@ -270,7 +291,7 @@ type Server<'a>
messageChannel : int<ServerId> -> Message<'a> -> unit
)
=
let mutable volatileState = VolatileState.New
let mutable volatileState = VolatileState<'a>.New
let mutable currentType =
ServerSpecialisation.Follower
@@ -567,11 +588,51 @@ type Server<'a>
| Some (_, term) -> term
if ourLogTerm = persistentState.CurrentTerm then
let oldCommitIndex = volatileState.CommitIndex
volatileState <-
{ volatileState with
CommitIndex = maxLogAQuorumHasCommitted
}
for i in (oldCommitIndex / 1<LogIndex> + 1) .. maxLogAQuorumHasCommitted / 1<LogIndex> do
let i = i * 1<LogIndex>
match persistentState.GetLogEntry i with
| None ->
failwith "Invariant violated. Leader does not have a log entry for a committed index."
| Some (logEntry, _term) ->
match logEntry with
| LogEntry.ClientEntry (stored, client, sequence, replyChannel) ->
let newClients =
volatileState.Clients
|> Map.change
client
(fun messageLog ->
let messages =
match messageLog with
| None -> Map.empty
| Some messageLog -> messageLog
messages |> Map.change sequence (fun _ -> Some stored) |> Some
)
volatileState <-
{ volatileState with
Clients = newClients
}
replyChannel (ClientResponse.Success (client, sequence))
| LogEntry.RaftOverhead (NewClientRegistered replyChannel) ->
let clientId = i / 1<LogIndex> * 1<ClientId>
volatileState <-
{ volatileState with
Clients = volatileState.Clients |> Map.add clientId Map.empty
}
clientId |> RegisterClientResponse.Success |> replyChannel
| RequestVoteReply requestVoteReply ->
match currentType with
| ServerSpecialisation.Leader _
@@ -635,18 +696,34 @@ type Server<'a>
|> messageChannel (i * 1<ServerId>)
| ServerAction.Receive (Message.Instruction m) -> processMessage m
| ServerAction.Receive (Message.Reply r) -> processReply r
| ServerAction.Receive (Message.ClientRequest toAdd) ->
match currentType with
| ServerSpecialisation.Leader leaderState ->
persistentState.AppendToLog toAdd persistentState.CurrentTerm
//replyChannel ClientReply.Acknowledged
emitHeartbeat leaderState
| ServerSpecialisation.Follower followerState ->
//replyChannel (ClientReply.Redirect followerState.CurrentLeader)
()
| ServerSpecialisation.Candidate _ ->
//replyChannel ClientReply.Dropped
()
| ServerAction.Receive (Message.ClientRequest request) ->
match request with
| ClientRequest.RegisterClient replyChannel ->
match currentType with
| ServerSpecialisation.Follower followerState ->
replyChannel (RegisterClientResponse.NotLeader followerState.CurrentLeader)
| ServerSpecialisation.Candidate _ -> replyChannel (RegisterClientResponse.NotLeader None)
| ServerSpecialisation.Leader leaderState ->
persistentState.AppendToLog
(RaftOverhead (NewClientRegistered replyChannel))
persistentState.CurrentTerm
leaderState.MatchIndex.[me / 1<ServerId>] <- persistentState.CurrentLogIndex
emitHeartbeat leaderState
| ClientRequest.ClientRequest (client, sequenceNumber, toAdd, replyChannel) ->
match currentType with
| ServerSpecialisation.Leader leaderState ->
persistentState.AppendToLog
(LogEntry.ClientEntry (toAdd, client, sequenceNumber, replyChannel))
persistentState.CurrentTerm
leaderState.MatchIndex.[me / 1<ServerId>] <- persistentState.CurrentLogIndex
emitHeartbeat leaderState
| ServerSpecialisation.Follower followerState ->
replyChannel (ClientResponse.NotLeader followerState.CurrentLeader)
| ServerSpecialisation.Candidate _ -> replyChannel (ClientResponse.NotLeader None)
| ServerAction.Sync replyChannel -> replyChannel.Reply ()
| ServerAction.StateReadout replyChannel ->
{
@@ -659,7 +736,11 @@ type Server<'a>
| Some (_, last) ->
List.init
(last.Index / 1<LogIndex>)
(fun index -> persistentState.GetLogEntry (1<LogIndex> + index * 1<LogIndex>))
(fun index ->
match persistentState.GetLogEntry (1<LogIndex> + index * 1<LogIndex>) with
| None -> None
| Some (entry, term) -> (SerialisedLogEntry.Make entry, term) |> Some
)
LeaderState =
match currentType with
| ServerSpecialisation.Leader state -> state.Clone () |> Some
@@ -676,7 +757,7 @@ type Server<'a>
#endif
mailbox
member this.SendClientRequest (request : 'a) =
member this.SendClientRequest (request : ClientRequest<'a>) =
mailbox.Post (ServerAction.Receive (Message.ClientRequest request))
member this.TriggerInactivityTimeout () = mailbox.Post ServerAction.BeginElection

24
RaftExplorer/Program.fs
View File

@@ -22,7 +22,7 @@ module Program =
let rec getAction (leaders : Set<int<ServerId>>) (clusterSize : int) : NetworkAction<byte> =
printf
"Enter action. Trigger [t]imeout <server id>, [h]eartbeat a leader <server id>, [d]rop message <server id, message id>, [s]ubmit data <server id, byte>, or allow [m]essage <server id, message id>: "
"Enter action. Trigger [t]imeout <server id>, [h]eartbeat a leader <server id>, [d]rop message <server id, message id>, establish new [s]ession <server id>, or allow [m]essage <server id, message id>: "
let s =
let rec go () =
@@ -36,7 +36,27 @@ module Program =
| true, b -> Ok b
| false, _ -> Error (sprintf "expected a byte, got '%s'" s)
match NetworkAction.tryParse parseByte (Some leaders) clusterSize s with
let handleRegister (response : RegisterClientResponse) : unit =
match response with
| RegisterClientResponse.Success i -> printfn "Client successfully registered, getting ID %i" i
| RegisterClientResponse.NotLeader hint ->
match hint with
| Some hint -> printfn "Client failed to register due to not asking a leader; try asking server %i" hint
| None -> printfn "Client failed to register due to not asking a leader."
let handleResponse (response : ClientResponse) : unit =
match response with
| ClientResponse.NotLeader hint ->
match hint with
| Some hint ->
printfn "Client failed to send request due to not asking a leader; try asking server %i" hint
| None -> printfn "Client failed to send request due to not asking a leader."
| ClientResponse.SessionExpired ->
failwith "Client failed to send request due to expiry of session. This currently can't happen."
| ClientResponse.Success (client, sequence) ->
printfn "Raft has committed request from client %i with sequence number %i" client sequence
match NetworkAction.tryParse parseByte (Some leaders) handleRegister handleResponse clusterSize s with
| Ok action -> action
| Error e ->
printfn "%s" e

12
RaftFable/public/index.html
View File

@@ -23,6 +23,7 @@
</table>
</div>
<h2>Interaction</h2>
<h3>Servers</h3>
<form>
<input type="number" class="timeout-text" />
<button id="timeout-button" class="timeout-button" type="button">Inactivity timeout server</button>
@@ -31,13 +32,24 @@
<input type="number" class="heartbeat-text" />
<button class="heartbeat-button" type="button">Heartbeat server</button>
</form>
<h3>Clients</h3>
<div class="clients"></div>
<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" />
<label for="client-id">Client to send from</label>
<input type="number" id="client-id" class="client-id" />
<label for="client-sequence">Sequence number for this client</label>
<input type="number" id="client-sequence" class="client-sequence" />
<button class="client-data-submit" type="button">Submit client data</button>
</form>
<form>
<label for="create-client-server">Server to send a client-create request</label>
<input type="number" id="create-client-server" class="create-client-server" />
<button class="client-create" type="button">Create client</button>
</form>
<h2>Messages in flight</h2>
<form>
<input type="checkbox" class="show-consumed" id="show-consumed" />

37
RaftFable/src/App.fs
View File

@@ -11,6 +11,10 @@ module App =
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)
@@ -18,7 +22,8 @@ module App =
(network : Network<'a>)
: Promise<unit>
=
userPrefs.Value <- Ui.getUserPrefs<'a> parse cluster.ClusterSize ui
userPrefs.Value <-
Ui.getUserPrefs<'a> parse handleRegisterClientResponse handleClientResponse cluster.ClusterSize ui
Ui.freezeState cluster network
|> Async.StartAsPromise
@@ -57,7 +62,7 @@ module App =
| true, v -> Ok v
let userPrefs : UserPreferences<byte> ref =
ref (Ui.getUserPrefs parseByte clusterSize ui)
ref (Ui.getUserPrefs parseByte handleRegisterClientResponse handleClientResponse clusterSize ui)
let mutable cluster, network = InMemoryCluster.make<byte> clusterSize
@@ -105,7 +110,7 @@ module App =
cluster <- newCluster
network <- newNetwork
userPrefs.Value <- Ui.getUserPrefs parseByte clusterSize ui
userPrefs.Value <- Ui.getUserPrefs parseByte handleRegisterClientResponse handleClientResponse clusterSize ui
startupActions
|> fun s -> (fullyRerender parseByte userPrefs cluster network, s)
@@ -151,11 +156,31 @@ module App =
clientDataSubmitButton.onclick <-
fun _event ->
let server =
ui.ClientDataServerField.valueAsNumber |> int |> (fun i -> i * 1<ServerId>)
ui.ClientData.ClientDataServerField.valueAsNumber |> int |> (*) 1<ServerId>
let data = ui.ClientDataField.valueAsNumber |> byte
let data = ui.ClientData.ClientDataField.valueAsNumber |> byte
let clientId = ui.ClientData.ClientIdField.valueAsNumber |> int |> (*) 1<ClientId>
NetworkAction.ClientRequest (server, data)
let clientSequence =
ui.ClientData.ClientSequenceField.valueAsNumber |> int |> (*) 1<ClientSequence>
// TODO: store the reply and display it
NetworkAction.ClientRequest (
server,
ClientRequest.ClientRequest (clientId, clientSequence, data, handleClientResponse)
)
|> perform parseByte userPrefs cluster network
let clientCreateButton =
document.querySelector ".client-create" :?> Browser.Types.HTMLButtonElement
clientCreateButton.onclick <-
fun _event ->
let server = ui.ClientCreateServer.valueAsNumber |> int |> (*) 1<ServerId>
// TODO: store the reply and display it
NetworkAction.ClientRequest (server, ClientRequest.RegisterClient handleRegisterClientResponse)
|> perform parseByte userPrefs cluster network
ui.ShowConsumedMessages.onchange <- fun _event -> fullyRerender parseByte userPrefs cluster network

69
RaftFable/src/Ui.fs
View File

@@ -24,6 +24,14 @@ type UiBackingState<'a> =
UserPreferences : UserPreferences<'a>
}
type ClientDataSection =
{
ClientDataField : Browser.Types.HTMLInputElement
ClientDataServerField : Browser.Types.HTMLInputElement
ClientIdField : Browser.Types.HTMLInputElement
ClientSequenceField : Browser.Types.HTMLInputElement
}
type UiElements =
{
Document : Browser.Types.Document
@@ -32,12 +40,13 @@ type UiElements =
MessageQueueArea : Browser.Types.HTMLTableElement
LeaderStateTable : Browser.Types.HTMLTableElement
TimeoutField : Browser.Types.HTMLInputElement
ClientDataField : Browser.Types.HTMLInputElement
ClientDataServerField : Browser.Types.HTMLInputElement
HeartbeatField : Browser.Types.HTMLInputElement
SelectedLeaderId : Browser.Types.HTMLInputElement
ShowConsumedMessages : Browser.Types.HTMLInputElement
ActionHistory : Browser.Types.HTMLTextAreaElement
ClientsList : Browser.Types.HTMLDivElement
ClientData : ClientDataSection
ClientCreateServer : Browser.Types.HTMLInputElement
}
type RequiresPopulation =
@@ -72,6 +81,12 @@ module Ui =
let clientDataField =
document.querySelector ".client-data" :?> Browser.Types.HTMLInputElement
let clientSequenceField =
document.querySelector ".client-sequence" :?> Browser.Types.HTMLInputElement
let clientIdField =
document.querySelector ".client-id" :?> Browser.Types.HTMLInputElement
let selectedLeaderId =
document.querySelector ".leader-select" :?> Browser.Types.HTMLInputElement
@@ -81,6 +96,19 @@ module Ui =
let actionHistory =
document.querySelector ".action-history" :?> Browser.Types.HTMLTextAreaElement
let clientsList = document.querySelector ".clients" :?> Browser.Types.HTMLDivElement
let clientCreateServer =
document.querySelector ".create-client-server" :?> Browser.Types.HTMLInputElement
let clientInfo =
{
ClientDataField = clientDataField
ClientDataServerField = clientDataServerField
ClientIdField = clientIdField
ClientSequenceField = clientSequenceField
}
{
Document = document
ServerStatusTable = serverStatuses
@@ -88,12 +116,13 @@ module Ui =
MessageQueueArea = messageQueueArea
LeaderStateTable = leaderStateTable
TimeoutField = timeoutField
ClientDataField = clientDataField
ClientDataServerField = clientDataServerField
HeartbeatField = heartbeatField
SelectedLeaderId = selectedLeaderId
ShowConsumedMessages = showConsumed
ActionHistory = actionHistory
ClientsList = clientsList
ClientData = clientInfo
ClientCreateServer = clientCreateServer
}
let reset (clusterSize : int) (ui : UiElements) : RequiresPopulation =
@@ -119,15 +148,22 @@ module Ui =
ui.SelectedLeaderId.min <- "0"
ui.SelectedLeaderId.max <- sprintf "%i" (clusterSize - 1)
ui.SelectedLeaderId.defaultValue <- "0"
ui.ClientDataField.max <- "255"
ui.ClientDataField.min <- "0"
ui.ClientDataField.defaultValue <- "0"
ui.ClientData.ClientDataField.max <- "255"
ui.ClientData.ClientDataField.min <- "0"
ui.ClientData.ClientDataField.defaultValue <- "0"
ui.ClientData.ClientDataServerField.max <- string<int> (clusterSize - 1)
ui.ClientData.ClientDataServerField.min <- "0"
ui.ClientData.ClientDataServerField.defaultValue <- "0"
ui.ClientData.ClientIdField.min <- "0"
ui.ClientData.ClientIdField.defaultValue <- "0"
ui.ClientData.ClientSequenceField.min <- "0"
ui.ClientData.ClientSequenceField.defaultValue <- "0"
ui.ClientCreateServer.min <- "0"
ui.ClientCreateServer.defaultValue <- "0"
ui.ClientCreateServer.max <- string<int> (clusterSize - 1)
ui.HeartbeatField.max <- string<int> (clusterSize - 1)
ui.HeartbeatField.min <- "0"
ui.HeartbeatField.defaultValue <- "0"
ui.ClientDataServerField.max <- string<int> (clusterSize - 1)
ui.ClientDataServerField.min <- "0"
ui.ClientDataServerField.defaultValue <- "0"
ui.TimeoutField.max <- string<int> (clusterSize - 1)
ui.TimeoutField.min <- "0"
ui.TimeoutField.defaultValue <- "0"
@@ -148,6 +184,8 @@ module Ui =
ui.ShowConsumedMessages.defaultChecked <- false
ui.ClientsList.innerText <- ""
{
ServerStatusNodes = serverStatusNodes
}
@@ -327,6 +365,8 @@ module Ui =
let getUserPrefs<'a>
(parse : string -> Result<'a, string>)
(handleRegisterClientResponse : RegisterClientResponse -> unit)
(handleClientDataResponse : ClientResponse -> unit)
(clusterSize : int)
(ui : UiElements)
: UserPreferences<'a>
@@ -338,7 +378,14 @@ module Ui =
// TODO write these back out again, and give a button to Load
ui.ActionHistory.textContent.Split "\n"
|> Seq.filter (not << System.String.IsNullOrEmpty)
|> Seq.map (NetworkAction.tryParse<'a> parse None clusterSize)
|> Seq.map (
NetworkAction.tryParse<'a>
parse
None
handleRegisterClientResponse
handleClientDataResponse
clusterSize
)
|> Result.allOkOrError
// TODO handle this
|> Result.get