Use spans for Efficiency

This commit is contained in:
Smaug123
2022-11-13 21:44:19 +00:00
parent 2f1ae5cd7f
commit 72785eda06
12 changed files with 315 additions and 150 deletions

View 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
)

View File

@@ -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
View 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

View File

@@ -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) =

View 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"

View File

@@ -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
View 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

View File

@@ -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

View File

@@ -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>

View File

@@ -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>

View File

@@ -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 ->

View File

@@ -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