Use spans for Efficiency
This commit is contained in:
33
Raft.Test/NetworkAction.fs
Normal file
33
Raft.Test/NetworkAction.fs
Normal file
@@ -0,0 +1,33 @@
|
|||||||
|
namespace Raft.Test
|
||||||
|
|
||||||
|
open FsCheck
|
||||||
|
open Raft
|
||||||
|
|
||||||
|
[<RequireQualifiedAccess>]
|
||||||
|
module NetworkAction =
|
||||||
|
|
||||||
|
let generate<'a> (clusterSize : int) : Gen<NetworkAction<'a>> =
|
||||||
|
gen {
|
||||||
|
let! choice = Arb.generate<NetworkAction<'a>>
|
||||||
|
let! server = Gen.choose (0, clusterSize - 1)
|
||||||
|
let server = server * 1<ServerId>
|
||||||
|
|
||||||
|
match choice with
|
||||||
|
| NetworkAction.InactivityTimeout _ -> return NetworkAction.InactivityTimeout server
|
||||||
|
| NetworkAction.NetworkMessage (_, message) -> return NetworkAction.NetworkMessage (server, abs message)
|
||||||
|
| NetworkAction.DropMessage (_, message) -> return NetworkAction.DropMessage (server, abs message)
|
||||||
|
| NetworkAction.Heartbeat _ -> return NetworkAction.Heartbeat server
|
||||||
|
| NetworkAction.ClientRequest (_, ClientRequest.ClientRequest (client, sequence, data, func)) ->
|
||||||
|
return
|
||||||
|
NetworkAction.ClientRequest (server, ClientRequest.ClientRequest (client, sequence, data, ignore))
|
||||||
|
| NetworkAction.ClientRequest (_, ClientRequest.RegisterClient _) ->
|
||||||
|
return NetworkAction.ClientRequest (server, ClientRequest.RegisterClient ignore)
|
||||||
|
}
|
||||||
|
|
||||||
|
let rec genNoClientRequests<'a> (clusterSize : int) : Gen<NetworkAction<'a>> =
|
||||||
|
generate clusterSize
|
||||||
|
|> Gen.filter (fun action ->
|
||||||
|
match action with
|
||||||
|
| NetworkAction.ClientRequest _ -> false
|
||||||
|
| _ -> true
|
||||||
|
)
|
@@ -9,6 +9,9 @@
|
|||||||
|
|
||||||
<ItemGroup>
|
<ItemGroup>
|
||||||
<Compile Include="Logger.fs" />
|
<Compile Include="Logger.fs" />
|
||||||
|
<Compile Include="Result.fs" />
|
||||||
|
<Compile Include="NetworkAction.fs" />
|
||||||
|
<Compile Include="TestNetworkAction.fs" />
|
||||||
<Compile Include="ValidHistory.fs" />
|
<Compile Include="ValidHistory.fs" />
|
||||||
<Compile Include="TestInMemoryServer.fs" />
|
<Compile Include="TestInMemoryServer.fs" />
|
||||||
<Compile Include="TestInMemoryPersistentState.fs" />
|
<Compile Include="TestInMemoryPersistentState.fs" />
|
||||||
|
9
Raft.Test/Result.fs
Normal file
9
Raft.Test/Result.fs
Normal file
@@ -0,0 +1,9 @@
|
|||||||
|
namespace Raft.Test
|
||||||
|
|
||||||
|
[<RequireQualifiedAccess>]
|
||||||
|
module Result =
|
||||||
|
|
||||||
|
let get<'a, 'b> (r : Result<'a, 'b>) : 'a =
|
||||||
|
match r with
|
||||||
|
| Ok a -> a
|
||||||
|
| Error e -> failwithf "%+A" e
|
@@ -9,6 +9,45 @@ open FsCheck
|
|||||||
[<TestFixture>]
|
[<TestFixture>]
|
||||||
module TestInMemoryServer =
|
module TestInMemoryServer =
|
||||||
|
|
||||||
|
let check<'T> (prop : 'T) =
|
||||||
|
let config =
|
||||||
|
{ Config.QuickThrowOnFailure with
|
||||||
|
MaxTest = 1000
|
||||||
|
}
|
||||||
|
|
||||||
|
Check.One (config, prop)
|
||||||
|
|
||||||
|
let parseByte (s : string) : Result<byte, string> =
|
||||||
|
match System.Byte.TryParse s with
|
||||||
|
| false, _ -> Error (sprintf "oh no: %s" s)
|
||||||
|
| true, v -> Ok v
|
||||||
|
|
||||||
|
[<Test>]
|
||||||
|
let ``Can round-trip NetworkAction`` () =
|
||||||
|
let property (action : NetworkAction<byte>) =
|
||||||
|
let roundTripped =
|
||||||
|
NetworkAction.toString action
|
||||||
|
|> NetworkAction.tryParse parseByte None ignore ignore 5
|
||||||
|
|> Result.get
|
||||||
|
|
||||||
|
match roundTripped, action with
|
||||||
|
| NetworkAction.ClientRequest (server1, request1), NetworkAction.ClientRequest (server2, request2) ->
|
||||||
|
match request1, request2 with
|
||||||
|
| ClientRequest.ClientRequest (client1, seq1, data1, _),
|
||||||
|
ClientRequest.ClientRequest (client2, seq2, data2, _) ->
|
||||||
|
server1 = server2 && client1 = client2 && seq1 = seq2 && data1 = data2
|
||||||
|
| ClientRequest.RegisterClient _, ClientRequest.RegisterClient _ -> server1 = server2
|
||||||
|
| _, _ -> false
|
||||||
|
| NetworkAction.InactivityTimeout server1, NetworkAction.InactivityTimeout server2 -> server1 = server2
|
||||||
|
| NetworkAction.Heartbeat server1, NetworkAction.Heartbeat server2 -> server1 = server2
|
||||||
|
| NetworkAction.DropMessage (server1, message1), NetworkAction.DropMessage (server2, message2) ->
|
||||||
|
server1 = server2 && message1 = message2
|
||||||
|
| NetworkAction.NetworkMessage (server1, message1), NetworkAction.NetworkMessage (server2, message2) ->
|
||||||
|
server1 = server2 && message1 = message2
|
||||||
|
| _, _ -> false
|
||||||
|
|
||||||
|
property |> Prop.forAll (NetworkAction.generate 5 |> Arb.fromGen) |> check
|
||||||
|
|
||||||
[<Test>]
|
[<Test>]
|
||||||
let ``Startup sequence in prod, only one timeout takes place`` () =
|
let ``Startup sequence in prod, only one timeout takes place`` () =
|
||||||
let cluster, network = InMemoryCluster.make<int> 5
|
let cluster, network = InMemoryCluster.make<int> 5
|
||||||
@@ -168,14 +207,6 @@ module TestInMemoryServer =
|
|||||||
if entry < messages.Length then
|
if entry < messages.Length then
|
||||||
cluster.SendMessageDirectly pile messages.[entry]
|
cluster.SendMessageDirectly pile messages.[entry]
|
||||||
|
|
||||||
let check (prop : Property) =
|
|
||||||
let config =
|
|
||||||
{ Config.QuickThrowOnFailure with
|
|
||||||
MaxTest = 1000
|
|
||||||
}
|
|
||||||
|
|
||||||
Check.One (config, prop)
|
|
||||||
|
|
||||||
[<Test>]
|
[<Test>]
|
||||||
let ``Startup sequence in prod, two timeouts at once, property-based: at most one leader is elected`` () =
|
let ``Startup sequence in prod, two timeouts at once, property-based: at most one leader is elected`` () =
|
||||||
let property (history : NetworkMessageSelection) =
|
let property (history : NetworkMessageSelection) =
|
||||||
|
37
Raft.Test/TestNetworkAction.fs
Normal file
37
Raft.Test/TestNetworkAction.fs
Normal file
@@ -0,0 +1,37 @@
|
|||||||
|
namespace Raft.Test
|
||||||
|
|
||||||
|
open Raft
|
||||||
|
open System.Collections.Generic
|
||||||
|
open NUnit.Framework
|
||||||
|
open FsCheck
|
||||||
|
open FsUnitTyped
|
||||||
|
|
||||||
|
[<TestFixture>]
|
||||||
|
module TestNetworkAction =
|
||||||
|
|
||||||
|
[<Test>]
|
||||||
|
let ``Generator hits all cases`` () =
|
||||||
|
let populate (cases : HashSet<_>) (a : NetworkAction<'a>) : bool =
|
||||||
|
cases.Add (a.GetType ()) |> ignore
|
||||||
|
true
|
||||||
|
|
||||||
|
let authoritativeCases = HashSet ()
|
||||||
|
Check.QuickThrowOnFailure (populate authoritativeCases)
|
||||||
|
|
||||||
|
let authoritativeCases =
|
||||||
|
authoritativeCases |> Seq.map (fun ty -> ty.FullName) |> Set.ofSeq
|
||||||
|
|
||||||
|
let ourCases = HashSet ()
|
||||||
|
|
||||||
|
populate ourCases
|
||||||
|
|> Prop.forAll (Arb.fromGen (NetworkAction.generate 5))
|
||||||
|
|> Check.QuickThrowOnFailure
|
||||||
|
|
||||||
|
let ourCases = ourCases |> Seq.map (fun ty -> ty.FullName) |> Set.ofSeq
|
||||||
|
Set.difference authoritativeCases ourCases |> shouldBeEmpty
|
||||||
|
|
||||||
|
// Sanity check that we are actually measuring what we think we're measuring
|
||||||
|
ourCases
|
||||||
|
|> Seq.map (fun name -> name.Split ('[') |> Array.head)
|
||||||
|
|> Set.ofSeq
|
||||||
|
|> shouldContain "Raft.NetworkAction`1+DropMessage"
|
@@ -20,20 +20,6 @@ module ValidHistory =
|
|||||||
|
|
||||||
if isValid then Some (ValidHistory history) else None
|
if isValid then Some (ValidHistory history) else None
|
||||||
|
|
||||||
let rec private networkActionGenNoClientRequests<'a> (clusterSize : int) : Gen<NetworkAction<'a>> =
|
|
||||||
gen {
|
|
||||||
let! choice = Arb.generate<NetworkAction<'a>>
|
|
||||||
let! server = Gen.choose (0, clusterSize - 1)
|
|
||||||
let server = server * 1<ServerId>
|
|
||||||
|
|
||||||
match choice with
|
|
||||||
| NetworkAction.InactivityTimeout _ -> return NetworkAction.InactivityTimeout server
|
|
||||||
| NetworkAction.NetworkMessage (_, message) -> return NetworkAction.NetworkMessage (server, abs message)
|
|
||||||
| NetworkAction.DropMessage (_, message) -> return NetworkAction.DropMessage (server, abs message)
|
|
||||||
| NetworkAction.Heartbeat _ -> return NetworkAction.Heartbeat server
|
|
||||||
| NetworkAction.ClientRequest _ -> return! networkActionGenNoClientRequests clusterSize
|
|
||||||
}
|
|
||||||
|
|
||||||
let private historyGenOfLength<'a>
|
let private historyGenOfLength<'a>
|
||||||
(elementGen : Gen<'a>)
|
(elementGen : Gen<'a>)
|
||||||
(clusterSize : int)
|
(clusterSize : int)
|
||||||
|
44
Raft/EfficientString.fs
Normal file
44
Raft/EfficientString.fs
Normal file
@@ -0,0 +1,44 @@
|
|||||||
|
namespace Raft
|
||||||
|
|
||||||
|
open System
|
||||||
|
|
||||||
|
type internal EfficientString =
|
||||||
|
#if NETSTANDARD2_0
|
||||||
|
string
|
||||||
|
#else
|
||||||
|
System.ReadOnlySpan<char>
|
||||||
|
#endif
|
||||||
|
|
||||||
|
[<RequireQualifiedAccess>]
|
||||||
|
module internal EfficientString =
|
||||||
|
|
||||||
|
let inline ofString (s : string) : EfficientString =
|
||||||
|
#if NETSTANDARD2_0
|
||||||
|
s
|
||||||
|
#else
|
||||||
|
s.AsSpan ()
|
||||||
|
#endif
|
||||||
|
|
||||||
|
let inline trimStart (s : EfficientString) : EfficientString = s.TrimStart ()
|
||||||
|
|
||||||
|
let inline slice (start : int) (length : int) (s : EfficientString) : EfficientString =
|
||||||
|
#if NETSTANDARD2_0
|
||||||
|
s.[start .. start + length - 1]
|
||||||
|
#else
|
||||||
|
s.Slice (start, length)
|
||||||
|
#endif
|
||||||
|
|
||||||
|
/// Mutates the input to drop up to the first instance of the input char,
|
||||||
|
/// and returns what was dropped.
|
||||||
|
/// If the char is not present, deletes the input.
|
||||||
|
let takeUntil<'a> (c : char) (s : EfficientString byref) : EfficientString =
|
||||||
|
let first = s.IndexOf c
|
||||||
|
|
||||||
|
if first < 0 then
|
||||||
|
let toRet = s
|
||||||
|
s <- EfficientString.Empty
|
||||||
|
toRet
|
||||||
|
else
|
||||||
|
let toRet = slice 0 first s
|
||||||
|
s <- slice (first + 1) (s.Length - first - 1) s
|
||||||
|
toRet
|
221
Raft/InMemory.fs
221
Raft/InMemory.fs
@@ -13,17 +13,17 @@ type Cluster<'a> =
|
|||||||
member this.SendMessage (i : int<ServerId>) (m : Message<'a>) : unit = this.SendMessageDirectly i m
|
member this.SendMessage (i : int<ServerId>) (m : Message<'a>) : unit = this.SendMessageDirectly i m
|
||||||
|
|
||||||
member this.InactivityTimeout (i : int<ServerId>) : unit =
|
member this.InactivityTimeout (i : int<ServerId>) : unit =
|
||||||
this.Servers.[i / 1<ServerId>].TriggerInactivityTimeout ()
|
this.Servers[ i / 1<ServerId> ].TriggerInactivityTimeout ()
|
||||||
this.Servers.[i / 1<ServerId>].Sync ()
|
this.Servers[ i / 1<ServerId> ].Sync ()
|
||||||
|
|
||||||
member this.HeartbeatTimeout (i : int<ServerId>) : unit =
|
member this.HeartbeatTimeout (i : int<ServerId>) : unit =
|
||||||
this.Servers.[i / 1<ServerId>].TriggerHeartbeatTimeout ()
|
this.Servers[ i / 1<ServerId> ].TriggerHeartbeatTimeout ()
|
||||||
this.Servers.[i / 1<ServerId>].Sync ()
|
this.Servers[ i / 1<ServerId> ].Sync ()
|
||||||
|
|
||||||
member this.Status (i : int<ServerId>) : ServerStatus = this.Servers.[i / 1<ServerId>].State
|
member this.Status (i : int<ServerId>) : ServerStatus = this.Servers[i / 1<ServerId>].State
|
||||||
|
|
||||||
member this.GetCurrentInternalState (i : int<ServerId>) : ServerInternalState<'a> Async =
|
member this.GetCurrentInternalState (i : int<ServerId>) : ServerInternalState<'a> Async =
|
||||||
this.Servers.[i / 1<ServerId>].GetCurrentInternalState ()
|
this.Servers[ i / 1<ServerId> ].GetCurrentInternalState ()
|
||||||
|
|
||||||
member this.ClusterSize : int = this.Servers.Length
|
member this.ClusterSize : int = this.Servers.Length
|
||||||
|
|
||||||
@@ -55,21 +55,21 @@ type Network<'a> =
|
|||||||
}
|
}
|
||||||
|
|
||||||
member this.AllInboundMessages (i : int<ServerId>) : Message<'a> list =
|
member this.AllInboundMessages (i : int<ServerId>) : Message<'a> list =
|
||||||
this.CompleteMessageHistory.[i / 1<ServerId>] |> List.ofSeq
|
this.CompleteMessageHistory[i / 1<ServerId>] |> List.ofSeq
|
||||||
|
|
||||||
member this.InboundMessage (i : int<ServerId>) (id : int) : Message<'a> =
|
member this.InboundMessage (i : int<ServerId>) (id : int) : Message<'a> =
|
||||||
this.CompleteMessageHistory.[i / 1<ServerId>].[id]
|
this.CompleteMessageHistory[i / 1<ServerId>].[id]
|
||||||
|
|
||||||
member this.DropMessage (i : int<ServerId>) (id : int) : unit =
|
member this.DropMessage (i : int<ServerId>) (id : int) : unit =
|
||||||
this.MessagesDelivered.[i / 1<ServerId>].Add id |> ignore
|
this.MessagesDelivered[ i / 1<ServerId> ].Add id |> ignore
|
||||||
|
|
||||||
member this.UndeliveredMessages (i : int<ServerId>) : (int * Message<'a>) list =
|
member this.UndeliveredMessages (i : int<ServerId>) : (int * Message<'a>) list =
|
||||||
this.CompleteMessageHistory.[i / 1<ServerId>]
|
this.CompleteMessageHistory[i / 1<ServerId>]
|
||||||
|> Seq.indexed
|
|> Seq.indexed
|
||||||
|> Seq.filter (fun (count, _) -> this.MessagesDelivered.[i / 1<ServerId>].Contains count |> not)
|
|> Seq.filter (fun (count, _) -> this.MessagesDelivered[ i / 1<ServerId> ].Contains count |> not)
|
||||||
|> List.ofSeq
|
|> List.ofSeq
|
||||||
|
|
||||||
member this.AllUndeliveredMessages () : ((int * Message<'a>) list) list =
|
member this.AllUndeliveredMessages () : (int * Message<'a>) list list =
|
||||||
List.init this.CompleteMessageHistory.Length (fun i -> this.UndeliveredMessages (i * 1<ServerId>))
|
List.init this.CompleteMessageHistory.Length (fun i -> this.UndeliveredMessages (i * 1<ServerId>))
|
||||||
|
|
||||||
member this.ClusterSize = this.CompleteMessageHistory.Length
|
member this.ClusterSize = this.CompleteMessageHistory.Length
|
||||||
@@ -84,19 +84,19 @@ module InMemoryCluster =
|
|||||||
let network = Network<int>.Make count
|
let network = Network<int>.Make count
|
||||||
|
|
||||||
let messageChannelHold (serverId : int<ServerId>) (message : Message<'a>) : unit =
|
let messageChannelHold (serverId : int<ServerId>) (message : Message<'a>) : unit =
|
||||||
let arr = network.CompleteMessageHistory.[serverId / 1<ServerId>]
|
let arr = network.CompleteMessageHistory[serverId / 1<ServerId>]
|
||||||
lock arr (fun () -> arr.Add message)
|
lock arr (fun () -> arr.Add message)
|
||||||
|
|
||||||
for s in 0 .. servers.Length - 1 do
|
for s in 0 .. servers.Length - 1 do
|
||||||
servers.[s] <- Server (count, s * 1<ServerId>, InMemoryPersistentState (), messageChannelHold)
|
servers[s] <- Server (count, s * 1<ServerId>, InMemoryPersistentState (), messageChannelHold)
|
||||||
|
|
||||||
let cluster =
|
let cluster =
|
||||||
{
|
{
|
||||||
Servers = servers
|
Servers = servers
|
||||||
SendMessageDirectly =
|
SendMessageDirectly =
|
||||||
fun i m ->
|
fun i m ->
|
||||||
servers.[i / 1<ServerId>].Message m
|
servers[ i / 1<ServerId> ].Message m
|
||||||
servers.[i / 1<ServerId>].Sync ()
|
servers[ i / 1<ServerId> ].Sync ()
|
||||||
}
|
}
|
||||||
|
|
||||||
cluster, network
|
cluster, network
|
||||||
@@ -121,28 +121,33 @@ module NetworkAction =
|
|||||||
network.DropMessage serverId messageId
|
network.DropMessage serverId messageId
|
||||||
| ClientRequest (server, request) -> Message.ClientRequest request |> cluster.SendMessage server
|
| ClientRequest (server, request) -> Message.ClientRequest request |> cluster.SendMessage server
|
||||||
|
|
||||||
let private getMessage (clusterSize : int) (s : string) : Result<int<ServerId> * int, string> =
|
let private getMessage (clusterSize : int) (s : EfficientString) : Result<int<ServerId> * int, string> =
|
||||||
match s.Split ',' with
|
let mutable messageId = s
|
||||||
| [| serverId ; messageId |] ->
|
let serverId = EfficientString.takeUntil ',' &messageId
|
||||||
let serverId = serverId.TrimEnd ()
|
|
||||||
let messageId = messageId.Trim ()
|
|
||||||
|
|
||||||
match Int32.TryParse serverId with
|
let serverId = serverId.TrimEnd ()
|
||||||
| true, serverId ->
|
let messageId = messageId.Trim ()
|
||||||
match Int32.TryParse messageId with
|
|
||||||
| true, messageId ->
|
|
||||||
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>, messageId)
|
|
||||||
| false, _ -> sprintf "Non-integer input '%s' for message ID." messageId |> Error
|
|
||||||
| false, _ -> sprintf "Non-integer input '%s' for server ID." serverId |> Error
|
|
||||||
| _ -> Error "Expected a single comma."
|
|
||||||
|
|
||||||
let private getTimeout (clusterSize : int) (serverId : string) : Result<int<ServerId>, string> =
|
|
||||||
match Int32.TryParse serverId with
|
match Int32.TryParse serverId with
|
||||||
| false, _ -> Error (sprintf "Expected an integer, got '%s'" serverId)
|
| false, _ -> sprintf "Non-integer input '%s' for server ID." (serverId.ToString ()) |> Error
|
||||||
|
| true, serverId ->
|
||||||
|
|
||||||
|
match Int32.TryParse messageId with
|
||||||
|
| false, _ ->
|
||||||
|
sprintf "Non-integer input '%s' for message ID." (messageId.ToString ())
|
||||||
|
|> Error
|
||||||
|
|
||||||
|
| true, messageId ->
|
||||||
|
|
||||||
|
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>, messageId)
|
||||||
|
|
||||||
|
let private getTimeout (clusterSize : int) (serverId : EfficientString) : Result<int<ServerId>, string> =
|
||||||
|
match Int32.TryParse serverId with
|
||||||
|
| false, _ -> Error (sprintf "Expected an integer, got '%s'" (serverId.ToString ()))
|
||||||
| true, serverId ->
|
| true, serverId ->
|
||||||
|
|
||||||
if serverId >= clusterSize || serverId < 0 then
|
if serverId >= clusterSize || serverId < 0 then
|
||||||
@@ -151,9 +156,11 @@ module NetworkAction =
|
|||||||
else
|
else
|
||||||
serverId * 1<ServerId> |> Ok
|
serverId * 1<ServerId> |> Ok
|
||||||
|
|
||||||
let private getHeartbeat (leaders : Set<int<ServerId>> option) (clusterSize : int) (serverId : string) =
|
let private getHeartbeat (leaders : Set<int<ServerId>> option) (clusterSize : int) (serverId : EfficientString) =
|
||||||
match Int32.TryParse serverId with
|
match Int32.TryParse serverId with
|
||||||
| false, _ -> sprintf "Expected an integer server ID, got '%s'" serverId |> Error
|
| false, _ ->
|
||||||
|
sprintf "Expected an integer server ID, got '%s'" (serverId.ToString ())
|
||||||
|
|> Error
|
||||||
| true, serverId ->
|
| true, serverId ->
|
||||||
|
|
||||||
if serverId >= clusterSize || serverId < 0 then
|
if serverId >= clusterSize || serverId < 0 then
|
||||||
@@ -172,9 +179,15 @@ module NetworkAction =
|
|||||||
else
|
else
|
||||||
sprintf "Cannot heartbeat a non-leader (%i)." serverId |> Error
|
sprintf "Cannot heartbeat a non-leader (%i)." serverId |> Error
|
||||||
|
|
||||||
let private getNewClientTarget<'a> (clusterSize : int) (serverId : string) : Result<int<ServerId>, string> =
|
let private getNewClientTarget<'a>
|
||||||
|
(clusterSize : int)
|
||||||
|
(serverId : EfficientString)
|
||||||
|
: Result<int<ServerId>, string>
|
||||||
|
=
|
||||||
match Int32.TryParse serverId with
|
match Int32.TryParse serverId with
|
||||||
| false, _ -> sprintf "Expected an int for a server ID, got '%s'" serverId |> Error
|
| false, _ ->
|
||||||
|
sprintf "Expected an int for a server ID, got '%s'" (serverId.ToString ())
|
||||||
|
|> Error
|
||||||
| true, serverId ->
|
| true, serverId ->
|
||||||
|
|
||||||
if serverId >= clusterSize || serverId < 0 then
|
if serverId >= clusterSize || serverId < 0 then
|
||||||
@@ -183,47 +196,43 @@ module NetworkAction =
|
|||||||
else
|
else
|
||||||
Ok (serverId * 1<ServerId>)
|
Ok (serverId * 1<ServerId>)
|
||||||
|
|
||||||
|
/// Mutates the input byref to contain the result.
|
||||||
let private getClientSubmitData<'a>
|
let private getClientSubmitData<'a>
|
||||||
(parse : string -> Result<'a, string>)
|
|
||||||
(clusterSize : int)
|
(clusterSize : int)
|
||||||
(s : string)
|
(s : byref<EfficientString>)
|
||||||
: Result<int<ServerId> * int<ClientId> * int<ClientSequence> * 'a, string>
|
: Result<int<ServerId> * int<ClientId> * int<ClientSequence>, string>
|
||||||
=
|
=
|
||||||
match s.Split ',' |> List.ofArray with
|
let serverId = EfficientString.takeUntil ',' &s
|
||||||
| serverId :: clientId :: clientSequenceNumber :: (_ :: _ as rest) ->
|
let clientId = EfficientString.takeUntil ',' &s
|
||||||
let rest = String.concat "," rest |> fun s -> s.TrimStart ()
|
let clientSequenceNumber = EfficientString.takeUntil ',' &s
|
||||||
|
|
||||||
match Int32.TryParse (serverId.Trim ()) with
|
match Int32.TryParse (serverId.Trim ()) with
|
||||||
| false, _ ->
|
| false, _ ->
|
||||||
sprintf "Server ID expected as first comma-separated component, got '%s'." serverId
|
sprintf "Server ID expected as first comma-separated component, got '%s'." (serverId.ToString ())
|
||||||
|> 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
|
|> 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.ToString ())
|
||||||
|
|> Error
|
||||||
|
| true, clientId ->
|
||||||
|
|
||||||
|
match Int32.TryParse (clientSequenceNumber.Trim ()) with
|
||||||
|
| false, _ ->
|
||||||
|
sprintf
|
||||||
|
"Client sequence number expected as third comma-separated component, got '%s'."
|
||||||
|
(clientSequenceNumber.ToString ())
|
||||||
|
|> Error
|
||||||
|
| true, clientSequenceNumber ->
|
||||||
|
|
||||||
|
(serverId * 1<ServerId>, clientId * 1<ClientId>, clientSequenceNumber * 1<ClientSequence>)
|
||||||
|
|> Ok
|
||||||
|
|
||||||
/// Optionally also validates leaders against the input set of leaders.
|
/// Optionally also validates leaders against the input set of leaders.
|
||||||
let tryParse<'a>
|
let tryParse<'a>
|
||||||
@@ -238,37 +247,45 @@ module NetworkAction =
|
|||||||
if String.IsNullOrEmpty s then
|
if String.IsNullOrEmpty s then
|
||||||
Error "Can't parse an empty string"
|
Error "Can't parse an empty string"
|
||||||
else
|
else
|
||||||
match Char.ToUpper s.[0] with
|
|
||||||
| 'T' ->
|
let rest = EfficientString.slice 1 (s.Length - 1) (EfficientString.ofString s)
|
||||||
match getTimeout clusterSize (s.[1..].TrimStart ()) with
|
|
||||||
| Ok t -> t |> InactivityTimeout |> Ok
|
match Char.ToUpper s[0] with
|
||||||
| Error e -> Error e
|
| 'T' ->
|
||||||
| 'D' ->
|
match getTimeout clusterSize (EfficientString.trimStart rest) with
|
||||||
match getMessage clusterSize (s.[1..].TrimStart ()) with
|
| Ok t -> t |> InactivityTimeout |> Ok
|
||||||
| Ok m -> m |> DropMessage |> Ok
|
| Error e -> Error e
|
||||||
| Error e -> Error e
|
| 'D' ->
|
||||||
| 'M' ->
|
match getMessage clusterSize (EfficientString.trimStart rest) with
|
||||||
match getMessage clusterSize (s.[1..].TrimStart ()) with
|
| Ok m -> m |> DropMessage |> Ok
|
||||||
| Ok m -> m |> NetworkMessage |> Ok
|
| Error e -> Error e
|
||||||
| Error e -> Error e
|
| 'M' ->
|
||||||
| 'H' ->
|
match getMessage clusterSize (EfficientString.trimStart rest) with
|
||||||
match getHeartbeat leaders clusterSize (s.[1..].TrimStart ()) with
|
| Ok m -> m |> NetworkMessage |> Ok
|
||||||
| Ok h -> Heartbeat h |> Ok
|
| Error e -> Error e
|
||||||
| Error e -> Error e
|
| 'H' ->
|
||||||
| 'S' ->
|
match getHeartbeat leaders clusterSize (EfficientString.trimStart rest) with
|
||||||
match getNewClientTarget clusterSize (s.[1..].TrimStart ()) with
|
| Ok h -> Heartbeat h |> Ok
|
||||||
| Ok target ->
|
| Error e -> Error e
|
||||||
ClientRequest (target, ClientRequest.RegisterClient handleRegisterClientResponse)
|
| 'S' ->
|
||||||
|> Ok
|
match getNewClientTarget clusterSize (EfficientString.trimStart rest) with
|
||||||
| Error e -> Error e
|
| Ok target ->
|
||||||
| 'R' ->
|
ClientRequest (target, ClientRequest.RegisterClient handleRegisterClientResponse)
|
||||||
match getClientSubmitData parse clusterSize (s.[1..].TrimStart ()) with
|
|> Ok
|
||||||
| Ok (server, client, sequence, data) ->
|
| Error e -> Error e
|
||||||
|
| 'R' ->
|
||||||
|
let mutable rest = EfficientString.trimStart rest
|
||||||
|
|
||||||
|
match getClientSubmitData clusterSize &rest with
|
||||||
|
| Ok (server, client, sequence) ->
|
||||||
|
match parse (rest.ToString ()) with
|
||||||
|
| Ok data ->
|
||||||
(server, ClientRequest.ClientRequest (client, sequence, data, handleClientDataResponse))
|
(server, ClientRequest.ClientRequest (client, sequence, data, handleClientDataResponse))
|
||||||
|> ClientRequest
|
|> ClientRequest
|
||||||
|> Ok
|
|> Ok
|
||||||
| Error e -> Error e
|
| Error e -> Error e
|
||||||
| c -> Error (sprintf "unexpected start char '%c'" c)
|
| Error e -> Error e
|
||||||
|
| c -> Error (sprintf "unexpected start char '%c'" c)
|
||||||
|
|
||||||
let toString<'a> (action : NetworkAction<'a>) : string =
|
let toString<'a> (action : NetworkAction<'a>) : string =
|
||||||
match action with
|
match action with
|
||||||
|
@@ -58,7 +58,7 @@ type InMemoryPersistentState<'a> () =
|
|||||||
if log.Count = 0 then
|
if log.Count = 0 then
|
||||||
None
|
None
|
||||||
else
|
else
|
||||||
let stored, term = log.[log.Count - 1]
|
let stored, term = log[log.Count - 1]
|
||||||
|
|
||||||
Some (
|
Some (
|
||||||
stored,
|
stored,
|
||||||
@@ -73,6 +73,6 @@ type InMemoryPersistentState<'a> () =
|
|||||||
|
|
||||||
if log.Count < position then None
|
if log.Count < position then None
|
||||||
elif position <= 0 then None
|
elif position <= 0 then None
|
||||||
else Some log.[position - 1]
|
else Some log[position - 1]
|
||||||
|
|
||||||
member this.CurrentLogIndex = log.Count * 1<LogIndex>
|
member this.CurrentLogIndex = log.Count * 1<LogIndex>
|
||||||
|
@@ -1,16 +1,21 @@
|
|||||||
<Project Sdk="Microsoft.NET.Sdk">
|
<Project Sdk="Microsoft.NET.Sdk">
|
||||||
|
|
||||||
<PropertyGroup>
|
<PropertyGroup>
|
||||||
<TargetFramework>netstandard2.0</TargetFramework>
|
<TargetFrameworks>netstandard2.0;netstandard2.1</TargetFrameworks>
|
||||||
<TreatWarningsAsErrors>true</TreatWarningsAsErrors>
|
<TreatWarningsAsErrors>true</TreatWarningsAsErrors>
|
||||||
</PropertyGroup>
|
</PropertyGroup>
|
||||||
|
|
||||||
<ItemGroup>
|
<ItemGroup>
|
||||||
<Compile Include="AssemblyInfo.fs" />
|
<Compile Include="AssemblyInfo.fs" />
|
||||||
<Compile Include="Domain.fs" />
|
<Compile Include="Domain.fs" />
|
||||||
|
<Compile Include="EfficientString.fs" />
|
||||||
<Compile Include="PersistentState.fs" />
|
<Compile Include="PersistentState.fs" />
|
||||||
<Compile Include="Server.fs" />
|
<Compile Include="Server.fs" />
|
||||||
<Compile Include="InMemory.fs" />
|
<Compile Include="InMemory.fs" />
|
||||||
</ItemGroup>
|
</ItemGroup>
|
||||||
|
|
||||||
|
<ItemGroup>
|
||||||
|
<PackageReference Update="FSharp.Core" Version="4.3.4" />
|
||||||
|
</ItemGroup>
|
||||||
|
|
||||||
</Project>
|
</Project>
|
||||||
|
@@ -219,7 +219,7 @@ type private CandidateState =
|
|||||||
|
|
||||||
static member New (count : int) (self : int<ServerId>) =
|
static member New (count : int) (self : int<ServerId>) =
|
||||||
let votes = Array.zeroCreate<_> count
|
let votes = Array.zeroCreate<_> count
|
||||||
votes.[self / 1<ServerId>] <- Some true
|
votes[self / 1<ServerId>] <- Some true
|
||||||
|
|
||||||
{
|
{
|
||||||
Votes = votes
|
Votes = votes
|
||||||
@@ -270,12 +270,12 @@ module internal ServerUtils =
|
|||||||
if i < 0 then
|
if i < 0 then
|
||||||
result
|
result
|
||||||
else
|
else
|
||||||
let numberCounted = numberCounted + snd numberWhoCommittedIndex.[i]
|
let numberCounted = numberCounted + snd numberWhoCommittedIndex[i]
|
||||||
|
|
||||||
if numberCounted > matchIndex.Length / 2 then
|
if numberCounted > matchIndex.Length / 2 then
|
||||||
fst numberWhoCommittedIndex.[i]
|
fst numberWhoCommittedIndex[i]
|
||||||
else
|
else
|
||||||
go numberCounted (fst numberWhoCommittedIndex.[i]) (i - 1)
|
go numberCounted (fst numberWhoCommittedIndex[i]) (i - 1)
|
||||||
|
|
||||||
go 0 0<LogIndex> (numberWhoCommittedIndex.Length - 1)
|
go 0 0<LogIndex> (numberWhoCommittedIndex.Length - 1)
|
||||||
|
|
||||||
@@ -528,7 +528,7 @@ type Server<'a>
|
|||||||
acceptRequest ()
|
acceptRequest ()
|
||||||
|
|
||||||
let sendAppendEntries (leaderState : LeaderState) (j : int<ServerId>) =
|
let sendAppendEntries (leaderState : LeaderState) (j : int<ServerId>) =
|
||||||
let toSend = leaderState.ToSend.[j / 1<ServerId>]
|
let toSend = leaderState.ToSend[j / 1<ServerId>]
|
||||||
let prevLogTerm = persistentState.GetLogEntry (toSend - 1<LogIndex>)
|
let prevLogTerm = persistentState.GetLogEntry (toSend - 1<LogIndex>)
|
||||||
|
|
||||||
{
|
{
|
||||||
@@ -572,14 +572,14 @@ type Server<'a>
|
|||||||
match appendEntriesReply.Success with
|
match appendEntriesReply.Success with
|
||||||
| Some matchIndex ->
|
| Some matchIndex ->
|
||||||
// They applied our request. Update our record of what we know they have applied...
|
// They applied our request. Update our record of what we know they have applied...
|
||||||
leaderState.MatchIndex.[appendEntriesReply.Follower / 1<ServerId>] <- matchIndex
|
leaderState.MatchIndex[appendEntriesReply.Follower / 1<ServerId>] <- matchIndex
|
||||||
// ... and update our record of what we'll be sending them next.
|
// ... and update our record of what we'll be sending them next.
|
||||||
leaderState.ToSend.[appendEntriesReply.Follower / 1<ServerId>] <- matchIndex + 1<LogIndex>
|
leaderState.ToSend[appendEntriesReply.Follower / 1<ServerId>] <- matchIndex + 1<LogIndex>
|
||||||
| None ->
|
| None ->
|
||||||
// They failed to apply our request. Next time, we'll be trying one message further
|
// They failed to apply our request. Next time, we'll be trying one message further
|
||||||
// back in our history.
|
// back in our history.
|
||||||
leaderState.ToSend.[appendEntriesReply.Follower / 1<ServerId>] <-
|
leaderState.ToSend[appendEntriesReply.Follower / 1<ServerId>] <-
|
||||||
max (leaderState.ToSend.[appendEntriesReply.Follower / 1<ServerId>] - 1<LogIndex>) 1<LogIndex>
|
max (leaderState.ToSend[appendEntriesReply.Follower / 1<ServerId>] - 1<LogIndex>) 1<LogIndex>
|
||||||
// Note that the decision to process this *here* means the algorithm doesn't work in clusters of
|
// Note that the decision to process this *here* means the algorithm doesn't work in clusters of
|
||||||
// only one node, because then there will never be any AppendEntries replies.
|
// only one node, because then there will never be any AppendEntries replies.
|
||||||
let maxLogAQuorumHasCommitted =
|
let maxLogAQuorumHasCommitted =
|
||||||
@@ -612,17 +612,18 @@ type Server<'a>
|
|||||||
match logEntry with
|
match logEntry with
|
||||||
| LogEntry.ClientEntry (stored, client, sequence, replyChannel) ->
|
| LogEntry.ClientEntry (stored, client, sequence, replyChannel) ->
|
||||||
let newClients =
|
let newClients =
|
||||||
volatileState.Clients
|
match Map.tryFind client volatileState.Clients with
|
||||||
|> Map.change
|
| None -> Map.add client Map.empty volatileState.Clients
|
||||||
client
|
| Some messageLog ->
|
||||||
(fun messageLog ->
|
let messageLog =
|
||||||
let messages =
|
match Map.tryFind sequence messageLog with
|
||||||
match messageLog with
|
| None -> messageLog |> Map.add sequence stored
|
||||||
| None -> Map.empty
|
| Some _ ->
|
||||||
| Some messageLog -> messageLog
|
// Here we'd assert that existing was equal to stored,
|
||||||
|
// if we had the equality constraint
|
||||||
|
messageLog
|
||||||
|
|
||||||
messages |> Map.change sequence (fun _ -> Some stored) |> Some
|
volatileState.Clients |> Map.add client messageLog
|
||||||
)
|
|
||||||
|
|
||||||
volatileState <-
|
volatileState <-
|
||||||
{ volatileState with
|
{ volatileState with
|
||||||
@@ -649,7 +650,7 @@ type Server<'a>
|
|||||||
| ServerSpecialisation.Candidate state ->
|
| ServerSpecialisation.Candidate state ->
|
||||||
|
|
||||||
if requestVoteReply.VoterTerm = persistentState.CurrentTerm then
|
if requestVoteReply.VoterTerm = persistentState.CurrentTerm then
|
||||||
state.Votes.[requestVoteReply.Voter / 1<ServerId>] <- Some requestVoteReply.VoteGranted
|
state.Votes[requestVoteReply.Voter / 1<ServerId>] <- Some requestVoteReply.VoteGranted
|
||||||
|
|
||||||
// Inefficient, but :shrug:
|
// Inefficient, but :shrug:
|
||||||
if
|
if
|
||||||
@@ -714,7 +715,7 @@ type Server<'a>
|
|||||||
(RaftOverhead (NewClientRegistered replyChannel))
|
(RaftOverhead (NewClientRegistered replyChannel))
|
||||||
persistentState.CurrentTerm
|
persistentState.CurrentTerm
|
||||||
|
|
||||||
leaderState.MatchIndex.[me / 1<ServerId>] <- persistentState.CurrentLogIndex
|
leaderState.MatchIndex[me / 1<ServerId>] <- persistentState.CurrentLogIndex
|
||||||
|
|
||||||
emitHeartbeat leaderState
|
emitHeartbeat leaderState
|
||||||
| ClientRequest.ClientRequest (client, sequenceNumber, toAdd, replyChannel) ->
|
| ClientRequest.ClientRequest (client, sequenceNumber, toAdd, replyChannel) ->
|
||||||
@@ -724,7 +725,7 @@ type Server<'a>
|
|||||||
(LogEntry.ClientEntry (toAdd, client, sequenceNumber, replyChannel))
|
(LogEntry.ClientEntry (toAdd, client, sequenceNumber, replyChannel))
|
||||||
persistentState.CurrentTerm
|
persistentState.CurrentTerm
|
||||||
|
|
||||||
leaderState.MatchIndex.[me / 1<ServerId>] <- persistentState.CurrentLogIndex
|
leaderState.MatchIndex[me / 1<ServerId>] <- persistentState.CurrentLogIndex
|
||||||
|
|
||||||
emitHeartbeat leaderState
|
emitHeartbeat leaderState
|
||||||
| ServerSpecialisation.Follower followerState ->
|
| ServerSpecialisation.Follower followerState ->
|
||||||
|
@@ -140,5 +140,4 @@ module Program =
|
|||||||
|
|
||||||
// TODO: log out the committed state so that we can see whether the leader is correctly
|
// TODO: log out the committed state so that we can see whether the leader is correctly
|
||||||
// processing heartbeat responses
|
// processing heartbeat responses
|
||||||
|
|
||||||
0
|
0
|
||||||
|
Reference in New Issue
Block a user