diff --git a/.paket/Paket.Restore.targets b/.paket/Paket.Restore.targets index a86be3a1..e7c1bc0c 100644 --- a/.paket/Paket.Restore.targets +++ b/.paket/Paket.Restore.targets @@ -23,6 +23,9 @@ <_PaketExeExtension>$([System.IO.Path]::GetExtension("$(PaketExePath)")) dotnet "$(PaketExePath)" + + "$(PaketExePath)" + $(PaketRootPath)paket.bootstrapper.exe $(PaketToolsPath)paket.bootstrapper.exe "$(PaketBootStrapperExePath)" @@ -50,10 +53,10 @@ - + - + @@ -145,9 +148,10 @@ + diff --git a/.paket/paket.exe b/.paket/paket.exe index e441f7c2..b98e000b 100644 Binary files a/.paket/paket.exe and b/.paket/paket.exe differ diff --git a/src/Disco/Disco/Client/ApiClient.fs b/src/Disco/Disco/Client/ApiClient.fs index c622132a..8452f21c 100644 --- a/src/Disco/Disco/Client/ApiClient.fs +++ b/src/Disco/Disco/Client/ApiClient.fs @@ -189,7 +189,7 @@ module ApiClient = let private handleServerRequest (state: ClientState) (req: Request) (agent: ApiAgent) = match req.Body |> Binary.decode with - | Right (ApiRequest.Snapshot snapshot) -> + | Ok (ApiRequest.Snapshot snapshot) -> state.Socket.Status |> String.format "received snapshot (status: {0})" |> Logger.info (tag "handleServerResponse") @@ -197,12 +197,12 @@ module ApiClient = |> Msg.SetState |> agent.Post - | Right (ApiRequest.Update sm) -> + | Ok (ApiRequest.Update sm) -> sm |> Msg.Update |> agent.Post - | Right other -> + | Ok other -> string other |> ApiError.UnknownCommand |> ApiResponse.NOK @@ -210,7 +210,7 @@ module ApiClient = |> Response.fromRequest req |> state.Socket.Respond - | Left error -> + | Error error -> error |> string |> ApiError.MalformedRequest @@ -230,7 +230,7 @@ module ApiClient = // | _ < __/ (_| | \__ \ || __/ | | __/ (_| | // |_| \_\___|\__, |_|___/\__\___|_| \___|\__,_| // |___/ - | Right ApiResponse.Registered -> + | Ok ApiResponse.Registered -> Logger.info (tag "handleClientResponse") "registration successful" ClientEvent.Registered |> Msg.Notify |> agent.Post @@ -240,7 +240,7 @@ module ApiClient = // | |_| | | | | _ < __/ (_| | \__ \ || __/ | | __/ (_| | // \___/|_| |_|_| \_\___|\__, |_|___/\__\___|_| \___|\__,_| // |___/ - | Right ApiResponse.Unregistered -> + | Ok ApiResponse.Unregistered -> Logger.info (tag "handleClientResponse") "un-registration successful" ClientEvent.UnRegistered |> Msg.Notify |> agent.Post agent.Post Msg.Dispose @@ -250,14 +250,14 @@ module ApiClient = // | \| | | | | ' / // | |\ | |_| | . \ // |_| \_|\___/|_|\_\ - | Right (ApiResponse.NOK error) -> error |> string |> Logger.err (tag "handleClientResponse") + | Ok (ApiResponse.NOK error) -> error |> string |> Logger.err (tag "handleClientResponse") // ____ _ _____ // | _ \ ___ ___ ___ __| | ___ | ____|_ __ _ __ ___ _ __ // | | | |/ _ \/ __/ _ \ / _` |/ _ \ | _| | '__| '__/ _ \| '__| // | |_| | __/ (_| (_) | (_| | __/ | |___| | | | | (_) | | // |____/ \___|\___\___/ \__,_|\___| |_____|_| |_| \___/|_| - | Left error -> error |> string |> Logger.err (tag "handleClientResponse") + | Error error -> error |> string |> Logger.err (tag "handleClientResponse") state // ** handleSocketEvent @@ -376,7 +376,7 @@ module ApiClient = // **** Start member self.Start () = - either { + result { server.Port |> sprintf "Connecting to server on %O:%O" server.IpAddress |> Logger.info (tag "start") @@ -387,7 +387,7 @@ module ApiClient = // **** Restart member self.Restart(server: DiscoServer) = - server |> Msg.Restart |> agent.Post |> Either.succeed + server |> Msg.Restart |> agent.Post |> Result.succeed // **** State diff --git a/src/Disco/Disco/Client/ApiRequest.fs b/src/Disco/Disco/Client/ApiRequest.fs index abbac646..589725df 100644 --- a/src/Disco/Disco/Client/ApiRequest.fs +++ b/src/Disco/Disco/Client/ApiRequest.fs @@ -56,17 +56,17 @@ type ApiError = match fb.Type with | ApiErrorTypeFB.InternalFB -> Internal fb.Data - |> Either.succeed + |> Result.succeed | ApiErrorTypeFB.UnknownCommandFB -> UnknownCommand fb.Data - |> Either.succeed + |> Result.succeed | ApiErrorTypeFB.MalformedRequestFB -> MalformedRequest fb.Data - |> Either.succeed + |> Result.succeed | x -> sprintf "Unknown ApiErrorFB: %A" x |> Error.asClientError "ApiErrorFB.FromFB" - |> Either.fail + |> Result.fail // * ApiRequest @@ -157,6 +157,13 @@ type ApiRequest = | Update (AddMember mem as cmd) | Update (UpdateMember mem as cmd) | Update (RemoveMember mem as cmd) -> + mem + |> Binary.toOffset builder + |> withPayload ParameterFB.ClusterMemberFB cmd.ApiCommand + + | Update (AddMachine mem as cmd) + | Update (UpdateMachine mem as cmd) + | Update (RemoveMachine mem as cmd) -> mem |> Binary.toOffset builder |> withPayload ParameterFB.RaftMemberFB cmd.ApiCommand @@ -308,7 +315,7 @@ type ApiRequest = // |____/|_| |_|\__,_| .__/|___/_| |_|\___/ \__| // |_| | ApiCommandFB.SnapshotFB, ParameterFB.StateFB -> - either { + result { let! state = let statish = fb.Parameter() if statish.HasValue then @@ -317,12 +324,12 @@ type ApiRequest = else "Empty StateFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return Snapshot state } | ApiCommandFB.DataSnapshotFB, ParameterFB.StateFB -> - either { + result { let! state = let statish = fb.Parameter() if statish.HasValue then @@ -331,7 +338,7 @@ type ApiRequest = else "Empty StateFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update(DataSnapshot state) } @@ -343,7 +350,7 @@ type ApiRequest = | ApiCommandFB.RegisterFB, ParameterFB.DiscoClientFB -> let clientish = fb.Parameter() if clientish.HasValue then - either { + result { let value = clientish.Value let! client = DiscoClient.FromFB(value) return Register client @@ -351,12 +358,12 @@ type ApiRequest = else "Empty DiscoClientFB Parameter in ApiRequest" |> Error.asClientError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail | ApiCommandFB.UnRegisterFB, ParameterFB.DiscoClientFB -> let clientish = fb.Parameter() if clientish.HasValue then - either { + result { let value = clientish.Value let! client = DiscoClient.FromFB(value) return UnRegister client @@ -364,7 +371,7 @@ type ApiRequest = else "Empty DiscoClientFB Parameter in ApiRequest" |> Error.asClientError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail // ____ _ _ // | _ \ _ __ ___ (_) ___ ___| |_ @@ -375,9 +382,9 @@ type ApiRequest = | ApiCommandFB.UnloadFB, _ -> UnloadProject |> ApiRequest.Update - |> Either.succeed + |> Result.succeed | ApiCommandFB.UpdateFB, ParameterFB.ProjectFB -> - either { + result { let! project = let projectish = fb.Parameter() if projectish.HasValue then @@ -386,7 +393,7 @@ type ApiRequest = else "Empty DiscoProjectFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateProject project) } @@ -396,7 +403,7 @@ type ApiRequest = // | |__| (_) | | | | | | | | | | | (_| | | | | (_| | |_) | (_| | || (__| | | | // \____\___/|_| |_| |_|_| |_| |_|\__,_|_| |_|\__,_|____/ \__,_|\__\___|_| |_| | ApiCommandFB.BatchFB, ParameterFB.TransactionFB -> - either { + result { let! commands = let batchish = fb.Parameter() if batchish.HasValue then @@ -405,7 +412,7 @@ type ApiRequest = else "Empty CommandBatchFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (CommandBatch commands) } @@ -416,7 +423,7 @@ type ApiRequest = // \____\__,_|\___|_| |_|\__,_|\__, |\___|_| // |___/ | ApiCommandFB.AddFB, ParameterFB.CuePlayerFB -> - either { + result { let! player = let playerish = fb.Parameter() if playerish.HasValue then @@ -425,11 +432,11 @@ type ApiRequest = else "Empty CuePlayer payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddCuePlayer player) } | ApiCommandFB.UpdateFB, ParameterFB.CuePlayerFB -> - either { + result { let! player = let playerish = fb.Parameter() if playerish.HasValue then @@ -438,11 +445,11 @@ type ApiRequest = else "Empty CuePlayer payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateCuePlayer player) } | ApiCommandFB.RemoveFB, ParameterFB.CuePlayerFB -> - either { + result { let! player = let playerish = fb.Parameter() if playerish.HasValue then @@ -451,7 +458,7 @@ type ApiRequest = else "Empty CuePlayer payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemoveCuePlayer player) } @@ -461,7 +468,7 @@ type ApiRequest = // | |___| | | __/ | | | |_ // \____|_|_|\___|_| |_|\__| | ApiCommandFB.AddFB, ParameterFB.DiscoClientFB -> - either { + result { let! client = let clientish = fb.Parameter() if clientish.HasValue then @@ -470,11 +477,11 @@ type ApiRequest = else "Empty DiscoClientFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddClient client) } | ApiCommandFB.UpdateFB, ParameterFB.DiscoClientFB -> - either { + result { let! client = let clientish = fb.Parameter() if clientish.HasValue then @@ -483,11 +490,11 @@ type ApiRequest = else "Empty DiscoClientFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateClient client) } | ApiCommandFB.RemoveFB, ParameterFB.DiscoClientFB -> - either { + result { let! client = let clientish = fb.Parameter() if clientish.HasValue then @@ -496,7 +503,7 @@ type ApiRequest = else "Empty DiscoClientFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemoveClient client) } @@ -506,7 +513,7 @@ type ApiRequest = // | | | | __/ | | | | | |_) | __/ | // |_| |_|\___|_| |_| |_|_.__/ \___|_| | ApiCommandFB.AddFB, ParameterFB.RaftMemberFB -> - either { + result { let! mem = let memish = fb.Parameter() if memish.HasValue then @@ -515,11 +522,11 @@ type ApiRequest = else "Empty RaftMemberFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail - return ApiRequest.Update (AddMember mem) + |> Result.fail + return ApiRequest.Update (AddMachine mem) } | ApiCommandFB.UpdateFB, ParameterFB.RaftMemberFB -> - either { + result { let! mem = let memish = fb.Parameter() if memish.HasValue then @@ -528,11 +535,11 @@ type ApiRequest = else "Empty RaftMemberFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail - return ApiRequest.Update (UpdateMember mem) + |> Result.fail + return ApiRequest.Update (UpdateMachine mem) } | ApiCommandFB.RemoveFB, ParameterFB.RaftMemberFB -> - either { + result { let! mem = let memish = fb.Parameter() if memish.HasValue then @@ -541,7 +548,52 @@ type ApiRequest = else "Empty RaftMemberFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail + return ApiRequest.Update (RemoveMachine mem) + } + + // __ __ _ + // | \/ | ___ _ __ ___ | |__ ___ _ __ + // | |\/| |/ _ \ '_ ` _ \| '_ \ / _ \ '__| + // | | | | __/ | | | | | |_) | __/ | + // |_| |_|\___|_| |_| |_|_.__/ \___|_| + | ApiCommandFB.AddFB, ParameterFB.ClusterMemberFB -> + result { + let! mem = + let memish = fb.Parameter() + if memish.HasValue then + let value = memish.Value + ClusterMember.FromFB value + else + "Empty ClusterMemberFB payload" + |> Error.asParseError "ApiRequest.FromFB" + |> Result.fail + return ApiRequest.Update (AddMember mem) + } + | ApiCommandFB.UpdateFB, ParameterFB.ClusterMemberFB -> + result { + let! mem = + let memish = fb.Parameter() + if memish.HasValue then + let value = memish.Value + ClusterMember.FromFB value + else + "Empty ClusterMemberFB payload" + |> Error.asParseError "ApiRequest.FromFB" + |> Result.fail + return ApiRequest.Update (UpdateMember mem) + } + | ApiCommandFB.RemoveFB, ParameterFB.ClusterMemberFB -> + result { + let! mem = + let memish = fb.Parameter() + if memish.HasValue then + let value = memish.Value + ClusterMember.FromFB value + else + "Empty ClusterMemberFB payload" + |> Error.asParseError "ApiRequest.FromFB" + |> Result.fail return ApiRequest.Update (RemoveMember mem) } @@ -552,15 +604,15 @@ type ApiRequest = /// |_| |___/_____|_| |_|\__|_| \__, | /// |___/ | ApiCommandFB.AddFB, ParameterFB.FsEntryUpdateFB -> - either { + result { let! entryUpdate = let update = fb.Parameter() if update.HasValue then - Either.succeed update.Value + Result.succeed update.Value else "Empty FsEntryUpdateFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail let! id = Id.decodeHostId entryUpdate let! entry = let entryish = entryUpdate.Entry @@ -570,19 +622,19 @@ type ApiRequest = else "Empty FsEntryFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddFsEntry (id, entry)) } | ApiCommandFB.UpdateFB, ParameterFB.FsEntryUpdateFB -> - either { + result { let! entryUpdate = let update = fb.Parameter() if update.HasValue then - Either.succeed update.Value + Result.succeed update.Value else "Empty FsEntryUpdateFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail let! id = Id.decodeHostId entryUpdate let! entry = let entryish = entryUpdate.Entry @@ -592,19 +644,19 @@ type ApiRequest = else "Empty FsEntryFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateFsEntry (id, entry)) } | ApiCommandFB.RemoveFB, ParameterFB.FsEntryUpdateFB -> - either { + result { let! entryUpdate = let update = fb.Parameter() if update.HasValue then - Either.succeed update.Value + Result.succeed update.Value else "Empty FsEntryUpdateFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail let! id = Id.decodeHostId entryUpdate let! path = let entryish = entryUpdate.Path @@ -614,7 +666,7 @@ type ApiRequest = else "Empty FsPathFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemoveFsEntry (id, path)) } @@ -624,15 +676,15 @@ type ApiRequest = /// | _|\__ \| || | | __/ __/ /// |_| |___/|_||_| \___|\___| | ApiCommandFB.AddFB, ParameterFB.FsTreeUpdateFB -> - either { + result { let! treeUpdate = let update = fb.Parameter() if update.HasValue then - Either.succeed update.Value + Result.succeed update.Value else "Empty FsTreeUpdateFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail let! tree = let treeish = treeUpdate.Tree @@ -642,19 +694,19 @@ type ApiRequest = else "Empty FsTreeFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddFsTree tree) } | ApiCommandFB.RemoveFB, ParameterFB.FsTreeUpdateFB -> - either { + result { let! treeUpdate = let update = fb.Parameter() if update.HasValue then - Either.succeed update.Value + Result.succeed update.Value else "Empty FsTreeUpdateFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail let! id = Id.decodeHostId treeUpdate return ApiRequest.Update (RemoveFsTree id) } @@ -666,7 +718,7 @@ type ApiRequest = // \____|_| \___/ \__,_| .__/ // |_| | ApiCommandFB.AddFB, ParameterFB.PinGroupFB -> - either { + result { let! group = let groupish = fb.Parameter() if groupish.HasValue then @@ -675,11 +727,11 @@ type ApiRequest = else "Empty PinGroupFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddPinGroup group) } | ApiCommandFB.UpdateFB, ParameterFB.PinGroupFB -> - either { + result { let! group = let groupish = fb.Parameter() if groupish.HasValue then @@ -688,11 +740,11 @@ type ApiRequest = else "Empty PinGroupFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdatePinGroup group) } | ApiCommandFB.RemoveFB, ParameterFB.PinGroupFB -> - either { + result { let! group = let groupish = fb.Parameter() if groupish.HasValue then @@ -701,7 +753,7 @@ type ApiRequest = else "Empty PinGroupFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemovePinGroup group) } @@ -712,7 +764,7 @@ type ApiRequest = // |_| |_|\__,_| .__/| .__/|_|_| |_|\__, | // |_| |_| |___/ | ApiCommandFB.AddFB, ParameterFB.PinMappingFB -> - either { + result { let! mapping = let mappingish = fb.Parameter() if mappingish.HasValue then @@ -721,11 +773,11 @@ type ApiRequest = else "Empty PinMappingFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddPinMapping mapping) } | ApiCommandFB.UpdateFB, ParameterFB.PinMappingFB -> - either { + result { let! mapping = let mappingish = fb.Parameter() if mappingish.HasValue then @@ -734,11 +786,11 @@ type ApiRequest = else "Empty PinMappingFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdatePinMapping mapping) } | ApiCommandFB.RemoveFB, ParameterFB.PinMappingFB -> - either { + result { let! mapping = let mappingish = fb.Parameter() if mappingish.HasValue then @@ -747,7 +799,7 @@ type ApiRequest = else "Empty PinMappingFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemovePinMapping mapping) } @@ -758,7 +810,7 @@ type ApiRequest = // \_/\_/ |_|\__,_|\__, |\___|\__| // |___/ | ApiCommandFB.AddFB, ParameterFB.PinWidgetFB -> - either { + result { let! widget = let widgetish = fb.Parameter() if widgetish.HasValue then @@ -767,11 +819,11 @@ type ApiRequest = else "Empty PinWidgetFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddPinWidget widget) } | ApiCommandFB.UpdateFB, ParameterFB.PinWidgetFB -> - either { + result { let! widget = let widgetish = fb.Parameter() if widgetish.HasValue then @@ -780,11 +832,11 @@ type ApiRequest = else "Empty PinWidgetFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdatePinWidget widget) } | ApiCommandFB.RemoveFB, ParameterFB.PinWidgetFB -> - either { + result { let! widget = let widgetish = fb.Parameter() if widgetish.HasValue then @@ -793,7 +845,7 @@ type ApiRequest = else "Empty PinWidgetFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemovePinWidget widget) } @@ -803,7 +855,7 @@ type ApiRequest = // | __/| | | | | // |_| |_|_| |_| | ApiCommandFB.AddFB, ParameterFB.PinFB -> - either { + result { let! pin = let pinish = fb.Parameter() if pinish.HasValue then @@ -812,11 +864,11 @@ type ApiRequest = else "Empty PinFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddPin pin) } | ApiCommandFB.UpdateFB, ParameterFB.PinFB -> - either { + result { let! pin = let pinish = fb.Parameter() if pinish.HasValue then @@ -825,11 +877,11 @@ type ApiRequest = else "Empty PinFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdatePin pin) } | ApiCommandFB.RemoveFB, ParameterFB.PinFB -> - either { + result { let! pin = let pinish = fb.Parameter() if pinish.HasValue then @@ -838,11 +890,11 @@ type ApiRequest = else "Empty PinFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemovePin pin) } | ApiCommandFB.UpdateFB, ParameterFB.SlicesFB -> - either { + result { let! slices = let slicish = fb.Parameter() if slicish.HasValue then @@ -851,7 +903,7 @@ type ApiRequest = else "Empty SlicesFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateSlices slices) } @@ -861,7 +913,7 @@ type ApiRequest = // | |__| |_| | __/ // \____\__,_|\___| | ApiCommandFB.AddFB, ParameterFB.CueFB -> - either { + result { let! cue = let cueish = fb.Parameter() if cueish.HasValue then @@ -870,11 +922,11 @@ type ApiRequest = else "Empty CueFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddCue cue) } | ApiCommandFB.UpdateFB, ParameterFB.CueFB -> - either { + result { let! cue = let cueish = fb.Parameter() if cueish.HasValue then @@ -883,11 +935,11 @@ type ApiRequest = else "Empty CueFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateCue cue) } | ApiCommandFB.RemoveFB, ParameterFB.CueFB -> - either { + result { let! cue = let cueish = fb.Parameter() if cueish.HasValue then @@ -896,11 +948,11 @@ type ApiRequest = else "Empty CueFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemoveCue cue) } | ApiCommandFB.CallCueFB, ParameterFB.CueFB -> - either { + result { let! cue = let cueish = fb.Parameter() if cueish.HasValue then @@ -909,7 +961,7 @@ type ApiRequest = else "Empty CueFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (CallCue cue) } @@ -919,7 +971,7 @@ type ApiRequest = // | |__| |_| | __/ |___| \__ \ |_ // \____\__,_|\___|_____|_|___/\__| | ApiCommandFB.AddFB, ParameterFB.CueListFB -> - either { + result { let! cueList = let cueListish = fb.Parameter() if cueListish.HasValue then @@ -928,11 +980,11 @@ type ApiRequest = else "Empty CueListFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddCueList cueList) } | ApiCommandFB.UpdateFB, ParameterFB.CueListFB -> - either { + result { let! cueList = let cueListish = fb.Parameter() if cueListish.HasValue then @@ -941,11 +993,11 @@ type ApiRequest = else "Empty CueListFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateCueList cueList) } | ApiCommandFB.RemoveFB, ParameterFB.CueListFB -> - either { + result { let! cueList = let cueListish = fb.Parameter() if cueListish.HasValue then @@ -954,7 +1006,7 @@ type ApiRequest = else "Empty CueListFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemoveCueList cueList) } @@ -964,7 +1016,7 @@ type ApiRequest = // | |_| \__ \ __/ | // \___/|___/\___|_| | ApiCommandFB.AddFB, ParameterFB.UserFB -> - either { + result { let! user = let userish = fb.Parameter() if userish.HasValue then @@ -973,11 +1025,11 @@ type ApiRequest = else "Empty UserFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddUser user) } | ApiCommandFB.UpdateFB, ParameterFB.UserFB -> - either { + result { let! user = let userish = fb.Parameter() if userish.HasValue then @@ -986,11 +1038,11 @@ type ApiRequest = else "Empty UserFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateUser user) } | ApiCommandFB.RemoveFB, ParameterFB.UserFB -> - either { + result { let! user = let userish = fb.Parameter() if userish.HasValue then @@ -999,7 +1051,7 @@ type ApiRequest = else "Empty UserFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemoveUser user) } @@ -1009,7 +1061,7 @@ type ApiRequest = // ___) | __/\__ \__ \ | (_) | | | | // |____/ \___||___/___/_|\___/|_| |_| | ApiCommandFB.AddFB, ParameterFB.SessionFB -> - either { + result { let! session = let sessionish = fb.Parameter() if sessionish.HasValue then @@ -1018,11 +1070,11 @@ type ApiRequest = else "Empty SessionFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddSession session) } | ApiCommandFB.UpdateFB, ParameterFB.SessionFB -> - either { + result { let! session = let sessionish = fb.Parameter() if sessionish.HasValue then @@ -1031,11 +1083,11 @@ type ApiRequest = else "Empty SessionFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateSession session) } | ApiCommandFB.RemoveFB, ParameterFB.SessionFB -> - either { + result { let! session = let sessionish = fb.Parameter() if sessionish.HasValue then @@ -1044,7 +1096,7 @@ type ApiRequest = else "Empty SessionFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemoveSession session) } @@ -1054,7 +1106,7 @@ type ApiRequest = // | |_| | \__ \ (_| (_) \ V / __/ | | __/ (_| | // |____/|_|___/\___\___/ \_/ \___|_| \___|\__,_| | ApiCommandFB.AddFB, ParameterFB.DiscoveredServiceFB -> - either { + result { let! service = let serviceish = fb.Parameter() if serviceish.HasValue then @@ -1063,11 +1115,11 @@ type ApiRequest = else "Empty DiscoveredServiceFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (AddDiscoveredService service) } | ApiCommandFB.UpdateFB, ParameterFB.DiscoveredServiceFB -> - either { + result { let! service = let serviceish = fb.Parameter() if serviceish.HasValue then @@ -1076,11 +1128,11 @@ type ApiRequest = else "Empty DiscoveredServiceFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateDiscoveredService service) } | ApiCommandFB.RemoveFB, ParameterFB.DiscoveredServiceFB -> - either { + result { let! service = let serviceish = fb.Parameter() if serviceish.HasValue then @@ -1089,7 +1141,7 @@ type ApiRequest = else "Empty DiscoveredServiceFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (RemoveDiscoveredService service) } @@ -1100,7 +1152,7 @@ type ApiRequest = // |_____\___/ \__, | // |___/ | ApiCommandFB.LogEventFB, ParameterFB.LogEventFB -> - either { + result { let! log = let logish = fb.Parameter() if logish.HasValue then @@ -1109,11 +1161,11 @@ type ApiRequest = else "Empty LogEventFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (LogMsg log) } | ApiCommandFB.SetLogLevelFB, _ -> - either { + result { let! level = let levelish = fb.Parameter() if levelish.HasValue then @@ -1122,7 +1174,7 @@ type ApiRequest = else "Empty StringFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (SetLogLevel level) } @@ -1132,16 +1184,16 @@ type ApiRequest = // | |___| | (_) | (__| < // \____|_|\___/ \___|_|\_\ | ApiCommandFB.UpdateFB, ParameterFB.ClockFB -> - either { + result { let! clock = let clockish = fb.Parameter() if clockish.HasValue then let value = clockish.Value - Right value.Value + Ok value.Value else "Empty ClockFB payload" |> Error.asParseError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail return ApiRequest.Update (UpdateClock clock) } @@ -1154,24 +1206,24 @@ type ApiRequest = AppCommand.Undo |> Command |> ApiRequest.Update - |> Either.succeed + |> Result.succeed | ApiCommandFB.RedoFB, _ -> AppCommand.Redo |> Command |> ApiRequest.Update - |> Either.succeed + |> Result.succeed | ApiCommandFB.ResetFB, _ -> AppCommand.Reset |> Command |> ApiRequest.Update - |> Either.succeed + |> Result.succeed | x,y -> sprintf "Unknown Command/Type combination in ApiRequest: %A/%A" x y |> Error.asClientError "ApiRequest.FromFB" - |> Either.fail + |> Result.fail // ** ToBytes @@ -1219,10 +1271,10 @@ type ApiResponse = static member FromFB(fb: ApiResponseFB) = match fb.Status with - | StatusFB.RegisteredFB -> Right Registered - | StatusFB.UnregisteredFB -> Right Unregistered + | StatusFB.RegisteredFB -> Ok Registered + | StatusFB.UnregisteredFB -> Ok Unregistered | StatusFB.NOKFB -> - either { + result { let! error = let errorish = fb.Error if errorish.HasValue then @@ -1231,13 +1283,13 @@ type ApiResponse = else "Empty ApiErrorFB value" |> Error.asParseError "ApiResponse.FromFB" - |> Either.fail + |> Result.fail return NOK error } | x -> sprintf "Unknown StatusFB value: %A" x |> Error.asParseError "ApiResponse.FromFB" - |> Either.fail + |> Result.fail member request.ToBytes() = Binary.buildBuffer request diff --git a/src/Disco/Disco/Client/Interfaces.fs b/src/Disco/Disco/Client/Interfaces.fs index 4f98f1d2..1cd70341 100644 --- a/src/Disco/Disco/Client/Interfaces.fs +++ b/src/Disco/Disco/Client/Interfaces.fs @@ -50,8 +50,8 @@ type ClientEvent = type IApiClient = inherit IDisposable abstract Id: ClientId - abstract Start: unit -> Either - abstract Restart: server:DiscoServer -> Either + abstract Start: unit -> DiscoResult + abstract Restart: server:DiscoServer -> DiscoResult abstract State: State abstract Status: ServiceStatus abstract Subscribe: (ClientEvent -> unit) -> IDisposable diff --git a/src/Disco/Disco/Core/Actor.fs b/src/Disco/Disco/Core/Actor.fs index 96d2dfd2..da8c683e 100644 --- a/src/Disco/Disco/Core/Actor.fs +++ b/src/Disco/Disco/Core/Actor.fs @@ -70,7 +70,7 @@ module AsyncActor = // ** loop - let private loop<'a> tag actor (f: AsyncActorTask<'a>) (inbox: MailboxProcessor<'a>) = + let private loop<'a> _ actor (f: AsyncActorTask<'a>) (inbox: MailboxProcessor<'a>) = let rec _loop () = async { let! msg = inbox.Receive() @@ -112,7 +112,7 @@ module ThreadActor = // ** loop - let private loop<'a> tag (queue: Queue<'a>) (actor: IActor<'a>) (f: ActorTask<'a>) () = + let private loop<'a> _ (queue: Queue<'a>) (actor: IActor<'a>) (f: ActorTask<'a>) () = let mutable run = true try while run do diff --git a/src/Disco/Disco/Core/Aliases.fs b/src/Disco/Disco/Core/Aliases.fs index 6a55f656..da249b34 100644 --- a/src/Disco/Disco/Core/Aliases.fs +++ b/src/Disco/Disco/Core/Aliases.fs @@ -101,8 +101,6 @@ module Measure = let email e: Email = UoM.wrap e let port p: Port = UoM.wrap p let checksum t: Hash = UoM.wrap t - let index i: Index = i * 1 - let term t: Term = t * 1 let version v: Version = UoM.wrap v let astag t: Tag = UoM.wrap t let url t: Url = UoM.wrap t @@ -243,59 +241,59 @@ type ServiceStatus = // ** FromFB static member FromFB (fb: ServiceStatusFB) = - either { + result { return! #if FABLE_COMPILER match fb.Type with - | x when x = ServiceStatusTypeFB.RunningFB -> Right Running - | x when x = ServiceStatusTypeFB.StartingFB -> Right Starting - | x when x = ServiceStatusTypeFB.StoppingFB -> Right Stopping - | x when x = ServiceStatusTypeFB.StoppedFB -> Right Stopped - | x when x = ServiceStatusTypeFB.DisposedFB -> Right Disposed + | x when x = ServiceStatusTypeFB.RunningFB -> Ok Running + | x when x = ServiceStatusTypeFB.StartingFB -> Ok Starting + | x when x = ServiceStatusTypeFB.StoppingFB -> Ok Stopping + | x when x = ServiceStatusTypeFB.StoppedFB -> Ok Stopped + | x when x = ServiceStatusTypeFB.DisposedFB -> Ok Disposed | x when x = ServiceStatusTypeFB.DegradedFB -> - fb.Error |> DiscoError.FromFB |> Either.map Degraded + fb.Error |> DiscoError.FromFB |> Result.map Degraded | x when x = ServiceStatusTypeFB.FailedFB -> - fb.Error |> DiscoError.FromFB |> Either.map Failed + fb.Error |> DiscoError.FromFB |> Result.map Failed | other -> other |> sprintf "could not parse empty Error payload: %O" |> Error.asParseError "ServiceStatus.FromFB" - |> Either.fail + |> Result.fail #else match fb.Type with - | ServiceStatusTypeFB.RunningFB -> Right Running - | ServiceStatusTypeFB.StartingFB -> Right Starting - | ServiceStatusTypeFB.StoppingFB -> Right Stopping - | ServiceStatusTypeFB.StoppedFB -> Right Stopped - | ServiceStatusTypeFB.DisposedFB -> Right Disposed + | ServiceStatusTypeFB.RunningFB -> Ok Running + | ServiceStatusTypeFB.StartingFB -> Ok Starting + | ServiceStatusTypeFB.StoppingFB -> Ok Stopping + | ServiceStatusTypeFB.StoppedFB -> Ok Stopped + | ServiceStatusTypeFB.DisposedFB -> Ok Disposed | ServiceStatusTypeFB.DegradedFB -> let valueish = fb.Error if valueish.HasValue then let value = valueish.Value DiscoError.FromFB value - |> Either.map Degraded + |> Result.map Degraded else "could not parse empty Error payload" |> Error.asParseError "ServiceStatus.FromFB" - |> Either.fail + |> Result.fail | ServiceStatusTypeFB.FailedFB -> let valueish = fb.Error if valueish.HasValue then let value = valueish.Value DiscoError.FromFB value - |> Either.map Failed + |> Result.map Failed else "could not parse empty Error payload" |> Error.asParseError "ServiceStatus.FromFB" - |> Either.fail + |> Result.fail | other -> other |> sprintf "could not parse empty Error payload: %O" |> Error.asParseError "ServiceStatus.FromFB" - |> Either.fail + |> Result.fail #endif } diff --git a/src/Disco/Disco/Core/Asset.fs b/src/Disco/Disco/Core/Asset.fs index efe9ec40..a26fb416 100644 --- a/src/Disco/Disco/Core/Asset.fs +++ b/src/Disco/Disco/Core/Asset.fs @@ -35,46 +35,46 @@ module Asset = #if !FABLE_COMPILER - let inline save< ^t when ^t : (member Save: FilePath -> Either)> + let inline save< ^t when ^t : (member Save: FilePath -> DiscoResult)> (path: FilePath) (t: ^t) = - (^t : (member Save: FilePath -> Either) (t, path)) + (^t : (member Save: FilePath -> DiscoResult) (t, path)) // ** delete - let inline delete< ^t when ^t : (member Delete: FilePath -> Either)> + let inline delete< ^t when ^t : (member Delete: FilePath -> DiscoResult)> (path: FilePath) (t: ^t) = - (^t : (member Delete: FilePath -> Either) (t, path)) + (^t : (member Delete: FilePath -> DiscoResult) (t, path)) // ** saveMap - let inline saveMap (basepath: FilePath) (guard: Either) _ (t: ^t) = - either { + let inline saveMap (basepath: FilePath) (guard: DiscoResult) _ (t: ^t) = + result { do! guard do! save basepath t } // ** load - let inline load< ^t when ^t : (static member Load: FilePath -> Either)> + let inline load< ^t when ^t : (static member Load: FilePath -> DiscoResult< ^t>)> (path: FilePath) = - (^t : (static member Load: FilePath -> Either) path) + (^t : (static member Load: FilePath -> DiscoResult< ^t>) path) // ** loadWithMachine - let inline loadWithMachine< ^t when ^t : (static member Load: FilePath * DiscoMachine -> Either)> + let inline loadWithMachine< ^t when ^t : (static member Load: FilePath * DiscoMachine -> DiscoResult< ^t>)> (path: FilePath) (machine: DiscoMachine) = - (^t : (static member Load: FilePath * DiscoMachine -> Either) (path,machine)) + (^t : (static member Load: FilePath * DiscoMachine -> DiscoResult< ^t>) (path,machine)) // ** loadAll - let inline loadAll< ^t when ^t : (static member LoadAll: FilePath -> Either)> + let inline loadAll< ^t when ^t : (static member LoadAll: FilePath -> DiscoResult< ^t array>)> (basePath: FilePath) = - (^t : (static member LoadAll: FilePath -> Either) basePath) + (^t : (static member LoadAll: FilePath -> DiscoResult< ^t array>) basePath) // ** hasParent @@ -104,9 +104,9 @@ module DiscoData = /// - location: FilePath to asset /// - payload: string payload to save /// - /// Returns: Either + /// Returns: DiscoResult let write (location: FilePath) (payload: StringPayload) = - either { + result { try let data = match payload with | Payload data -> data let info = File.info location @@ -119,7 +119,7 @@ module DiscoData = return! exn.Message |> Error.asAssetError (tag "write") - |> Either.fail + |> Result.fail } #endif @@ -135,9 +135,9 @@ module DiscoData = /// ### Signature: /// - location: FilePath to asset /// - /// Returns: Either + /// Returns: DiscoResult let remove (location: FilePath) = - either { + result { try if File.exists location then Path.map File.Delete location @@ -148,7 +148,7 @@ module DiscoData = return! exn.Message |> Error.asAssetError (tag "remove") - |> Either.fail + |> Result.fail } #endif @@ -165,9 +165,9 @@ module DiscoData = /// ### Signature: /// - locationg: FilePath to asset /// - /// Returns: Either - let read (location: FilePath) : Either = - either { + /// Returns: DiscoResult + let read (location: FilePath) : DiscoResult< string> = + result { if File.exists location then try return File.readText location @@ -176,19 +176,19 @@ module DiscoData = return! exn.Message |> Error.asAssetError (tag "read") - |> Either.fail + |> Result.fail else return! sprintf "File not found: %O" location |> Error.asAssetError (tag "read") - |> Either.fail + |> Result.fail } #endif // ** load let inline load (path: FilePath) = - either { + result { let! data = read path let! group = Yaml.decode data return group @@ -197,7 +197,7 @@ module DiscoData = // ** loadAll let inline loadAll (basePath: FilePath) = - either { + result { try let files = Directory.getFiles true ("*" + Constants.ASSET_EXTENSION) basePath let! (_,groups) = @@ -206,14 +206,14 @@ module DiscoData = |> Array.length |> Array.zeroCreate Array.fold - (fun (m: Either) path -> - either { + (fun (m: DiscoResult) path -> + result { let! (idx,groups) = m let! group = load path groups.[idx] <- group return (idx + 1, groups) }) - (Right(0, arr)) + (Ok(0, arr)) files return groups with @@ -221,7 +221,7 @@ module DiscoData = return! exn.Message |> Error.asAssetError "PinGroup.LoadAll" - |> Either.fail + |> Result.fail } // ** ensureDirectoryExists @@ -231,9 +231,9 @@ module DiscoData = path |> Path.getDirectoryName |> Directory.createDirectory - |> Either.ignore + |> Result.ignore else - Either.nothing + Result.nothing // ** ensureDirectoryGone @@ -241,14 +241,14 @@ module DiscoData = if Asset.hasParent asset then if Directory.isEmpty dir then Directory.removeDirectory dir - |> Either.ignore - else Either.nothing - else Either.nothing + |> Result.ignore + else Result.nothing + else Result.nothing // ** save let inline save (basePath: FilePath) asset = - either { + result { let path = basePath Asset.path asset do! ensureDirectoryExists path asset let data = Yaml.encode asset @@ -259,7 +259,7 @@ module DiscoData = // ** delete let inline delete (basePath: FilePath) asset = - either { + result { let path = basePath Asset.path asset do! path |> Path.concat basePath |> remove do! ensureDirectoryGone (Path.directoryName path) asset @@ -270,7 +270,7 @@ module DiscoData = #if !FABLE_COMPILER let inline commit (basepath: FilePath) (msg: string) (signature: LibGit2Sharp.Signature) (t: ^t) = - either { + result { use! repo = Git.Repo.repository basepath let target = @@ -291,7 +291,7 @@ module DiscoData = #if !FABLE_COMPILER let inline saveWithCommit (basepath: FilePath) (signature: LibGit2Sharp.Signature) (t: ^t) = - either { + result { do! save basepath t let filename = t |> Asset.path |> Path.getFileName let msg = sprintf "%s saved %A" signature.Name filename @@ -305,7 +305,7 @@ module DiscoData = #if !FABLE_COMPILER let inline deleteWithCommit (basepath: FilePath) (signature: LibGit2Sharp.Signature) (t: ^t) = - either { + result { let filepath = basepath Asset.path t let! _ = remove filepath let msg = sprintf "%s deleted %A" signature.Name (Path.getFileName filepath) diff --git a/src/Disco/Disco/Core/Client.fs b/src/Disco/Disco/Core/Client.fs index 76abd918..83fb6eda 100644 --- a/src/Disco/Disco/Core/Client.fs +++ b/src/Disco/Disco/Core/Client.fs @@ -43,18 +43,18 @@ type Role = static member FromFB(fb: RoleFB) = #if FABLE_COMPILER match fb with - | x when x = RoleFB.RendererFB -> Either.succeed Renderer + | x when x = RoleFB.RendererFB -> Result.succeed Renderer | x -> sprintf "Unknown RoleFB value: %A" x |> Error.asClientError "Role.FromFB" - |> Either.fail + |> Result.fail #else match fb with - | RoleFB.RendererFB -> Either.succeed Renderer + | RoleFB.RendererFB -> Result.succeed Renderer | x -> sprintf "Unknown RoleFB value: %A" x |> Error.asClientError "Role.FromFB" - |> Either.fail + |> Result.fail #endif // * DiscoClient @@ -97,7 +97,7 @@ type DiscoClient = // ** FromFB static member FromFB(fb: DiscoClientFB) = - either { + result { let! id = Id.decodeId fb let! serviceId = Id.decodeServiceId fb let! role = Role.FromFB fb.Role @@ -113,7 +113,7 @@ type DiscoClient = else "could not parse empty status payload" |> Error.asParseError "DiscoClient.FromFB" - |> Either.fail + |> Result.fail #endif return { Id = id diff --git a/src/Disco/Disco/Core/Color.fs b/src/Disco/Disco/Core/Color.fs index 63a31936..1513cea4 100644 --- a/src/Disco/Disco/Core/Color.fs +++ b/src/Disco/Disco/Core/Color.fs @@ -148,17 +148,17 @@ type RGBAValue = Green = green Blue = blue Alpha = alpha } - |> Either.succeed + |> Result.succeed | Parsing.RGB (red, green, blue) -> { Red = red Green = green Blue = blue Alpha = 255uy } - |> Either.succeed + |> Result.succeed | _ -> System.String.Format("Cannot parse {0} as RGB(A)", value) |> Error.asParseError "RGBAValue.TryParse" - |> Either.fail + |> Result.fail // ** ToOffset @@ -179,18 +179,18 @@ type RGBAValue = // ** FromFB - static member FromFB(fb: RGBAValueFB) : Either = + static member FromFB(fb: RGBAValueFB) : DiscoResult = try { Red = fb.Red ; Green = fb.Green ; Blue = fb.Blue ; Alpha = fb.Alpha - } |> Right + } |> Ok with | exn -> exn.Message |> Error.asParseError "RGBAValue.FromFB" - |> Either.fail + |> Result.fail // ** ToBytes @@ -291,18 +291,18 @@ type HSLAValue = // ** FromFB - static member FromFB(fb: HSLAValueFB) : Either = + static member FromFB(fb: HSLAValueFB) : DiscoResult = try { Hue = fb.Hue ; Saturation = fb.Saturation ; Lightness = fb.Lightness ; Alpha = fb.Alpha - } |> Right + } |> Ok with | exn -> exn.Message |> Error.asParseError "HSLAValue.FromFB" - |> Either.fail + |> Result.fail // ** ToBytes @@ -333,7 +333,7 @@ type ColorSpace = static member TryParse(value:string) = value |> RGBAValue.TryParse - |> Either.map ColorSpace.RGBA + |> Result.map ColorSpace.RGBA // ** Black @@ -372,25 +372,25 @@ type ColorSpace = // ** FromFB - static member FromFB(fb: ColorSpaceFB) : Either = + static member FromFB(fb: ColorSpaceFB) : DiscoResult = #if FABLE_COMPILER match fb.ValueType with | x when x = ColorSpaceTypeFB.RGBAValueFB -> RGBAValueFB.Create() |> fb.Value |> RGBAValue.FromFB - |> Either.map RGBA + |> Result.map RGBA | x when x = ColorSpaceTypeFB.HSLAValueFB -> HSLAValueFB.Create() |> fb.Value |> HSLAValue.FromFB - |> Either.map HSLA + |> Result.map HSLA | x -> sprintf "Could not deserialize %A" x |> Error.asParseError "ColorSpace.FromFB" - |> Either.fail + |> Result.fail #else // On .NET side, System.Nullables are used. Hard to emulate rn. @@ -400,27 +400,27 @@ type ColorSpace = if v.HasValue then v.Value |> RGBAValue.FromFB - |> Either.map RGBA + |> Result.map RGBA else "Could not parse RGBAValue" |> Error.asParseError "ColorSpace.FromFB" - |> Either.fail + |> Result.fail | ColorSpaceTypeFB.HSLAValueFB -> let v = fb.Value() if v.HasValue then v.Value |> HSLAValue.FromFB - |> Either.map HSLA + |> Result.map HSLA else "Could not parse RGBAValue" |> Error.asParseError "ColorSpace.FromFB" - |> Either.fail + |> Result.fail | x -> sprintf "Could not parse ColorSpaceFB. Unknown type: %A" x |> Error.asParseError "ColorSpace.FromFB" - |> Either.fail + |> Result.fail #endif @@ -469,17 +469,17 @@ type ColorSpace = Green = yml.Channel2; Blue = yml.Channel3; Alpha = yml.Alpha - } |> Right + } |> Ok | "HSLA" -> HSLA { Hue = yml.Channel1; Saturation = yml.Channel2; Lightness = yml.Channel3; Alpha = yml.Alpha - } |> Right + } |> Ok | x -> sprintf "Could not parse ColorYaml. Unknown type: %s" x |> Error.asParseError "ColorSpace.FromYaml" - |> Either.fail + |> Result.fail #endif diff --git a/src/Disco/Disco/Core/Commands.fs b/src/Disco/Disco/Core/Commands.fs index 86add673..e69abe0e 100644 --- a/src/Disco/Disco/Core/Commands.fs +++ b/src/Disco/Disco/Core/Commands.fs @@ -43,4 +43,4 @@ type Command = | LoadProject of projectName:Name * site:NameAndId option | GetProjectSites of projectName:Name -type CommandAgent = Command -> Async> +type CommandAgent = Command -> Async> diff --git a/src/Disco/Disco/Core/Cue.fs b/src/Disco/Disco/Core/Cue.fs index 7996d1af..772af402 100644 --- a/src/Disco/Disco/Core/Cue.fs +++ b/src/Disco/Disco/Core/Cue.fs @@ -50,19 +50,19 @@ type CueYaml() = // ** ToCue member yaml.ToCue() = - either { + result { let! slices = let arr = Array.zeroCreate yaml.Slices.Length Array.fold - (fun (m: Either) box -> either { + (fun (m: DiscoResult) box -> result { let! (i, arr) = m let! (slice : Slices) = Yaml.fromYaml box arr.[i] <- slice return (i + 1, arr) }) - (Right (0, arr)) + (Ok (0, arr)) yaml.Slices - |> Either.map snd + |> Result.map snd let! id = DiscoId.TryParse yaml.Id @@ -106,12 +106,12 @@ type Cue = // |____/|_|_| |_|\__,_|_| \__, | // |___/ - static member FromFB(fb: CueFB) : Either = - either { + static member FromFB(fb: CueFB) : DiscoResult = + result { let! slices = let arr = Array.zeroCreate fb.SlicesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (i, slices) = m let! slice = @@ -126,19 +126,19 @@ type Cue = else "Could not parse empty SlicesFB" |> Error.asParseError "Cue.FromFB" - |> Either.fail + |> Result.fail #endif with | exn -> exn.Message |> Error.asParseError "Cue.FromtFB" - |> Either.fail + |> Result.fail slices.[i] <- slice return (i + 1, slices) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd + |> Result.map snd let! id = Id.decodeId fb @@ -164,7 +164,7 @@ type Cue = // ** FromBytes - static member FromBytes(bytes: byte[]) : Either = + static member FromBytes(bytes: byte[]) : DiscoResult = bytes |> Binary.createBuffer |> CueFB.GetRootAsCueFB @@ -188,7 +188,7 @@ type Cue = // ** FromYaml - static member FromYaml(yaml: CueYaml) : Either = + static member FromYaml(yaml: CueYaml) : DiscoResult = yaml.ToCue() // ** AssetPath @@ -216,12 +216,12 @@ type Cue = // | |__| (_) | (_| | (_| | // |_____\___/ \__,_|\__,_| - static member Load(path: FilePath) : Either = + static member Load(path: FilePath) : DiscoResult = DiscoData.load path // ** LoadAll - static member LoadAll(basePath: FilePath) : Either = + static member LoadAll(basePath: FilePath) : DiscoResult = basePath filepath CUE_DIR |> DiscoData.loadAll diff --git a/src/Disco/Disco/Core/CueGroup.fs b/src/Disco/Disco/Core/CueGroup.fs index c8dd7a32..fba08187 100644 --- a/src/Disco/Disco/Core/CueGroup.fs +++ b/src/Disco/Disco/Core/CueGroup.fs @@ -53,9 +53,9 @@ type CueGroupYaml() = // ** ToCueGroup member yaml.ToCueGroup() = - either { + result { let! id = DiscoId.TryParse yaml.Id - let! cues = Either.bindArray Yaml.fromYaml yaml.CueRefs + let! cues = Result.bindArray Yaml.fromYaml yaml.CueRefs let name = if System.String.IsNullOrWhiteSpace yaml.Name then None @@ -106,10 +106,10 @@ type CueGroup = // |____/|_|_| |_|\__,_|_| \__, | // |___/ - static member FromFB(fb: CueGroupFB) : Either = - either { + static member FromFB(fb: CueGroupFB) : DiscoResult = + result { let! cues = - EitherExt.bindGeneratorToArray + ResultExt.bindGeneratorToArray "CueGroup.FromFB" fb.CueRefsLength fb.CueRefs @@ -143,7 +143,7 @@ type CueGroup = // ** FromBytes - static member FromBytes(bytes: byte[]) : Either = + static member FromBytes(bytes: byte[]) : DiscoResult = bytes |> Binary.createBuffer |> CueGroupFB.GetRootAsCueGroupFB @@ -167,7 +167,7 @@ type CueGroup = // ** FromYaml - static member FromYaml(yaml: CueGroupYaml) : Either = + static member FromYaml(yaml: CueGroupYaml) : DiscoResult = yaml.ToCueGroup() #endif diff --git a/src/Disco/Disco/Core/CueList.fs b/src/Disco/Disco/Core/CueList.fs index c60b784d..3abda8fc 100644 --- a/src/Disco/Disco/Core/CueList.fs +++ b/src/Disco/Disco/Core/CueList.fs @@ -45,19 +45,19 @@ type CueListYaml() = yaml member yaml.ToCueList() = - either { + result { let! items = let arr = Array.zeroCreate yaml.Items.Length Array.fold - (fun (m: Either) itemish -> either { + (fun (m: DiscoResult) itemish -> result { let! (i, arr) = m let! (item: CueGroup) = Yaml.fromYaml itemish arr.[i] <- item return (i + 1, arr) }) - (Right (0, arr)) + (Ok (0, arr)) yaml.Items - |> Either.map snd + |> Result.map snd let! id = DiscoId.TryParse yaml.Id @@ -122,12 +122,12 @@ type CueList = // ** FromFB - static member FromFB(fb: CueListFB) : Either = - either { + static member FromFB(fb: CueListFB) : DiscoResult = + result { let! items = let arr = Array.zeroCreate fb.ItemsLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (i, items) = m #if FABLE_COMPILER @@ -140,15 +140,15 @@ type CueList = else "Could not parse empty CueGroupFB" |> Error.asParseError "CueList.FromFB" - |> Either.fail + |> Result.fail #endif items.[i] <- item return (i + 1, items) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd + |> Result.map snd let! id = Id.decodeId fb @@ -180,7 +180,7 @@ type CueList = // ** FromYaml - static member FromYaml(yml: CueListYaml) : Either = + static member FromYaml(yml: CueListYaml) : DiscoResult = yml.ToCueList() // ** AssetPath @@ -202,12 +202,12 @@ type CueList = // | |__| (_) | (_| | (_| | // |_____\___/ \__,_|\__,_| - static member Load(path: FilePath) : Either = + static member Load(path: FilePath) : DiscoResult = DiscoData.load path // ** LoadAll - static member LoadAll(basePath: FilePath) : Either = + static member LoadAll(basePath: FilePath) : DiscoResult = basePath filepath CUELIST_DIR |> DiscoData.loadAll diff --git a/src/Disco/Disco/Core/CuePlayer.fs b/src/Disco/Disco/Core/CuePlayer.fs index 6605188f..f471b5e1 100644 --- a/src/Disco/Disco/Core/CuePlayer.fs +++ b/src/Disco/Disco/Core/CuePlayer.fs @@ -68,7 +68,7 @@ type CuePlayerYaml() = // ** ToPlayer member yaml.ToPlayer() = - either { + result { let str2opt str = match str with | null -> None @@ -83,7 +83,7 @@ type CuePlayerYaml() = Locked = yaml.Locked Active = yaml.Active CueListId = str2opt yaml.CueListId - Selected = index yaml.Selected + Selected = 1 * yaml.Selected CallId = call NextId = next PreviousId = previous @@ -200,30 +200,30 @@ type CuePlayer = // ** FromFB static member FromFB(fb: CuePlayerFB) = - either { + result { let! cuelist = try if fb.CueListIdLength = 0 - then Either.succeed None - else Id.decodeCueListId fb |> Either.map Some + then Result.succeed None + else Id.decodeCueListId fb |> Result.map Some with exn -> - Either.succeed None + Result.succeed None let! lastcalled = try if fb.LastCalledIdLength = 0 - then Either.succeed None - else Id.decodeLastCalledId fb |> Either.map Some + then Result.succeed None + else Id.decodeLastCalledId fb |> Result.map Some with exn -> - Either.succeed None + Result.succeed None let! lastcaller = try if fb.LastCallerIdLength = 0 - then Either.succeed None - else Id.decodeLastCallerId fb |> Either.map Some + then Result.succeed None + else Id.decodeLastCallerId fb |> Result.map Some with exn -> - Either.succeed None + Result.succeed None let! id = Id.decodeId fb let! call = Id.decodeCallId fb @@ -235,7 +235,7 @@ type CuePlayer = Name = name fb.Name Locked = fb.Locked Active = fb.Active - Selected = index fb.Selected + Selected = 1 * fb.Selected RemainingWait = fb.RemainingWait CueListId = cuelist CallId = call @@ -252,7 +252,7 @@ type CuePlayer = // ** FromBytes - static member FromBytes (bytes: byte[]) : Either = + static member FromBytes (bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> CuePlayerFB.GetRootAsCuePlayerFB |> CuePlayer.FromFB @@ -278,12 +278,12 @@ type CuePlayer = #if !FABLE_COMPILER && !DISCO_NODES - static member Load(path: FilePath) : Either = + static member Load(path: FilePath) : DiscoResult = DiscoData.load path // ** LoadAll - static member LoadAll(basePath: FilePath) : Either = + static member LoadAll(basePath: FilePath) : DiscoResult = basePath filepath Constants.CUEPLAYER_DIR |> DiscoData.loadAll diff --git a/src/Disco/Disco/Core/CueReference.fs b/src/Disco/Disco/Core/CueReference.fs index f9da48b0..43685bc2 100644 --- a/src/Disco/Disco/Core/CueReference.fs +++ b/src/Disco/Disco/Core/CueReference.fs @@ -55,7 +55,7 @@ type CueReferenceYaml() = // ** ToCueReference member yaml.ToCueReference() = - either { + result { let! id = DiscoId.TryParse yaml.Id let! cueId = DiscoId.TryParse yaml.CueId return { @@ -112,8 +112,8 @@ type CueReference = // |____/|_|_| |_|\__,_|_| \__, | // |___/ - static member FromFB(fb: CueReferenceFB) : Either = - either { + static member FromFB(fb: CueReferenceFB) : DiscoResult = + result { let! id = Id.decodeId fb let! cueId = Id.decodeCueId fb return { @@ -140,7 +140,7 @@ type CueReference = // ** FromBytes - static member FromBytes(bytes: byte[]) : Either = + static member FromBytes(bytes: byte[]) : DiscoResult = bytes |> Binary.createBuffer |> CueReferenceFB.GetRootAsCueReferenceFB @@ -164,7 +164,7 @@ type CueReference = // ** FromYaml - static member FromYaml(yaml: CueReferenceYaml) : Either = + static member FromYaml(yaml: CueReferenceYaml) : DiscoResult = yaml.ToCueReference() #endif diff --git a/src/Disco/Disco/Core/Discovery.fs b/src/Disco/Disco/Core/Discovery.fs index 14866e5a..cc85d9f5 100644 --- a/src/Disco/Disco/Core/Discovery.fs +++ b/src/Disco/Disco/Core/Discovery.fs @@ -61,12 +61,12 @@ type ServiceType = try str |> ServiceType.Parse - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asParseError "ServiceType.TryParse" - |> Either.fail + |> Result.fail // ** ToOffset @@ -83,26 +83,26 @@ type ServiceType = static member FromFB(fb: ExposedServiceTypeFB) = #if FABLE_COMPILER match fb with - | x when x = ExposedServiceTypeFB.GitFB -> Right Git - | x when x = ExposedServiceTypeFB.RaftFB -> Right Raft - | x when x = ExposedServiceTypeFB.HttpFB -> Right Http - | x when x = ExposedServiceTypeFB.ApiFB -> Right Api - | x when x = ExposedServiceTypeFB.WebSocketFB -> Right WebSocket + | x when x = ExposedServiceTypeFB.GitFB -> Ok Git + | x when x = ExposedServiceTypeFB.RaftFB -> Ok Raft + | x when x = ExposedServiceTypeFB.HttpFB -> Ok Http + | x when x = ExposedServiceTypeFB.ApiFB -> Ok Api + | x when x = ExposedServiceTypeFB.WebSocketFB -> Ok WebSocket | x -> sprintf "Unknown ExposedServiceTypeFB value: %d" x |> Error.asParseError "ServiceType.FromFB" - |> Either.fail + |> Result.fail #else match fb with - | ExposedServiceTypeFB.GitFB -> Right Git - | ExposedServiceTypeFB.RaftFB -> Right Raft - | ExposedServiceTypeFB.HttpFB -> Right Http - | ExposedServiceTypeFB.ApiFB -> Right Api - | ExposedServiceTypeFB.WebSocketFB -> Right WebSocket + | ExposedServiceTypeFB.GitFB -> Ok Git + | ExposedServiceTypeFB.RaftFB -> Ok Raft + | ExposedServiceTypeFB.HttpFB -> Ok Http + | ExposedServiceTypeFB.ApiFB -> Ok Api + | ExposedServiceTypeFB.WebSocketFB -> Ok WebSocket | x -> sprintf "Unknown ExposedServiceTypeFB value: %O" x |> Error.asParseError "ServiceType.FromFB" - |> Either.fail + |> Result.fail #endif @@ -148,7 +148,7 @@ type ExposedService = // ** FromFB static member FromFB (fb: ExposedServiceFB) = - either { + result { let! tipe = ServiceType.FromFB fb.Type return { ServiceType = tipe; Port = port fb.Port } } @@ -341,20 +341,20 @@ type DiscoveredService = // ** FromFB static member FromFB(fb: DiscoveredServiceFB) = - either { + result { let! protocol = match fb.Protocol with - | "IPv4" -> Right IPProtocol.IPv4 - | "IPv6" -> Right IPProtocol.IPv6 + | "IPv4" -> Ok IPProtocol.IPv4 + | "IPv6" -> Ok IPProtocol.IPv6 | other -> "Unknown protocol: " + other |> Error.asParseError "Discovery.FromFB" - |> Either.fail + |> Result.fail let! metadata = let arr = Array.zeroCreate fb.ExtraMetadataLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (idx, props) = m #if FABLE_COMPILER @@ -368,28 +368,28 @@ type DiscoveredService = else "Unable to parse empty Property value" |> Error.asParseError "DiscoveredService.FromFB" - |> Either.fail + |> Result.fail #endif props.[idx] <- prop return (idx + 1, props) }) - (Right(0, arr)) + (Ok(0, arr)) arr - |> Either.map snd + |> Result.map snd let! addressList = let arr = Array.zeroCreate fb.AddressListLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (idx, addresses) = m let! ip = fb.AddressList(idx) |> IpAddress.TryParse addresses.[idx] <- ip return (idx + 1, addresses) }) - (Right(0, arr)) + (Ok(0, arr)) arr - |> Either.map snd + |> Result.map snd let aliases = [| for i = 0 to fb.AliasesLength - 1 do @@ -407,13 +407,13 @@ type DiscoveredService = else "Unable to parse empty ServiceStatus" |> Error.asParseError "DiscoveredService.FromFB" - |> Either.fail + |> Result.fail #endif let! services = let arr = Array.zeroCreate fb.ServicesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (idx, services) = m #if FABLE_COMPILER @@ -427,15 +427,15 @@ type DiscoveredService = else "Unable to parse empty ExposedService key/value" |> Error.asParseError "DiscoveryService.FromFB" - |> Either.fail + |> Result.fail #endif services.[idx] <- service return (idx + 1, services) }) - (Right(0, arr)) + (Ok(0, arr)) arr - |> Either.map snd + |> Result.map snd let! id = Id.decodeId fb @@ -580,11 +580,11 @@ module Discovery = #if FABLE_COMPILER let prt = try Some(uint16 item.ValueString) with | _ -> None match ServiceType.TryParse item.Key, prt with - | Right st, (true, prt) -> Some { ServiceType = st; Port = port prt } + | Ok st, (true, prt) -> Some { ServiceType = st; Port = port prt } | _ -> None #else match ServiceType.TryParse item.Key, UInt16.TryParse item.ValueString with - | Right st, (true, prt) -> Some { ServiceType = st; Port = port prt } + | Ok st, (true, prt) -> Some { ServiceType = st; Port = port prt } | _ -> None #endif @@ -607,22 +607,22 @@ module Discovery = let private parseMachine (txt: ITxtRecord) = match parseFieldWith (|Machine|_|) txt with - | Some id -> id |> DiscoId.Parse |> Either.succeed + | Some id -> id |> DiscoId.Parse |> Result.succeed | _ -> "Could not find machine id in metatdata" |> Error.asParseError (tag "parseMachine") - |> Either.fail + |> Result.fail // ** parseProtocol let private parseProtocol (proto: AddressProtocol) = match proto with - | AddressProtocol.IPv4 -> Either.succeed IPv4 - | AddressProtocol.IPv6 -> Either.succeed IPv6 + | AddressProtocol.IPv4 -> Result.succeed IPv4 + | AddressProtocol.IPv6 -> Result.succeed IPv6 | x -> "AddressProtocol could not be parsed: " + string x |> Error.asParseError (tag "parseProtocol") - |> Either.fail + |> Result.fail // ** parseStatus @@ -632,14 +632,14 @@ module Discovery = let rawstatus = parseFieldWith (|Status|_|) record match rawstatus, rawid, rawname with - | Some MachineStatus.IDLE, _, _ -> Right Idle + | Some MachineStatus.IDLE, _, _ -> Ok Idle | Some MachineStatus.BUSY, Some id, Some parsed when not (isNull id) && not (isNull parsed) -> - Busy (DiscoId.Parse id, name parsed) |> Either.succeed + Busy (DiscoId.Parse id, name parsed) |> Result.succeed | _, _, _ -> "Failed to parse Machine status: field(s) missing or null" |> Error.asParseError (tag "parseStatus") - |> Either.fail + |> Result.fail // ** reservedField @@ -701,7 +701,7 @@ module Discovery = // ** toDiscoveredService let toDiscoveredService (service: IResolvableService) = - either { + result { let entry = service.HostEntry let! proto = parseProtocol service.AddressProtocol diff --git a/src/Disco/Disco/Core/Either.fs b/src/Disco/Disco/Core/Either.fs index 9463c940..96806040 100644 --- a/src/Disco/Disco/Core/Either.fs +++ b/src/Disco/Disco/Core/Either.fs @@ -9,74 +9,61 @@ namespace Disco.Core open System -// * Either Type - -// _____ _ _ _ -// | ____(_) |_| |__ ___ _ __ -// | _| | | __| '_ \ / _ \ '__| -// | |___| | |_| | | | __/ | -// |_____|_|\__|_| |_|\___|_| - -type Either<'err,'a> = - | Right of 'a - | Left of 'err - -// * Either Module +// * Result Module [] -[] -module Either = +module Result = // ** ofNullable // FB types are not modeled with nullables in JS #if FABLE_COMPILER let ofNullable (v: 'T) (er: string -> 'Err) = - Right v + Ok v #else let ofNullable (v: Nullable<'T>) (er: string -> 'Err) = if v.HasValue - then Right v.Value - else "Item has no value" |> er |> Left + then Ok v.Value + else "Item has no value" |> er |> Error #endif // ** succeed - /// ## lift a regular value into Either + /// ## lift a regular value into Result /// /// ### Signature: - /// - v: value to lift into Either + /// - v: value to lift into Result /// - /// Returns: Either<^err, ^t> - let succeed v = Right v + /// Returns: Result<^err, ^t> + let succeed v = Ok v // ** fail - /// ## lift an error value into Either + /// ## lift an error value into Result /// /// ### Signature: - /// - v: error to lift into Either + /// - v: error to lift into Result /// - /// Returns: Either<^err, ^t> - let fail v = Left v + /// Returns: Result<^err, ^t> + let fail v = Error v // ** isFail - /// ## Check if Either is a failure + /// ## Check if Result is a failure /// - /// Check passed value of type Either<^err, ^t> for being a failure. + /// Check passed value of type Result<^err, ^t> for being a failure. /// /// ### Signature: /// - value: value to be checked /// /// Returns: bool let isFail = function - | Left _ -> true + | Error _ -> true | _ -> false // ** isSuccess - /// ## Check if Either value is a success + /// ## Check if Result value is a success /// /// Check the passed value for being a success constructor.g /// @@ -85,175 +72,116 @@ module Either = /// /// Returns: bool let isSuccess = function - | Right _ -> true + | Ok _ -> true | _ -> false // ** get - /// ## Extract success value from Either wrapper type + /// ## Extract success value from Result wrapper type /// /// Extracts the result of a computation from the wrapper - /// type. Crashes hard if the constructor is a Left (failure). + /// type. Crashes hard if the constructor is a Error (failure). /// /// ### Signature: - /// - value: Either<^err,^t> to extract result from + /// - value: Result<^err,^t> to extract result from /// /// Returns: ^t let get = function - | Right result -> result - | Left error -> - failwithf "Either: cannot get result from failure: %A" error + | Ok result -> result + | Error error -> + failwithf "Result: cannot get result from failure: %A" error // ** error - /// ## Extract the embedded error value from an Either + /// ## Extract the embedded error value from an Result /// - /// Extracts the embedded error value from the passed Either + /// Extracts the embedded error value from the passed Result /// wrapper. Crashed hard if the constructor was actually a success. /// /// ### Signature: - /// - value: value of type Either<^err,^t> to extract error from + /// - value: value of type Result<^err,^t> to extract error from /// /// Returns: ^err let error = function - | Left error -> error - | Right _ -> - failwith "Either: cannot get error from regular result" + | Error error -> error + | Ok _ -> + failwith "Result: cannot get error from regular result" // ** iter - let inline iter< ^a, ^err >(f: ^a -> unit) (a: Either< ^err, ^a >) = + let inline iter< ^a, ^err >(f: ^a -> unit) (a: Result< ^a,^err >) = match a with - | Right value -> f value - | Left _ -> () + | Ok value -> f value + | Error _ -> () // ** iterError - let inline iterError< ^a, ^err >(f: ^err -> unit) (a: Either< ^err, ^a >) = - match a with - | Left error -> f error - | Right _ -> () - - // ** unwrap - - /// Gets the value if it's successful and runs the provided function otherwise - let inline unwrap< ^a, ^err > (fail: ^err -> ^a) (a: Either< ^err, ^a >) = - match a with - | Right value -> value - | Left err -> fail err - - // ** bind - - /// ## Bind a function to the result of a computation - /// - /// Inspects the passed value `a` and applies the function `f` to - /// the embedded value, *if* `a` was a `Right` (or success). Errors - /// are just passed through. - /// - /// ### Signature: - /// - `f`: function to apply to the embedded value of `a` - /// - `a`: value of type Either<^err, ^t> to apply `f` to - /// - /// Returns: Either<^err, ^t> - let inline bind< ^a, ^b, ^err > - (f: ^a -> Either< ^err, ^b >) - (a: Either< ^err, ^a >) - : Either< ^err, ^b > = + let inline iterError< ^a, ^err >(f: ^err -> unit) (a: Result< ^a, ^err >) = match a with - | Right value -> f value - | Left err -> Left err - - // ** map + | Error error -> f error + | Ok _ -> () - /// ## Map over an embedded value - /// - /// Applies a function `f` to the inner value of `a`, *if* `a` - /// indeed is a `Right`. - /// - /// ### Signature: - /// - `f`: function to apply to the inner value of `a` - /// - `a`: value to extract and apply `f` to - /// - /// Returns: Either<^err, ^t> - let inline map< ^a, ^b, ^err > - (f: ^a -> ^b) - (a: Either< ^err, ^a >) - : Either< ^err, ^b > = - match a with - | Right value -> f value |> succeed - | Left error -> Left error + // ** bindArray - let bindArray(f: 'a -> Either<'err,'b>) (arr:'a[]): Either<'err,'b[]> = + let bindArray(f: 'a -> Result<'b,'err>) (arr:'a[]): Result<'b[],'err> = let mutable i = 0 let mutable error = None let arr2 = Array.zeroCreate arr.Length while i < arr.Length && Option.isNone error do match f arr.[i] with - | Right value -> arr2.[i] <- value; i <- i + 1 - | Left err -> error <- Some err + | Ok value -> arr2.[i] <- value; i <- i + 1 + | Error err -> error <- Some err match error with - | Some err -> Left err - | None -> Right arr2 + | Some err -> Error err + | None -> Ok arr2 - // ** mapError + // ** unwrap - /// ## Map over the embedded error value - /// - /// Inspects the passed value `a` and applies the function `f`, *if* - /// `a` is a `Left`. - /// - /// ### Signature: - /// - `f`: function to apply to the inner error value - /// - `a`: value of type Either<^err,^t> - /// - /// Returns: Either<^err, ^t> - let inline mapError< ^a, ^err1, ^err2 > - (f: ^err1 -> ^err2) - (a: Either< ^err1, ^a >) - : Either< ^err2, ^a> = + /// Gets the value if it's successful and runs the provided function otherwise + let inline unwrap< ^a, ^err > (fail: ^err -> ^a) (a: Result< ^a,^err >) = match a with - | Right value -> Right value - | Left error -> Left(f error) + | Ok value -> value + | Error err -> fail err // ** combine let inline combine< ^a, ^b, ^err > (v1 : ^a) - (v2 : Either< ^err, ^b >) - : Either< ^err, (^a * ^b) > = + (v2 : Result< ^b,^err >) + : Result< (^a * ^b),^err > = match v2 with - | Right value2 -> succeed (v1, value2) - | Left err -> Left err + | Ok value2 -> succeed (v1, value2) + | Error err -> Error err // ** ofOption - /// ## Transform an Option value into an Either + /// ## Transform an Option value into a Result /// /// Converts the passed value of type `'t option` into an - /// Either<^err, ^t>. If the passed value is a `None`, use the - /// provided error value in the `Left`. + /// Result<^t,^err>. If the passed value is a `None`, use the + /// provided error value in the `Error`. /// /// ### Signature: /// - err: error value to use when `a` is `None` /// - `a`: value to convert /// - /// Returns: Either<^err,^t> + /// Returns: Result<^t,^err> let inline ofOption< ^a, ^b, ^err > (err: ^err) (a: ^a option) - : Either< ^err, ^a > = + : Result< ^a,^err > = match a with - | Some value -> Right value - | None -> Left err + | Some value -> Ok value + | None -> Error err // ** nothing - let inline nothing< ^err > : Either< ^err,unit > = + let inline nothing< ^err > : Result = succeed () // ** ignore - let inline ignore< ^err > _ : Either< ^err, unit > = + let inline ignore< ^err > _ : Result = succeed () // ** tryWith @@ -261,7 +189,7 @@ module Either = let inline tryWith< ^a, ^err > (err: (string -> ^err)) (f: unit -> ^a) - : Either< ^err, ^a > = + : Result< ^a, ^err > = try f() |> succeed with @@ -274,56 +202,48 @@ module Either = // ** orElse let inline orElse value = function - | Right _ as good -> good - | Left _ -> Right value + | Ok _ as good -> good + | Error _ -> Ok value // ** defaultValue let defaultValue def = function - | Right value -> value - | Left _ -> def - -// * Either Builder + | Ok value -> value + | Error _ -> def -// _____ _ _ _ ____ _ _ _ -// | ____(_) |_| |__ ___ _ __ | __ ) _ _(_) | __| | ___ _ __ -// | _| | | __| '_ \ / _ \ '__| | _ \| | | | | |/ _` |/ _ \ '__| -// | |___| | |_| | | | __/ | | |_) | |_| | | | (_| | __/ | -// |_____|_|\__|_| |_|\___|_| |____/ \__,_|_|_|\__,_|\___|_| +// * Result Builder [] -module EitherUtils = +module ResultUtils = - type EitherBuilder() = + type ResultBuilder() = - member self.Return(v: 'a): Either<'err, 'a> = Right v + member self.Return(v: 'a): Result<'a,'err> = Ok v - member self.ReturnFrom(v: Either<'err, 'a>): Either<'err, 'a> = v + member self.ReturnFrom(v: Result<'a,'err>): Result<'a,'err> = v - member self.Bind(m: Either<'err, 'a>, f: 'a -> Either<'err, 'b>): Either<'err, 'b> = - match m with - | Right value -> f value - | Left err -> Left err + member self.Bind(m: Result<'a,'err>, f: 'a -> Result<'b,'err>): Result<'b,'err> = + Result.bind f m - member self.Zero(): Either<'err, unit> = Right () + member self.Zero(): Result = Ok () - member self.Delay(f: unit -> Either<'err, 'a>) = f + member self.Delay(f: unit -> Result<'a,'err>) = f - member self.Run(f: unit -> Either<'err, 'a>) = f() + member self.Run(f: unit -> Result<'a,'err>) = f() - member self.While(guard: unit -> bool, body: unit -> Either<'err, unit>): Either<'err, unit> = + member self.While(guard: unit -> bool, body: unit -> Result): Result = if guard () then self.Bind(body(), fun () -> self.While(guard, body)) else self.Zero() - member self.For(sequence:seq<'a>, body: 'a -> Either<'err, unit>): Either<'err, unit> = + member self.For(sequence:seq<'a>, body: 'a -> Result): Result = self.Using(sequence.GetEnumerator(), fun enum -> self.While(enum.MoveNext, fun () -> body enum.Current)) member self.Combine(a, b) = match a with - | Right _ -> a - | Left _ -> b + | Ok _ -> a + | Error _ -> b member self.TryWith(body, handler) = try body() |> self.ReturnFrom @@ -336,17 +256,17 @@ module EitherUtils = handler () member self.Using<'a, 'b, 'err when 'a :> IDisposable> - (disposable: 'a, body: 'a -> Either<'err, 'b>): Either<'err, 'b> = + (disposable: 'a, body: 'a -> Result<'b,'err>): Result<'b,'err> = let body' = fun () -> body disposable self.TryFinally(body', fun () -> disposable.Dispose()) - let either = EitherBuilder() + let result = ResultBuilder() #if INTERACTIVE module Test = - open EitherUtils + open ResultUtils type DisposableAction(f) = interface IDisposable with @@ -360,15 +280,15 @@ module Test = let orFail x = match x with - | Left err -> printfn "ERROR: %O" err - | Right v -> printfn "OK: %O" v + | Error err -> printfn "ERROR: %O" err + | Ok v -> printfn "OK: %O" v let riskyOp x = printfn "Evaluating %O..." x - if x = 0 then Left "boom!" else Right () + if x = 0 then Error "boom!" else Ok () let test() = - let test = either { + let test = result { printfn "This should be lazy but it's evaluated eagerly" let ar = [|1;2;0;3|] let mutable i = 0 @@ -381,13 +301,13 @@ module Test = orFail test // No problem here - either { + result { for x in [1;2;3] do do! riskyOp x } |> orFail // Boom! - either { + result { for x in [|1;2;0;3|] do do! riskyOp x } |> orFail @@ -396,10 +316,10 @@ module Test = let isDisposed = ref false let step1ok = ref false let step2ok = ref false - let resource = either { + let resource = result { return new DisposableAction(fun () -> isDisposed := true) } - either { + result { use! r = resource step1ok := not !isDisposed } |> ignore @@ -434,4 +354,4 @@ module OptionUtils = member __.Run (f) = f() - let maybe = new MaybeBuilder() + let maybe = MaybeBuilder() diff --git a/src/Disco/Disco/Core/Error.fs b/src/Disco/Disco/Core/Error.fs index d39025d5..1c59decd 100644 --- a/src/Disco/Disco/Core/Error.fs +++ b/src/Disco/Disco/Core/Error.fs @@ -87,35 +87,35 @@ type DiscoError = static member FromFB (fb: ErrorFB) = match fb.Type with #if FABLE_COMPILER - | x when x = ErrorTypeFB.OKFB -> Right OK - | x when x = ErrorTypeFB.OtherFB -> Right (Other (fb.Location,fb.Message)) - | x when x = ErrorTypeFB.GitErrorFB -> Right (GitError (fb.Location,fb.Message)) - | x when x = ErrorTypeFB.ProjectErrorFB -> Right (ProjectError (fb.Location,fb.Message)) - | x when x = ErrorTypeFB.AssetErrorFB -> Right (AssetError (fb.Location,fb.Message)) - | x when x = ErrorTypeFB.RaftErrorFB -> Right (RaftError (fb.Location,fb.Message)) - | x when x = ErrorTypeFB.ParseErrorFB -> Right (ParseError (fb.Location,fb.Message)) - | x when x = ErrorTypeFB.SocketErrorFB -> Right (SocketError (fb.Location,fb.Message)) - | x when x = ErrorTypeFB.ClientErrorFB -> Right (ClientError (fb.Location,fb.Message)) - | x when x = ErrorTypeFB.IOErrorFB -> Right (IOError (fb.Location,fb.Message)) + | x when x = ErrorTypeFB.OKFB -> Ok OK + | x when x = ErrorTypeFB.OtherFB -> Ok (Other (fb.Location,fb.Message)) + | x when x = ErrorTypeFB.GitErrorFB -> Ok (GitError (fb.Location,fb.Message)) + | x when x = ErrorTypeFB.ProjectErrorFB -> Ok (ProjectError (fb.Location,fb.Message)) + | x when x = ErrorTypeFB.AssetErrorFB -> Ok (AssetError (fb.Location,fb.Message)) + | x when x = ErrorTypeFB.RaftErrorFB -> Ok (RaftError (fb.Location,fb.Message)) + | x when x = ErrorTypeFB.ParseErrorFB -> Ok (ParseError (fb.Location,fb.Message)) + | x when x = ErrorTypeFB.SocketErrorFB -> Ok (SocketError (fb.Location,fb.Message)) + | x when x = ErrorTypeFB.ClientErrorFB -> Ok (ClientError (fb.Location,fb.Message)) + | x when x = ErrorTypeFB.IOErrorFB -> Ok (IOError (fb.Location,fb.Message)) | x -> ("DiscoError.FromFB", sprintf "Could not parse unknown ErrorTypeFB: %A" x) |> ParseError - |> Either.fail + |> Result.fail #else - | ErrorTypeFB.OKFB -> Right OK - | ErrorTypeFB.OtherFB -> Right (Other (fb.Location,fb.Message)) - | ErrorTypeFB.GitErrorFB -> Right (GitError (fb.Location,fb.Message)) - | ErrorTypeFB.ProjectErrorFB -> Right (ProjectError (fb.Location,fb.Message)) - | ErrorTypeFB.AssetErrorFB -> Right (AssetError (fb.Location,fb.Message)) - | ErrorTypeFB.RaftErrorFB -> Right (RaftError (fb.Location,fb.Message)) - | ErrorTypeFB.ParseErrorFB -> Right (ParseError (fb.Location,fb.Message)) - | ErrorTypeFB.SocketErrorFB -> Right (SocketError (fb.Location,fb.Message)) - | ErrorTypeFB.ClientErrorFB -> Right (ClientError (fb.Location,fb.Message)) - | ErrorTypeFB.IOErrorFB -> Right (IOError (fb.Location,fb.Message)) + | ErrorTypeFB.OKFB -> Ok OK + | ErrorTypeFB.OtherFB -> Ok (Other (fb.Location,fb.Message)) + | ErrorTypeFB.GitErrorFB -> Ok (GitError (fb.Location,fb.Message)) + | ErrorTypeFB.ProjectErrorFB -> Ok (ProjectError (fb.Location,fb.Message)) + | ErrorTypeFB.AssetErrorFB -> Ok (AssetError (fb.Location,fb.Message)) + | ErrorTypeFB.RaftErrorFB -> Ok (RaftError (fb.Location,fb.Message)) + | ErrorTypeFB.ParseErrorFB -> Ok (ParseError (fb.Location,fb.Message)) + | ErrorTypeFB.SocketErrorFB -> Ok (SocketError (fb.Location,fb.Message)) + | ErrorTypeFB.ClientErrorFB -> Ok (ClientError (fb.Location,fb.Message)) + | ErrorTypeFB.IOErrorFB -> Ok (IOError (fb.Location,fb.Message)) | x -> ("DiscoError.FromFB", sprintf "Could not parse unknown ErrotTypeFB: %A" x) |> ParseError - |> Either.fail + |> Result.fail #endif // ** ToOffset @@ -167,6 +167,10 @@ type DiscoError = +// * DiscoResult + +type DiscoResult<'t> = Result<'t,DiscoError> + // * Error Module [] module Error = @@ -267,10 +271,10 @@ module Error = /// - `a`: value to apply function /// /// Returns: ^b - let inline orExit (f: ^a -> ^b) (a: Either< DiscoError, ^a>) : ^b = + let inline orExit (f: ^a -> ^b) (a: DiscoResult< ^a >) : ^b = match a with - | Right value -> f value - | Left error -> exitWith error + | Ok value -> f value + | Error error -> exitWith error let asGitError loc err = GitError(loc,err) let asProjectError loc err = ProjectError(loc,err) diff --git a/src/Disco/Disco/Core/FileSystem.fs b/src/Disco/Disco/Core/FileSystem.fs index 81a54e34..d1f9fbf3 100644 --- a/src/Disco/Disco/Core/FileSystem.fs +++ b/src/Disco/Disco/Core/FileSystem.fs @@ -94,20 +94,20 @@ type FsPath = // ** FromFB static member FromFB(fb: FsPathFB) = - either { + result { let! platform = Platform.FromFB fb.Platform let drive = Convert.ToChar fb.Drive let! elements = if fb.ElementsLength > 0 then Array.fold - (fun (lst:Either) idx -> either { + (fun (lst:DiscoResult) idx -> result { let! elms = lst let elm = fb.Elements idx return elm :: elms }) - (Right List.empty) + (Ok List.empty) [| 0 .. fb.ElementsLength - 1 |] - else Either.succeed List.empty + else Result.succeed List.empty return { Drive = drive Platform = platform @@ -121,7 +121,7 @@ type FsPath = // ** FromBytes - static member FromBytes (bytes: byte array) : Either = + static member FromBytes (bytes: byte array) : DiscoResult = bytes |> Binary.createBuffer |> FsPathFB.GetRootAsFsPathFB @@ -240,7 +240,7 @@ type FsEntry = // ** FromEntryFB static member FromEntryFB(fb: FsInfoFB) = - either { + result { let! path = #if FABLE_COMPILER FsPath.FromFB fb.Path @@ -252,7 +252,7 @@ type FsEntry = else "Cannot parse empty path value" |> Error.asParseError "FsTree.toEntry" - |> Either.fail + |> Result.fail #endif let info = { Path = path @@ -278,7 +278,7 @@ type FsEntry = other |> sprintf "%A is not a known FsEntry type" |> Error.asParseError "FsTree.toEntry" - |> Either.fail + |> Result.fail } // ** ToOffset @@ -307,7 +307,7 @@ type FsEntry = // ** FromFB static member FromFB(fb:FsEntryFB) = - either { + result { let! root = #if FABLE_COMPILER FsEntry.FromEntryFB fb.Root @@ -319,7 +319,7 @@ type FsEntry = else "Could not parse empty FsEntry root value" |> Error.asParseError "FsEntry.FromFB" - |> Either.fail + |> Result.fail #endif match root with @@ -328,7 +328,7 @@ type FsEntry = | FsEntry.Directory _ -> return! List.fold - (fun (m:Either) idx -> either { + (fun (m:DiscoResult) idx -> result { let! lst = m let! child = #if FABLE_COMPILER @@ -343,18 +343,18 @@ type FsEntry = else "Could not parse empty child value" |> Error.asParseError "FsEntry.FromFB" - |> Either.fail + |> Result.fail #endif return child :: lst }) - (Right List.empty) + (Ok List.empty) [ 0 .. fb.ChildrenLength - 1 ] - |> Either.map (List.rev >> FsEntry.inflate root) + |> Result.map (List.rev >> FsEntry.inflate root) } // ** FromBytes - static member FromBytes (bytes: byte array) : Either = + static member FromBytes (bytes: byte array) : DiscoResult = bytes |> Binary.createBuffer |> FsEntryFB.GetRootAsFsEntryFB @@ -433,7 +433,7 @@ type FsTree = // ** FromBytes - static member FromBytes (bytes: byte array) : Either = + static member FromBytes (bytes: byte array) : DiscoResult = bytes |> Binary.createBuffer |> FsTreeFB.GetRootAsFsTreeFB @@ -446,7 +446,7 @@ type FsTree = // ** FromFB static member FromFB(fb:FsTreeFB) = - either { + result { let! hostId = Id.decodeHostId fb let filters = fb.Filters.Split(' ') @@ -462,11 +462,11 @@ type FsTree = else "Could not parse empty root" |> Error.asParseError "FsTree.FromtFB" - |> Either.fail + |> Result.fail #endif let! children = Array.fold - (fun (m:Either) idx -> either { + (fun (m:DiscoResult) idx -> result { let! list = m let! child = #if FABLE_COMPILER @@ -481,11 +481,11 @@ type FsTree = else "Could not parse empty child" |> Error.asParseError "FsTree.FromFB" - |> Either.fail + |> Result.fail #endif return child :: list }) - (Right List.empty) + (Ok List.empty) [| 0 .. fb.ChildrenLength - 1 |] return children @@ -744,11 +744,11 @@ module File = path |> unwrap |> File.Delete - |> Either.succeed + |> Result.succeed with exn -> exn.Message |> Error.asIOError (tag "delete") - |> Either.fail + |> Result.fail // ** ensurePath @@ -757,11 +757,11 @@ module File = path |> Path.getDirectoryName |> Directory.createDirectory - |> Either.ignore + |> Result.ignore with exn -> exn.Message |> Error.asIOError (tag "ensurePath") - |> Either.fail + |> Result.fail #endif @@ -782,18 +782,18 @@ module Directory = /// Create a new directory. Upon failure, return an DiscoError /// /// FilePath - /// Either + /// DiscoResult let createDirectory (path: FilePath) = try path |> unwrap |> Directory.CreateDirectory - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asIOError (tag "createDirectory") - |> Either.fail + |> Result.fail // ** removeDirectory @@ -801,11 +801,11 @@ module Directory = try unwrap path |> Directory.Delete - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asIOError (tag "removeDirectory") - |> Either.fail + |> Result.fail // ** info @@ -921,8 +921,8 @@ module FileSystem = /// ### Signature: /// - path: FilePath to delete /// - /// Returns: Either - let rec rmDir (path: FilePath) : Either = + /// Returns: DiscoResult + let rec rmDir (path: FilePath) : DiscoResult = try let info = new FileInfo(unwrap path) info.IsReadOnly <- false @@ -930,28 +930,28 @@ module FileSystem = if (attrs &&& FileAttributes.Directory) = FileAttributes.Directory then let children = DirectoryInfo(unwrap path).EnumerateFileSystemInfos() if children.Count() > 0 then - either { + result { do! Seq.fold - (fun (_: Either) (child: FileSystemInfo) -> either { + (fun (_: DiscoResult) (child: FileSystemInfo) -> result { return! child.FullName |> filepath |> rmDir }) - (Right ()) + (Ok ()) children return Directory.Delete(unwrap path) } else Directory.Delete(unwrap path) - |> Either.succeed + |> Result.succeed else path |> unwrap |> File.Delete - |> Either.succeed + |> Result.succeed with | exn -> ("FileSystem.rmDir", exn.Message) |> IOError - |> Either.fail + |> Result.fail #endif @@ -995,7 +995,7 @@ module FileSystem = /// ### Signature: /// - path: FilePath /// - /// Returns: Either + /// Returns: DiscoResult let mkDir (path: FilePath) = try if path |> unwrap |> Directory.Exists |> not then @@ -1003,14 +1003,14 @@ module FileSystem = |> unwrap |> Directory.CreateDirectory |> ignore - |> Either.succeed + |> Result.succeed else - Either.succeed () + Result.succeed () with | exn -> ("FileSystem.mkDir", exn.Message) |> IOError - |> Either.fail + |> Result.fail #endif @@ -1026,9 +1026,9 @@ module FileSystem = /// - source: FilePath /// - target: FilePath /// - /// Returns: Either + /// Returns: DiscoResult - let rec copyDir (source: FilePath) (target: FilePath) : Either = + let rec copyDir (source: FilePath) (target: FilePath) : DiscoResult = try let source = Directory.info source @@ -1046,12 +1046,12 @@ module FileSystem = let destpath = filepath target.FullName filepath dir.Name copyDir (filepath dir.FullName) destpath |> ignore - Either.succeed () + Result.succeed () with | exn -> ("FileSystem.mkDir", exn.Message) |> IOError - |> Either.fail + |> Result.fail #endif @@ -1509,13 +1509,13 @@ module FsTree = basePath |> sprintf "%A was not found or is not a directory" |> Error.asAssetError "FsTree" - |> Either.fail - either { + |> Result.fail + result { let! root = if Directory.exists basePath then let path = FsPath.parse basePath match FsEntry.create path with - | Some root -> Right root + | Some root -> Ok root | None -> notFound() else notFound() return { @@ -1680,11 +1680,11 @@ module FsTree = |> List.choose id |> inflate host root |> setFilters filters - |> Either.succeed + |> Result.succeed | None -> "Could not parse root entry: does the directory exist?" |> Error.asIOError "FsTree.read" - |> Either.fail + |> Result.fail #endif @@ -1739,7 +1739,7 @@ module FsTreeTesting = fp |> File.readBytes |> Binary.decode - |> Either.get + |> Result.get let roundTrip dirCount fileCount = let fp = Path.getTempFile() diff --git a/src/Disco/Disco/Core/Git.fs b/src/Disco/Disco/Core/Git.fs index 6a9113c4..eee2f353 100644 --- a/src/Disco/Disco/Core/Git.fs +++ b/src/Disco/Disco/Core/Git.fs @@ -80,12 +80,12 @@ module Git = url |> Repository.ListRemoteReferences |> Seq.cast - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "lsRemote") - |> Either.fail + |> Result.fail // ** Branch module @@ -119,12 +119,12 @@ module Git = let create (name: string) (repo: Repository) = try repo.CreateBranch(name) - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "create") - |> Either.fail + |> Result.fail // *** current @@ -147,14 +147,14 @@ module Git = /// ### Signature: /// - branch: Branch /// - /// Returns: Either - let tracked (branch: Branch) : Either = + /// Returns: Result + let tracked (branch: Branch) : DiscoResult = match branch.TrackedBranch with | null -> "No tracked branch" |> Error.asGitError (tag "tracked") - |> Either.fail - | branch -> Either.succeed branch + |> Result.fail + | branch -> Result.succeed branch // *** tracking @@ -166,13 +166,13 @@ module Git = /// - branch: Branch to get details for /// /// Returns: BranchTrackingDetails option - let tracking (branch: Branch) : Either = + let tracking (branch: Branch) : DiscoResult = match branch.TrackingDetails with | null -> "No tracked branch" |> Error.asGitError (tag "tracking") - |> Either.fail - | details -> Either.succeed details + |> Result.fail + | details -> Result.succeed details // *** tip @@ -310,7 +310,7 @@ module Git = /// - remote: string /// - upstream: string /// - /// Returns: Either + /// Returns: DiscoResult let setTracked (repo: Repository) (branch: Branch) (remote: Remote) = try @@ -318,12 +318,12 @@ module Git = updater.Remote <- remote.Name updater.UpstreamBranch <- branch.CanonicalName repo.Branches.Update (branch, setRemote) - |> Either.ignore + |> Result.ignore with | exn -> exn.Message |> Error.asGitError (tag "setTracked") - |> Either.fail + |> Result.fail // ** Repo @@ -396,12 +396,12 @@ module Git = let setReceivePackConfig (repo: Repository) = try repo.Config.Set("receive.denyCurrentBranch", "updateInstead") - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "setReceivePackConfig") - |> Either.fail + |> Result.fail #endif @@ -415,10 +415,10 @@ module Git = /// - target: FilePath to target directory /// - remote: string specifiying the remote repository address /// - /// Returns: Either + /// Returns: DiscoResult let clone (target: FilePath) (remote: string) = try - either { + result { let path = Repository.Clone(remote, unwrap target) let repo = new Repository(path) do! setReceivePackConfig repo @@ -427,7 +427,7 @@ module Git = | exn -> exn.Message |> Error.asGitError (tag "clone") - |> Either.fail + |> Result.fail // *** branches @@ -484,12 +484,12 @@ module Git = let reset (opts: ResetMode) (repo: Repository) = try repo.Reset opts - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "reset") - |> Either.fail + |> Result.fail // *** resetTo @@ -506,12 +506,12 @@ module Git = let resetTo (opts: ResetMode) (commit: Commit) (repo: Repository) = try repo.Reset(opts, commit) - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "resetTo") - |> Either.fail + |> Result.fail // *** clean @@ -628,8 +628,8 @@ module Git = spec |> String.format "{0} not found" |> Error.asGitError (tag "checkout") - |> Either.fail - | branch -> Either.succeed branch + |> Result.fail + | branch -> Result.succeed branch // *** repository @@ -641,7 +641,7 @@ module Git = /// - path: FilePath to search for the .git folder /// /// Returns: Repository option - let repository (path: FilePath) : Either = + let repository (path: FilePath) : DiscoResult = try let normalized = if Path.endsWith ".git" path then @@ -650,17 +650,17 @@ module Git = path filepath ".git" new Repository(unwrap normalized) - |> Either.succeed + |> Result.succeed with | :? RepositoryNotFoundException as exn -> exn.Message |> String.format (unwrap path + ": {0}") |> Error.asGitError (tag "repository") - |> Either.fail + |> Result.fail | exn -> exn.Message |> Error.asGitError (tag "repository") - |> Either.fail + |> Result.fail // *** init @@ -671,7 +671,7 @@ module Git = /// ### Signature: /// - path: FilePath pointing to the target directory /// - /// Returns: Either,Repository> + /// Returns: DiscoResult let init (path: FilePath) = try Path.map Repository.Init path |> ignore @@ -680,7 +680,7 @@ module Git = | exn -> exn.Message |> Error.asGitError (tag "init") - |> Either.fail + |> Result.fail // *** add @@ -690,18 +690,18 @@ module Git = path |> String.format "Path must be relative to the project root: {0}" |> Error.asGitError (tag "add") - |> Either.fail + |> Result.fail else if File.exists path || Directory.exists path then runGit repo.Info.WorkingDirectory "add" "." "" - |> Either.ignore + |> Result.ignore else - Either.succeed () + Result.succeed () with | exn -> exn.Message |> Error.asGitError (tag "add") - |> Either.fail + |> Result.fail // *** stage @@ -709,17 +709,17 @@ module Git = try if Path.isPathRooted path && not (repo.Ignore.IsPathIgnored (unwrap path))then runGit repo.Info.WorkingDirectory "stage" "." "" - |> Either.ignore + |> Result.ignore else path |> String.format "Paths must be absolute: {0}" |> Error.asGitError (tag "stage") - |> Either.fail + |> Result.fail with | exn -> exn.Message |> Error.asGitError (tag "stage") - |> Either.fail + |> Result.fail // *** stageAll @@ -731,24 +731,24 @@ module Git = try repo.RetrieveStatus() |> Seq.iter _stage - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "stageAll") - |> Either.fail + |> Result.fail // *** commit let commit (repo: Repository) (msg: string) (committer: Signature) = try repo.Commit(msg, committer, committer) - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "commit") - |> Either.fail + |> Result.fail // *** status @@ -760,15 +760,15 @@ module Git = /// - repo: Repository to fetch status for /// /// Returns: RepositoryStatus - let status (repo: Repository) : Either = + let status (repo: Repository) : DiscoResult = try repo.RetrieveStatus() - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "status") - |> Either.fail + |> Result.fail // *** isDirty @@ -780,8 +780,8 @@ module Git = /// - repo: Repository to check /// /// Returns: boolean - let isDirty (repo: Repository) : Either = - either { + let isDirty (repo: Repository) : DiscoResult = + result { let! status = status repo return status.IsDirty } @@ -796,8 +796,8 @@ module Git = /// - repo: Repository /// /// Returns: seq - let untracked (repo: Repository) : Either> = - either { + let untracked (repo: Repository) : DiscoResult> = + result { let! status = status repo return status.Untracked } @@ -827,15 +827,15 @@ module Git = /// - t: IQueryableCommitLog /// /// Returns: Commit - let elementAt (idx: int) (t: IQueryableCommitLog) : Either = + let elementAt (idx: int) (t: IQueryableCommitLog) : DiscoResult = try t.ElementAt(idx) - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "elementAt") - |> Either.fail + |> Result.fail // *** commitCount @@ -859,12 +859,12 @@ module Git = let basepath = Path.GetDirectoryName repo.Info.Path branch.FriendlyName |> runGit basepath "push" remote.Name - |> Either.ignore + |> Result.ignore with | exn -> exn.Message |> Error.asGitError (tag "push") - |> Either.fail + |> Result.fail // *** pull @@ -876,11 +876,11 @@ module Git = /// - repo: Repository /// - remote: string /// - /// Returns: Either + /// Returns: DiscoResult let pull (repo: Repository) (signature: Signature) = try - either { + result { let options = let fopts = FetchOptions() let popts = PullOptions() @@ -896,7 +896,7 @@ module Git = | exn -> exn.Message |> Error.asGitError (tag "pull") - |> Either.fail + |> Result.fail // *** lsRemote @@ -905,12 +905,12 @@ module Git = remote |> repo.Network.ListReferences |> Seq.cast - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "lsRemote") - |> Either.fail + |> Result.fail // ** Config @@ -946,12 +946,12 @@ module Git = let addRemote (repo: Repository) (name: string) (url: Url) = try repo.Network.Remotes.Add(name, unwrap url) - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "addRemote") - |> Either.fail + |> Result.fail // *** updateRemote @@ -961,18 +961,18 @@ module Git = updater.Url <- unwrap url repo.Network.Remotes.Update(remote.Name, update) repo.Network.Remotes.[remote.Name] - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asGitError (tag "updateRemote") - |> Either.fail + |> Result.fail // *** delRemote - let delRemote (repo: Repository) (name: string) : Either = + let delRemote (repo: Repository) (name: string) : DiscoResult = repo.Network.Remotes.Remove name - |> Either.succeed + |> Result.succeed #endif @@ -1031,6 +1031,6 @@ repo.Network.Fetch("git@bitbucket.org:krgn/meh.git", ["master"], "hello") Commands.Pull(repo, User.Admin.Signature, options) -repo.Network.Push(fix_issue |> Either.get) +repo.Network.Push(fix_issue |> Result.get) #endif diff --git a/src/Disco/Disco/Core/Id.fs b/src/Disco/Disco/Core/Id.fs index ad4908ff..278160c9 100644 --- a/src/Disco/Disco/Core/Id.fs +++ b/src/Disco/Disco/Core/Id.fs @@ -56,11 +56,11 @@ type DiscoId = // ** TryParse static member TryParse (str: string) = - try DiscoId.Parse str |> Either.succeed + try DiscoId.Parse str |> Result.succeed with exn -> exn.Message |> Error.asParseError "DiscoId" - |> Either.fail + |> Result.fail // ** FromGuid @@ -127,7 +127,7 @@ module Id = [| 0 .. 15 |] |> Array.map t |> DiscoId.FromByteArray - |> Either.succeed + |> Result.succeed let inline decodeId (fb: ^t) = (fun idx -> (^t : (member Id: int -> byte) fb, idx)) diff --git a/src/Disco/Disco/Core/Interfaces.fs b/src/Disco/Disco/Core/Interfaces.fs index d02ddb80..3532555d 100644 --- a/src/Disco/Disco/Core/Interfaces.fs +++ b/src/Disco/Disco/Core/Interfaces.fs @@ -103,7 +103,6 @@ type DiscoEvent = | EnterJointConsensus of changes:ConfigChange array | LeaderChanged of leader:MemberId option | StateChanged of oldstate:MemberState * newstate:MemberState - | PersistSnapshot of log:RaftLogEntry | RaftError of error:DiscoError | Status of ServiceStatus | GitPull of remote:IpAddress @@ -122,7 +121,6 @@ type DiscoEvent = | EnterJointConsensus _ -> "EnterJointConsensus" | LeaderChanged _ -> "LeaderChanged" | StateChanged _ -> "StateChanged" - | PersistSnapshot _ -> "PersistSnapshot" | RaftError _ -> "RaftError" | Status _ -> "Status" | SessionOpened _ -> "SessionOpened" @@ -142,7 +140,6 @@ type DiscoEvent = | EnterJointConsensus _ | LeaderChanged _ | StateChanged _ - | PersistSnapshot _ | RaftError _ | SessionOpened _ | SessionClosed _ @@ -166,7 +163,6 @@ type DiscoEvent = // | _| | | | __/___) | |_| \__ \ || __/ | | | | | // |_| |_|_|\___|____/ \__, |___/\__\___|_| |_| |_| // |___/ - | FileSystem _ -> Ignore // ____ __ _ @@ -174,12 +170,10 @@ type DiscoEvent = // | |_) / _` | |_| __| // | _ < (_| | _| |_ // |_| \_\__,_|_| \__| - | ConfigurationDone _ | EnterJointConsensus _ | StateChanged _ | LeaderChanged _ - | PersistSnapshot _ | RaftError _ -> Process // ____ _ _ @@ -187,7 +181,6 @@ type DiscoEvent = // | | _| | __| // | |_| | | |_ // \____|_|\__| - | GitPull _ | GitPush _ -> Process @@ -196,7 +189,6 @@ type DiscoEvent = // \ \ /\ / / _ \ '_ \___ \ / _ \ / __| |/ / _ \ __| // \ V V / __/ |_) |__) | (_) | (__| < __/ |_ // \_/\_/ \___|_.__/____/ \___/ \___|_|\_\___|\__| - | SessionOpened _ | SessionClosed _ -> Replicate @@ -209,7 +201,6 @@ type DiscoEvent = // | _ \ / _` | __/ __| '_ \ // | |_) | (_| | || (__| | | | // |____/ \__,_|\__\___|_| |_| - | Append (Origin.Client _, CommandBatch _) | Append (Origin.Service _, CommandBatch _) | Append (Origin.Web _, CommandBatch _) -> Replicate @@ -220,7 +211,6 @@ type DiscoEvent = // | | | | (_| | |_) | |_) | | | | | (_| | // |_| |_|\__,_| .__/| .__/|_|_| |_|\__, | // |_| |_| |___/ - | Append (Origin.Client _, AddPinMapping _) | Append (Origin.Service _, AddPinMapping _) | Append (Origin.Web _, AddPinMapping _) @@ -237,7 +227,6 @@ type DiscoEvent = // \ V V / | | (_| | (_| | __/ |_ // \_/\_/ |_|\__,_|\__, |\___|\__| // |___/ - | Append (Origin.Client _, AddPinWidget _) | Append (Origin.Service _, AddPinWidget _) | Append (Origin.Web _, AddPinWidget _) @@ -254,7 +243,6 @@ type DiscoEvent = // | __/| | | (_) | | __/ (__| |_ // |_| |_| \___// |\___|\___|\__| // |__/ - | Append (Origin.Web _, UnloadProject) -> Replicate | Append (Origin.Client _, UnloadProject) -> Ignore | Append (Origin.Service _, UnloadProject) -> Replicate @@ -268,23 +256,33 @@ type DiscoEvent = // | |\/| |/ _ \ '_ ` _ \| '_ \ / _ \ '__| // | | | | __/ | | | | | |_) | __/ | // |_| |_|\___|_| |_| |_|_.__/ \___|_| + | Append (Origin.Web _, AddMachine _) -> Replicate + | Append (Origin.Web _, UpdateMachine _) -> Ignore + | Append (Origin.Web _, RemoveMachine _) -> Replicate + | Append (Origin.Client _, AddMachine _) + | Append (Origin.Client _, UpdateMachine _) + | Append (Origin.Client _, RemoveMachine _) -> Ignore + | Append (Origin.Service _, AddMachine _) + | Append (Origin.Service _, UpdateMachine _) + | Append (Origin.Service _, RemoveMachine _) -> Replicate - | Append (Origin.Web _, AddMember _) -> Replicate - | Append (Origin.Web _, UpdateMember _) -> Ignore - | Append (Origin.Web _, RemoveMember _) -> Replicate - | Append (Origin.Client _, AddMember _) - | Append (Origin.Client _, UpdateMember _) - | Append (Origin.Client _, RemoveMember _) -> Ignore + // __ __ _ + // | \/ | ___ _ __ ___ | |__ ___ _ __ + // | |\/| |/ _ \ '_ ` _ \| '_ \ / _ \ '__| + // | | | | __/ | | | | | |_) | __/ | + // |_| |_|\___|_| |_| |_|_.__/ \___|_| | Append (Origin.Service _, AddMember _) | Append (Origin.Service _, UpdateMember _) | Append (Origin.Service _, RemoveMember _) -> Replicate + | Append ( _, AddMember _) + | Append ( _, UpdateMember _) + | Append ( _, RemoveMember _) -> Ignore // ____ _ _ _ // / ___| (_) ___ _ __ | |_ // | | | | |/ _ \ '_ \| __| // | |___| | | __/ | | | |_ // \____|_|_|\___|_| |_|\__| - | Append (Origin.Web _, AddClient _) | Append (Origin.Web _, UpdateClient _) | Append (Origin.Web _, RemoveClient _) @@ -301,7 +299,6 @@ type DiscoEvent = // | __/| | | | | |_| | | | (_) | |_| | |_) | // |_| |_|_| |_|\____|_| \___/ \__,_| .__/ // |_| - | Append (Origin.Web _, AddPinGroup _) | Append (Origin.Web _, UpdatePinGroup _) | Append (Origin.Web _, RemovePinGroup _) -> Ignore @@ -317,7 +314,6 @@ type DiscoEvent = // | |_) | | '_ \ // | __/| | | | | // |_| |_|_| |_| - | Append (Origin.Web _, AddPin _) -> Ignore | Append (Origin.Web _, UpdatePin _) -> Replicate | Append (Origin.Web _, RemovePin _) -> Ignore @@ -333,7 +329,6 @@ type DiscoEvent = // | | | | | |/ _ \ // | |__| |_| | __/ // \____\__,_|\___| - | Append (Origin.Web _, AddCue _) | Append (Origin.Web _, UpdateCue _) | Append (Origin.Web _, RemoveCue _) @@ -377,7 +372,6 @@ type DiscoEvent = // | | | | | |/ _ \ | | / __| __| // | |__| |_| | __/ |___| \__ \ |_ // \____\__,_|\___|_____|_|___/\__| - | Append (Origin.Web _, AddCueList _) | Append (Origin.Web _, UpdateCueList _) | Append (Origin.Web _, RemoveCueList _) @@ -394,7 +388,6 @@ type DiscoEvent = // | |__| |_| | __/ __/| | (_| | |_| | __/ | // \____\__,_|\___|_| |_|\__,_|\__, |\___|_| // |___/ - | Append (Origin.Web _, AddCuePlayer _) | Append (Origin.Web _, UpdateCuePlayer _) | Append (Origin.Web _, RemoveCuePlayer _) @@ -410,7 +403,6 @@ type DiscoEvent = // | | | / __|/ _ \ '__| // | |_| \__ \ __/ | // \___/|___/\___|_| - | Append (Origin.Web _, AddUser _) | Append (Origin.Web _, UpdateUser _) | Append (Origin.Web _, RemoveUser _) -> Replicate @@ -426,7 +418,6 @@ type DiscoEvent = // \___ \ / _ \/ __/ __| |/ _ \| '_ \ // ___) | __/\__ \__ \ | (_) | | | | // |____/ \___||___/___/_|\___/|_| |_| - | Append (Origin.Web _, AddSession _) | Append (Origin.Web _, UpdateSession _) | Append (Origin.Web _, RemoveSession _) -> Replicate @@ -442,7 +433,6 @@ type DiscoEvent = // | | | | / __|/ __/ _ \ \ / / _ \ '__/ _ \/ _` | // | |_| | \__ \ (_| (_) \ V / __/ | | __/ (_| | // |____/|_|___/\___\___/ \_/ \___|_| \___|\__,_| - | Append (Origin.Web _, AddDiscoveredService _) | Append (Origin.Web _, UpdateDiscoveredService _) | Append (Origin.Web _, RemoveDiscoveredService _) @@ -458,7 +448,6 @@ type DiscoEvent = // | | | |/ _ \ / __| |/ / // | |___| | (_) | (__| < // \____|_|\___/ \___|_|\_\ - | Append (Origin.Service _, UpdateClock _) -> Publish | Append ( _, UpdateClock _) -> Ignore @@ -467,7 +456,6 @@ type DiscoEvent = // | | / _ \| '_ ` _ \| '_ ` _ \ / _` | '_ \ / _` | // | |__| (_) | | | | | | | | | | | (_| | | | | (_| | // \____\___/|_| |_| |_|_| |_| |_|\__,_|_| |_|\__,_| - | Append (Origin.Web _, Command _) | Append (Origin.Client _, Command _) | Append (Origin.Service _, Command _) -> Replicate @@ -478,7 +466,6 @@ type DiscoEvent = // | |_| | (_| | || (_| |___) | | | | (_| | |_) \__ \ | | | (_) | |_ // |____/ \__,_|\__\__,_|____/|_| |_|\__,_| .__/|___/_| |_|\___/ \__| // |_| - | Append (Origin.Web _, DataSnapshot _) | Append (Origin.Client _, DataSnapshot _) | Append (Origin.Service _, DataSnapshot _) -> Ignore @@ -488,7 +475,6 @@ type DiscoEvent = // | |_ / _` / __| __| |_) | '__/ _ \ / __/ _ \/ __/ __| // | _| (_| \__ \ |_| __/| | | (_) | (_| __/\__ \__ \ // |_| \__,_|___/\__|_| |_| \___/ \___\___||___/___/ - | Append (_, UpdateSlices _) -> Publish | Append (_, CallCue _) -> Publish @@ -498,7 +484,6 @@ type DiscoEvent = // | |__| (_) | (_| | | | \__ \ (_| | // |_____\___/ \__, |_| |_|___/\__, | // |___/ |___/ - | Append (_, LogMsg _) -> Publish // __ __ _ @@ -506,7 +491,6 @@ type DiscoEvent = // | |\/| | / __|/ __| // | | | | \__ \ (__ // |_| |_|_|___/\___| - | Append (_, SetLogLevel _) -> Replicate // * DiscoEvent module diff --git a/src/Disco/Disco/Core/IpAddress.fs b/src/Disco/Disco/Core/IpAddress.fs index 727e4832..0bdf8de8 100644 --- a/src/Disco/Disco/Core/IpAddress.fs +++ b/src/Disco/Disco/Core/IpAddress.fs @@ -57,28 +57,28 @@ type IpAddress = #if FABLE_COMPILER try IpAddress.Parse str - |> Either.succeed + |> Result.succeed with | exn -> sprintf "Unable to parse IP: %s Cause: %s" str exn.Message |> Disco.Core.Error.asParseError "IpAddress.Parse" - |> Either.fail + |> Result.fail #else try let ip = IPAddress.Parse(str) match ip.AddressFamily with - | Sockets.AddressFamily.InterNetwork -> IPv4Address str |> Right - | Sockets.AddressFamily.InterNetworkV6 -> IPv6Address str |> Right + | Sockets.AddressFamily.InterNetwork -> IPv4Address str |> Ok + | Sockets.AddressFamily.InterNetworkV6 -> IPv6Address str |> Ok | fam -> sprintf "Unable to parse IP: %s Unsupported AddressFamily: %A" str fam |> Error.asParseError "IpAddress.Parse" - |> Either.fail + |> Result.fail with | exn -> sprintf "Unable to parse IP: %s Cause: %s" str exn.Message |> Error.asParseError "IpAddress.Parse" - |> Either.fail + |> Result.fail #endif // ** ofIPAddress diff --git a/src/Disco/Disco/Core/LogLevel.fs b/src/Disco/Disco/Core/LogLevel.fs index eb2ae3d5..46ec5efe 100644 --- a/src/Disco/Disco/Core/LogLevel.fs +++ b/src/Disco/Disco/Core/LogLevel.fs @@ -34,7 +34,7 @@ type LogLevel = | _ -> failwithf "could not parse %s" str static member TryParse (str: string) = - Either.tryWith ParseError "LogLevel" <| fun _ -> + Result.tryWith ParseError "LogLevel" <| fun _ -> str |> LogLevel.Parse override self.ToString() = diff --git a/src/Disco/Disco/Core/Logging.fs b/src/Disco/Disco/Core/Logging.fs index 0e2ad09f..b0f2fb17 100644 --- a/src/Disco/Disco/Core/Logging.fs +++ b/src/Disco/Disco/Core/Logging.fs @@ -58,7 +58,7 @@ type LogLevel = // ** TryParse static member TryParse (str: string) = - Either.tryWith (Error.asParseError "LogLevel.TryParse") <| fun _ -> + Result.tryWith (Error.asParseError "LogLevel.TryParse") <| fun _ -> str |> LogLevel.Parse // ** ToString @@ -108,7 +108,7 @@ type Tier = // ** TryParse static member TryParse (str: string) = - Either.tryWith (Error.asParseError "Tier.TryParse") <| fun _ -> + Result.tryWith (Error.asParseError "Tier.TryParse") <| fun _ -> str |> Tier.Parse // * LogEventYaml @@ -126,14 +126,32 @@ type LogEventYaml() = #endif +// * LogEventFields + +type LogEventFields = + { Time: bool + Thread: bool + Tier: bool + Id: bool + Tag: bool + LogLevel: bool + Message: bool } + + // ** Default + + static member Default = + { Time = true + Thread = true + Tier = true + Id = true + Tag = true + LogLevel = true + Message = true } + // * LogEvent -/// ## LogEvent -/// /// Structured log format record. /// -/// ## Fields: -/// /// - Time: int64 unixtime in milliseconds /// - Thread: int ID of Thread the log event was collected /// - Tier: application tier where log was collected @@ -141,8 +159,7 @@ type LogEventYaml() = /// - Tag: call site tag describing source code location where log was collected /// - LogLevel: LogLevel of collected log message /// - Message: log message -/// -/// Returns: LogEvent + type LogEvent = { Time : uint32 Thread : int @@ -192,7 +209,7 @@ type LogEvent = // ** FromFB - static member FromFB(fb: LogEventFB) = either { + static member FromFB(fb: LogEventFB) = result { let! id = Id.decodeMachineId fb let! tier = Tier.TryParse fb.Tier let! level = LogLevel.TryParse fb.LogLevel @@ -230,8 +247,8 @@ type LogEvent = // ** FromYaml - static member FromYaml(yaml: LogEventYaml) : Either = - either { + static member FromYaml(yaml: LogEventYaml) : DiscoResult = + result { let! id = DiscoId.TryParse yaml.MachineId let! level = LogLevel.TryParse yaml.LogLevel let! tier = Tier.TryParse yaml.Tier @@ -254,6 +271,7 @@ type LoggingSettings = { MachineId: DiscoId Level: LogLevel UseColors: bool + Fields: LogEventFields Tier: Tier } // * LoggingSettings module @@ -264,9 +282,10 @@ module LoggingSettings = { MachineId = DiscoId.Empty Level = LogLevel.Debug UseColors = true + Fields = LogEventFields.Default Tier = Tier.Service } -// * Logger +// * Logger module [] module Logger = @@ -283,7 +302,12 @@ module Logger = { MachineId = DiscoId.Empty Level = LogLevel.Debug UseColors = true + Fields = LogEventFields.Default + #if DISCO_NODES + Tier = Tier.Client } + #else Tier = Tier.Service } + #endif // ** currentSettings @@ -293,6 +317,10 @@ module Logger = let set config = _settings <- config + // ** setFields + + let setFields fields = _settings <- { _settings with Fields = fields } + // ** setLevel let setLevel level = @@ -304,40 +332,41 @@ module Logger = // ** stdout - /// ## stdout - /// /// Simple logging to stdout - /// - /// ### Signature: - /// - log: LogEvent - /// - /// Returns: unit + let stdout (log: LogEvent) = #if !FABLE_COMPILER && !DISCO_NODES if _settings.UseColors then - Console.darkGreen "{0}" "[" - match log.LogLevel with - | LogLevel.Trace -> Console.gray "{0,-5}" log.LogLevel - | LogLevel.Debug -> Console.white "{0,-5}" log.LogLevel - | LogLevel.Info -> Console.green "{0,-5}" log.LogLevel - | LogLevel.Warn -> Console.yellow "{0,-5}" log.LogLevel - | LogLevel.Err -> Console.red "{0,-5}" log.LogLevel - Console.darkGreen "{0}" "] " - - Console.darkGreen "{0}:" "ts" - Console.white "{0} " log.Time - - Console.darkGreen "{0}:" "id" - Console.white "{0} " (log.MachineId.Prefix()) - - Console.darkGreen "{0}:" "type" - Console.white "{0,-7} " log.Tier - - Console.darkGreen "{0}:" "in" - Console.yellow "{0,-30} " log.Tag - Console.white "{0}" log.Message - Console.Write(System.Environment.NewLine) + if _settings.Fields.LogLevel then + Console.darkGreen "{0}" "[" + match log.LogLevel with + | LogLevel.Trace -> Console.gray "{0,-5}" log.LogLevel + | LogLevel.Debug -> Console.white "{0,-5}" log.LogLevel + | LogLevel.Info -> Console.green "{0,-5}" log.LogLevel + | LogLevel.Warn -> Console.yellow "{0,-5}" log.LogLevel + | LogLevel.Err -> Console.red "{0,-5}" log.LogLevel + Console.darkGreen "{0}" "] " + + if _settings.Fields.Time then + Console.darkGreen "{0}:" "ts" + Console.white "{0} " log.Time + + if _settings.Fields.Id then + Console.darkGreen "{0}:" "id" + Console.white "{0} " (log.MachineId.Prefix()) + + if _settings.Fields.Tier then + Console.darkGreen "{0}:" "type" + Console.white "{0,-7} " log.Tier + + if _settings.Fields.Tag then + Console.darkGreen "{0}:" "in" + Console.yellow "{0,-30} " log.Tag + + if _settings.Fields.Message then + Console.white "{0}" log.Message + Console.Write(System.Environment.NewLine) else #endif Console.WriteLine("{0}", log) @@ -577,24 +606,24 @@ module LogFile = log |> string |> file.Stream.WriteLine - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asIOError (tag "write") - |> Either.fail + |> Result.fail // ** create let create (machine: MachineId) (path: FilePath) = - either { + result { try let ts = DateTime.Now let fn = String.Format("disco-{0}-{1:yyyy-MM-dd_hh-mm-ss-tt}.log", machine.Prefix(), ts) do! if Directory.exists path |> not then Directory.createDirectory path - |> Either.ignore - else Either.succeed () + |> Result.ignore + else Result.succeed () let fp = Path.Combine(unwrap path, fn) let writer = File.AppendText fp writer.AutoFlush <- true @@ -607,7 +636,7 @@ module LogFile = return! exn.Message |> Error.asIOError (tag "create") - |> Either.fail + |> Result.fail } #endif diff --git a/src/Disco/Disco/Core/Machine.fs b/src/Disco/Disco/Core/Machine.fs index 2a6ca97e..4c4f9b41 100644 --- a/src/Disco/Disco/Core/Machine.fs +++ b/src/Disco/Disco/Core/Machine.fs @@ -165,7 +165,7 @@ type DiscoMachine = // ** FromFB static member FromFB (fb: DiscoMachineFB) = - either { + result { let! machineId = Id.decodeMachineId fb let! ip = IpAddress.TryParse fb.BindAddress let! metricsHost = IpAddress.TryParse fb.MetricsHost @@ -246,7 +246,7 @@ type DiscoMachineYaml () = [] val mutable AssetFilter: string [] val mutable LogDirectory: string [] val mutable CollectMetrics: bool - + [] val mutable MetricsHost: string [] val mutable MetricsPort: uint16 @@ -272,8 +272,8 @@ type DiscoMachineYaml () = yml.LogDirectory <- unwrap cfg.LogDirectory yml.CollectMetrics <- cfg.CollectMetrics yml.MetricsHost <- string cfg.MetricsHost - yml.MetricsPort <- unwrap cfg.MetricsPort - yml.MetricsDb <- cfg.MetricsDb + yml.MetricsPort <- unwrap cfg.MetricsPort + yml.MetricsDb <- cfg.MetricsDb yml.BindAddress <- string cfg.BindAddress yml.MulticastAddress <- string cfg.MulticastAddress yml.MulticastPort <- unwrap cfg.MulticastPort @@ -334,28 +334,28 @@ module MachineStatus = static member FromFB(fb: MachineStatusFB) = #if FABLE_COMPILER match fb.Status with - | x when x = MachineStatusEnumFB.IdleFB -> Either.succeed Idle + | x when x = MachineStatusEnumFB.IdleFB -> Result.succeed Idle | x when x = MachineStatusEnumFB.BusyFB -> - either { + result { let! id = Id.decodeProjectId fb return Busy (id, name fb.ProjectName) } | other -> sprintf "Unknown Machine Status: %d" other |> Error.asParseError "MachineStatus.FromOffset" - |> Either.fail + |> Result.fail #else match fb.Status with - | MachineStatusEnumFB.IdleFB -> Either.succeed Idle + | MachineStatusEnumFB.IdleFB -> Result.succeed Idle | MachineStatusEnumFB.BusyFB -> - either { + result { let! id = Id.decodeProjectId fb return Busy (id, name fb.ProjectName) } | other -> sprintf "Unknown Machine Status: %O" other |> Error.asParseError "MachineStatus.FromOffset" - |> Either.fail + |> Result.fail #endif // *** ToBytes @@ -452,8 +452,8 @@ module MachineConfig = // ** parse - let private parse (yml: DiscoMachineYaml) : Either = - either { + let private parse (yml: DiscoMachineYaml) : DiscoResult = + result { let! ip = IpAddress.TryParse yml.BindAddress let! metricsHost = IpAddress.TryParse yml.MetricsHost let! id = DiscoId.TryParse yml.MachineId @@ -556,7 +556,7 @@ module MachineConfig = // ** save - let save (path: FilePath option) (cfg: DiscoMachine) : Either = + let save (path: FilePath option) (cfg: DiscoMachine) : DiscoResult = let serializer = Serializer() try @@ -573,12 +573,12 @@ module MachineConfig = |> ensureExists File.WriteAllText(unwrap location, payload) - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asIOError (tag "save") - |> Either.fail + |> Result.fail // ** load @@ -594,16 +594,16 @@ module MachineConfig = else "could not find machine configuration" |> Error.asIOError (tag "load") - |> Either.fail + |> Result.fail with exn -> exn.Message |> Error.asIOError (tag "load") - |> Either.fail + |> Result.fail // ** init /// Attention: this method must be called only when starting the main process - let init getBindIp shiftDefaults (path: FilePath option) : Either = + let init getBindIp shiftDefaults (path: FilePath option) : DiscoResult = let serializer = Serializer() try let location = getLocation path @@ -617,11 +617,11 @@ module MachineConfig = let bindIp = getBindIp() let cfg = create bindIp shiftDefaults save path cfg - |> Either.map (fun _ -> cfg) + |> Result.map (fun _ -> cfg) match cfg with - | Left err -> Either.fail err - | Right cfg -> + | Error err -> Result.fail err + | Ok cfg -> if Path.IsPathRooted (unwrap cfg.WorkSpace) then singleton <- cfg else @@ -631,12 +631,12 @@ module MachineConfig = |> filepath cfg.WorkSpace singleton <- { cfg with WorkSpace = wp } - Either.succeed() + Result.succeed() with | exn -> exn.Message |> Error.asIOError (tag "load") - |> Either.fail + |> Result.fail #endif diff --git a/src/Disco/Disco/Core/Metrics.fs b/src/Disco/Disco/Core/Metrics.fs index d3b2154e..a4246799 100644 --- a/src/Disco/Disco/Core/Metrics.fs +++ b/src/Disco/Disco/Core/Metrics.fs @@ -23,11 +23,11 @@ module Metrics = .WriteTo.InfluxDB(url, config.MetricsDb) .CreateCollector() - let init (config: DiscoMachine): Either = + let init (config: DiscoMachine): DiscoResult = try if config.CollectMetrics then match agent with - | Some _ -> Either.nothing + | Some _ -> Result.nothing | None -> let collector = createCollector config let actor = ThreadActor.create "Metrics" (fun _ (name,value) -> @@ -36,12 +36,12 @@ module Metrics = do collector.Write(name, values)) actor.Start() agent <- Some actor - Either.nothing - else Either.nothing + Result.nothing + else Result.nothing with exn -> exn.Message |> Error.asIOError "Metrics.init" - |> Either.fail + |> Result.fail let collect (name: string) (value: obj) : unit = match agent with diff --git a/src/Disco/Disco/Core/Network.fs b/src/Disco/Disco/Core/Network.fs index 48e421ad..1e3f1c24 100644 --- a/src/Disco/Disco/Core/Network.fs +++ b/src/Disco/Disco/Core/Network.fs @@ -130,13 +130,13 @@ module Network = List.fold (fun result (iface: NetworkInterface) -> match result with - | Right () -> result - | Left _ -> + | Ok () -> result + | Error _ -> if List.contains ip iface.IpAddresses then - Either.succeed () + Result.succeed () else result) - (Left (Error.asSocketError (tag "checkIpAddress") msg)) + (Error (Error.asSocketError (tag "checkIpAddress") msg)) ifaces // ** ensureIpAddress @@ -160,7 +160,7 @@ module Network = // ** ensureAvailability let ensureAvailability (ip: IpAddress) (port: Port) = - either { + result { try use socket = new Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp) let endpoint = IPEndPoint(ip.toIPAddress(), int port) @@ -174,7 +174,7 @@ module Network = port |> sprintf "Address %O:%O already in use" ip |> Error.asSocketError (tag "ensureAvailability") - |> Either.fail + |> Result.fail } #endif diff --git a/src/Disco/Disco/Core/Pin.fs b/src/Disco/Disco/Core/Pin.fs index e9c30686..b779f80b 100644 --- a/src/Disco/Disco/Core/Pin.fs +++ b/src/Disco/Disco/Core/Pin.fs @@ -63,16 +63,16 @@ type Behavior = static member TryParse (str: string) = match String.toLower str with - | "string" | "simple" -> Right Simple - | "multiline" -> Right MultiLine - | "filename" -> Right FileName - | "directory" -> Right Directory - | "url" -> Right Url - | "ip" -> Right IP + | "string" | "simple" -> Ok Simple + | "multiline" -> Ok MultiLine + | "filename" -> Ok FileName + | "directory" -> Ok Directory + | "url" -> Ok Url + | "ip" -> Ok IP | _ -> sprintf "Invalid Behavior value: %s" str |> Error.asParseError "Behavior.TryParse" - |> Either.fail + |> Result.fail // ** ToString @@ -97,30 +97,30 @@ type Behavior = static member FromFB (fb: BehaviorFB) = #if FABLE_COMPILER match fb with - | x when x = BehaviorFB.SimpleFB -> Right Simple - | x when x = BehaviorFB.MultiLineFB -> Right MultiLine - | x when x = BehaviorFB.FileNameFB -> Right FileName - | x when x = BehaviorFB.DirectoryFB -> Right Directory - | x when x = BehaviorFB.UrlFB -> Right Url - | x when x = BehaviorFB.IPFB -> Right IP + | x when x = BehaviorFB.SimpleFB -> Ok Simple + | x when x = BehaviorFB.MultiLineFB -> Ok MultiLine + | x when x = BehaviorFB.FileNameFB -> Ok FileName + | x when x = BehaviorFB.DirectoryFB -> Ok Directory + | x when x = BehaviorFB.UrlFB -> Ok Url + | x when x = BehaviorFB.IPFB -> Ok IP | x -> sprintf "Cannot parse Behavior. Unknown type: %A" x |> Error.asParseError "Behavior.FromFB" - |> Either.fail + |> Result.fail #else match fb with - | BehaviorFB.SimpleFB -> Right Simple - | BehaviorFB.MultiLineFB -> Right MultiLine - | BehaviorFB.FileNameFB -> Right FileName - | BehaviorFB.DirectoryFB -> Right Directory - | BehaviorFB.UrlFB -> Right Url - | BehaviorFB.IPFB -> Right IP + | BehaviorFB.SimpleFB -> Ok Simple + | BehaviorFB.MultiLineFB -> Ok MultiLine + | BehaviorFB.FileNameFB -> Ok FileName + | BehaviorFB.DirectoryFB -> Ok Directory + | BehaviorFB.UrlFB -> Ok Url + | BehaviorFB.IPFB -> Ok IP | x -> sprintf "Cannot parse Behavior. Unknown type: %A" x |> Error.asParseError "Behavior.FromFB" - |> Either.fail + |> Result.fail #endif @@ -177,12 +177,12 @@ type PinConfiguration = try str |> PinConfiguration.Parse - |> Either.succeed + |> Result.succeed with | x -> x.Message |> Error.asParseError "PinConfiguration.TryParse" - |> Either.fail + |> Result.fail // ** ToOffset @@ -197,22 +197,22 @@ type PinConfiguration = static member FromFB(fb: PinConfigurationFB) = #if FABLE_COMPILER match fb with - | x when x = PinConfigurationFB.SinkFB -> Right Sink - | x when x = PinConfigurationFB.SourceFB -> Right Source - | x when x = PinConfigurationFB.PresetFB -> Right Preset + | x when x = PinConfigurationFB.SinkFB -> Ok Sink + | x when x = PinConfigurationFB.SourceFB -> Ok Source + | x when x = PinConfigurationFB.PresetFB -> Ok Preset | x -> sprintf "Unknown PinConfigurationFB value: %A" x |> Error.asParseError "PinConfiguration.FromFB" - |> Either.fail + |> Result.fail #else match fb with - | PinConfigurationFB.SinkFB -> Right Sink - | PinConfigurationFB.SourceFB -> Right Source - | PinConfigurationFB.PresetFB -> Right Preset + | PinConfigurationFB.SinkFB -> Ok Sink + | PinConfigurationFB.SourceFB -> Ok Source + | PinConfigurationFB.PresetFB -> Ok Preset | x -> sprintf "Unknown PinConfigurationFB value: %A" x |> Error.asParseError "PinConfiguration.FromFB" - |> Either.fail + |> Result.fail #endif // * VecSize @@ -256,12 +256,12 @@ type VecSize = try str |> VecSize.Parse - |> Either.succeed + |> Result.succeed with | x -> x.Message |> Error.asParseError "VecSize.TryParse" - |> Either.fail + |> Result.fail // ** ToOffset @@ -282,21 +282,21 @@ type VecSize = static member FromFB(fb: VecSizeFB) = #if FABLE_COMPILER match fb.Type with - | x when x = VecSizeTypeFB.DynamicFB -> Right Dynamic + | x when x = VecSizeTypeFB.DynamicFB -> Ok Dynamic | x when x = VecSizeTypeFB.FixedFB -> - Right (Fixed fb.Size) + Ok (Fixed fb.Size) | x -> sprintf "Unknown VecSizeFB value: %A" x |> Error.asParseError "VecSize.FromFB" - |> Either.fail + |> Result.fail #else match fb.Type with - | VecSizeTypeFB.DynamicFB -> Right Dynamic - | VecSizeTypeFB.FixedFB -> Right (Fixed fb.Size) + | VecSizeTypeFB.DynamicFB -> Ok Dynamic + | VecSizeTypeFB.FixedFB -> Ok (Fixed fb.Size) | x -> sprintf "Unknown PinConfigurationFB value: %A" x |> Error.asParseError "PinConfiguration.FromFB" - |> Either.fail + |> Result.fail #endif // * Pin @@ -506,49 +506,49 @@ type Pin = // ** FromFB - static member FromFB(fb: PinFB) : Either = + static member FromFB(fb: PinFB) : DiscoResult = #if FABLE_COMPILER match fb.PinType with | x when x = PinTypeFB.StringPinFB -> StringPinFB.Create() |> fb.Pin |> StringPinD.FromFB - |> Either.map StringPin + |> Result.map StringPin | x when x = PinTypeFB.NumberPinFB -> NumberPinFB.Create() |> fb.Pin |> NumberPinD.FromFB - |> Either.map NumberPin + |> Result.map NumberPin | x when x = PinTypeFB.BoolPinFB -> BoolPinFB.Create() |> fb.Pin |> BoolPinD.FromFB - |> Either.map BoolPin + |> Result.map BoolPin | x when x = PinTypeFB.BytePinFB -> BytePinFB.Create() |> fb.Pin |> BytePinD.FromFB - |> Either.map BytePin + |> Result.map BytePin | x when x = PinTypeFB.EnumPinFB -> EnumPinFB.Create() |> fb.Pin |> EnumPinD.FromFB - |> Either.map EnumPin + |> Result.map EnumPin | x when x = PinTypeFB.ColorPinFB -> ColorPinFB.Create() |> fb.Pin |> ColorPinD.FromFB - |> Either.map ColorPin + |> Result.map ColorPin | x -> sprintf "%A is not a valid PinTypeFB" x |> Error.asParseError "PinFB.FromFB" - |> Either.fail + |> Result.fail #else @@ -558,71 +558,71 @@ type Pin = if v.HasValue then v.Value |> StringPinD.FromFB - |> Either.map StringPin + |> Result.map StringPin else "StringPinFB has no value" |> Error.asParseError "PinFB.FromFB" - |> Either.fail + |> Result.fail | PinTypeFB.NumberPinFB -> let v = fb.Pin() if v.HasValue then v.Value |> NumberPinD.FromFB - |> Either.map NumberPin + |> Result.map NumberPin else "NumberPinFB has no value" |> Error.asParseError "PinFB.FromFB" - |> Either.fail + |> Result.fail | PinTypeFB.BoolPinFB -> let v = fb.Pin() if v.HasValue then v.Value |> BoolPinD.FromFB - |> Either.map BoolPin + |> Result.map BoolPin else "BoolPinFB has no value" |> Error.asParseError "PinFB.FromFB" - |> Either.fail + |> Result.fail | PinTypeFB.BytePinFB -> let v = fb.Pin() if v.HasValue then v.Value |> BytePinD.FromFB - |> Either.map BytePin + |> Result.map BytePin else "BytePinFB has no value" |> Error.asParseError "PinFB.FromFB" - |> Either.fail + |> Result.fail | PinTypeFB.EnumPinFB -> let v = fb.Pin() if v.HasValue then v.Value |> EnumPinD.FromFB - |> Either.map EnumPin + |> Result.map EnumPin else "EnumPinFB has no value" |> Error.asParseError "PinFB.FromFB" - |> Either.fail + |> Result.fail | PinTypeFB.ColorPinFB -> let v = fb.Pin() if v.HasValue then v.Value |> ColorPinD.FromFB - |> Either.map ColorPin + |> Result.map ColorPin else "ColorPinFB has no value" |> Error.asParseError "PinFB.FromFB" - |> Either.fail + |> Result.fail | x -> sprintf "PinTypeFB not recognized: %A" x |> Error.asParseError "PinFB.FromFB" - |> Either.fail + |> Result.fail #endif @@ -632,7 +632,7 @@ type Pin = // ** FromBytes - static member FromBytes(bytes: byte[]) : Either = + static member FromBytes(bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> PinFB.GetRootAsPinFB |> Pin.FromFB @@ -666,63 +666,64 @@ module Pin = #if FABLE_COMPILER - let inline parseComplexValues< ^a, ^b, ^t when ^t : (static member FromFB : ^a -> Either) + let inline parseComplexValues< ^a, ^b, ^t when ^t : (static member FromFB : ^a -> DiscoResult< ^t>) and ^b : (member ValuesLength : int) and ^b : (member Values : int -> ^a)> (fb: ^b) - : Either = + : DiscoResult< ^t array> = let len = (^b : (member ValuesLength : int) fb) let arr = Array.zeroCreate len Array.fold - (fun (result: Either) _ -> either { - - let! (i, slices) = result + (fun (res: DiscoResult) _ -> + result { + let! (i, slices) = res // In Javascript, Flatbuffer types are not modeled as nullables, // hence parsing code is much simpler let! slice = let value = (^b : (member Values : int -> ^a) (fb, i)) - (^t : (static member FromFB : ^a -> Either) value) + (^t : (static member FromFB : ^a -> DiscoResult< ^t>) value) // add the slice to the array> at its correct position slices.[i] <- slice return (i + 1, slices) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd + |> Result.map snd #else - let inline parseComplexValues< ^a, ^b, ^t when ^t : (static member FromFB : ^a -> Either) + let inline parseComplexValues< ^a, ^b, ^t when ^t : (static member FromFB : ^a -> DiscoResult< ^t>) and ^b : (member ValuesLength : int) and ^b : (member Values : int -> Nullable< ^a >)> (fb: ^b) - : Either = + : DiscoResult< ^t array> = let len = (^b : (member ValuesLength : int) fb) let arr = Array.zeroCreate len Array.fold - (fun (result: Either) _ -> either { - let! (i, slices) = result + (fun (res: DiscoResult) _ -> + result { + let! (i, slices) = res // In .NET, Flatbuffers are modelled with nullables, hence // parsing is slightly more elaborate let! slice = let value = (^b : (member Values : int -> Nullable< ^a >) (fb, i)) if value.HasValue then - (^t : (static member FromFB : ^a -> Either) value.Value) + (^t : (static member FromFB : ^a -> DiscoResult< ^t>) value.Value) else "Could not parse empty slice" |> Error.asParseError (sprintf "ParseSlices of %s" (typeof< ^t >).Name) - |> Either.fail + |> Result.fail // add the slice to the array> at its correct position slices.[i] <- slice return (i + 1, slices) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd + |> Result.map snd #endif @@ -733,37 +734,35 @@ module Pin = let inline parseSimpleValues< ^a, ^b when ^b : (member ValuesLength : int) and ^b : (member Values : int -> ^a)> (fb: ^b) - : Either = + : DiscoResult< ^a array> = let len = (^b : (member ValuesLength : int) fb) let arr = Array.zeroCreate len Array.fold - (fun (result: Either) _ -> either { - - let! (i, slices) = result - + (fun (res: DiscoResult) _ -> + result { + let! (i, slices) = res // In Javascript, Flatbuffer types are not modeled as nullables, // hence parsing code is much simpler let slice = (^b : (member Values : int -> ^a) (fb, i)) - // add the slice to the array> at its correct position slices.[i] <- slice return (i + 1, slices) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd + |> Result.map snd #else let inline parseSimpleValues< ^a, ^b when ^b : (member ValuesLength : int) and ^b : (member Values : int -> ^a)> (fb: ^b) - : Either = + : DiscoResult< ^a array> = let len = (^b : (member ValuesLength : int) fb) let arr = Array.zeroCreate len Array.fold - (fun (result: Either) _ -> either { - let! (i, slices) = result + (fun (res: DiscoResult) _ -> result { + let! (i, slices) = res // In .NET, Flatbuffers are modelled with nullables, hence // parsing is slightly more elaborate @@ -775,9 +774,9 @@ module Pin = slices.[i] <- slice return (i + 1, slices) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd + |> Result.map snd #endif @@ -796,7 +795,7 @@ module Pin = else "Cannot parse empty VecSize" |> Error.asParseError "VecSize.FromFB" - |> Either.fail + |> Result.fail #endif // ** parseLabels @@ -805,21 +804,21 @@ module Pin = let inline parseLabels< ^a when ^a : (member LabelsLength : int) and ^a : (member Labels : int -> string)> (fb: ^a) - : Either = + : DiscoResult< string array> = let len = (^a : (member LabelsLength : int) fb) let arr = Array.zeroCreate len Array.fold - (fun (result: Either) _ -> either { - let! (i, labels) = result + (fun (res: DiscoResult) _ -> result { + let! (i, labels) = res let value = try (^a : (member Labels : int -> string) (fb, i)) with | _ -> null labels.[i] <- value return (i + 1, labels) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd + |> Result.map snd // ** parseTags @@ -831,30 +830,30 @@ module Pin = and ^a : (member Tags : int -> Nullable)> #endif (fb: ^a) - : Either = + : DiscoResult< Property array> = let len = (^a : (member TagsLength : int) fb) let arr = Array.zeroCreate len Array.fold - (fun (result: Either) _ -> either { - let! (i, arr) = result + (fun (res: DiscoResult) _ -> result { + let! (i, arr) = res #if FABLE_COMPILER let prop = (^a : (member Tags: int -> KeyValueFB) fb, i) #else let! prop = let nullable = (^a : (member Tags: int -> Nullable) fb,i) if nullable.HasValue then - Either.succeed nullable.Value + Result.succeed nullable.Value else "Cannot parse empty property" |> Error.asParseError "EnumPin.FromFB" - |> Either.fail + |> Result.fail #endif arr.[i] <- { Key = prop.Key; Value = prop.Value } return (i + 1, arr) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd + |> Result.map snd // ** parseProperties @@ -865,11 +864,11 @@ module Pin = and ^a : (member Properties: int -> Nullable)> #endif (fb: ^a) - : Either = + : DiscoResult< Property array> = let len = (^a : (member PropertiesLength: int) fb) let properties = Array.zeroCreate len Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult< int * Property array>) _ -> result { let! (i, arr) = m #if FABLE_COMPILER let prop = (^a : (member Properties: int -> KeyValueFB) fb, i) @@ -877,18 +876,18 @@ module Pin = let! prop = let nullable = (^a : (member Properties: int -> Nullable) fb,i) if nullable.HasValue then - Either.succeed nullable.Value + Result.succeed nullable.Value else "Cannot parse empty property" |> Error.asParseError "EnumPin.FromFB" - |> Either.fail + |> Result.fail #endif arr.[i] <- { Key = prop.Key; Value = prop.Value } return (i + 1, arr) }) - (Right (0, properties)) + (Ok (0, properties)) properties - |> Either.map snd + |> Result.map snd // ** emtpyLabels @@ -1718,8 +1717,8 @@ type NumberPinD = // ** FromFB - static member FromFB(fb: NumberPinFB) : Either = - either { + static member FromFB(fb: NumberPinFB) : DiscoResult = + result { let! id = Id.decodeId fb let! groupId = Id.decodePinGroupId fb let! clientId = Id.decodeClientId fb @@ -1731,7 +1730,7 @@ type NumberPinD = let! slices = fb |> Pin.parseSimpleValues - |> Either.map (Array.map double) + |> Result.map (Array.map double) return { Id = id @@ -1759,7 +1758,7 @@ type NumberPinD = // ** FromBytes - static member FromBytes(bytes: byte[]) : Either = + static member FromBytes(bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> NumberPinFB.GetRootAsNumberPinFB |> NumberPinD.FromFB @@ -1916,8 +1915,8 @@ type StringPinD = // ** FromFB - static member FromFB(fb: StringPinFB) : Either = - either { + static member FromFB(fb: StringPinFB) : DiscoResult = + result { let! id = Id.decodeId fb let! groupId = Id.decodePinGroupId fb let! clientId = Id.decodeClientId fb @@ -1952,7 +1951,7 @@ type StringPinD = // ** FromStrings - static member FromStrings(bytes: byte[]) : Either = + static member FromStrings(bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> StringPinFB.GetRootAsStringPinFB |> StringPinD.FromFB @@ -2052,8 +2051,8 @@ type BoolPinD = // ** FromFB - static member FromFB(fb: BoolPinFB) : Either = - either { + static member FromFB(fb: BoolPinFB) : DiscoResult = + result { let! id = Id.decodeId fb let! groupId = Id.decodePinGroupId fb let! clientId = Id.decodeClientId fb @@ -2086,7 +2085,7 @@ type BoolPinD = // ** FromBytes - static member FromBytes(bytes: byte[]) : Either = + static member FromBytes(bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> BoolPinFB.GetRootAsBoolPinFB |> BoolPinD.FromFB @@ -2248,8 +2247,8 @@ type [] BytePinD = // ** FromFB - static member FromFB(fb: BytePinFB) : Either = - either { + static member FromFB(fb: BytePinFB) : DiscoResult = + result { let! id = Id.decodeId fb let! group = Id.decodePinGroupId fb let! client = Id.decodeClientId fb @@ -2260,7 +2259,7 @@ type [] BytePinD = let! slices = fb |> Pin.parseSimpleValues - |> Either.map (Array.map String.decodeBase64) + |> Result.map (Array.map String.decodeBase64) return { Id = id @@ -2284,7 +2283,7 @@ type [] BytePinD = // ** FromBytes - static member FromBytes(bytes: byte[]) : Either = + static member FromBytes(bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> BytePinFB.GetRootAsBytePinFB |> BytePinD.FromFB @@ -2386,8 +2385,8 @@ type EnumPinD = // ** FromFB - static member FromFB(fb: EnumPinFB) : Either = - either { + static member FromFB(fb: EnumPinFB) : DiscoResult = + result { let! id = Id.decodeId fb let! group = Id.decodePinGroupId fb let! client = Id.decodeClientId fb @@ -2400,7 +2399,7 @@ type EnumPinD = let! properties = let properties = Array.zeroCreate fb.PropertiesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult< int * Property array>) _ -> result { let! (i, arr) = m #if FABLE_COMPILER let prop = fb.Properties(i) @@ -2408,18 +2407,18 @@ type EnumPinD = let! prop = let nullable = fb.Properties(i) if nullable.HasValue then - Either.succeed nullable.Value + Result.succeed nullable.Value else "Cannot parse empty property" |> Error.asParseError "EnumPin.FromFB" - |> Either.fail + |> Result.fail #endif arr.[i] <- { Key = prop.Key; Value = prop.Value } return (i + 1, arr) }) - (Right (0, properties)) + (Ok (0, properties)) properties - |> Either.map snd + |> Result.map snd return { Id = id @@ -2444,7 +2443,7 @@ type EnumPinD = // ** FromEnums - static member FromEnums(bytes: byte[]) : Either = + static member FromEnums(bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> EnumPinFB.GetRootAsEnumPinFB |> EnumPinD.FromFB @@ -2540,8 +2539,8 @@ type ColorPinD = // ** FromFB - static member FromFB(fb: ColorPinFB) : Either = - either { + static member FromFB(fb: ColorPinFB) : DiscoResult = + result { let! id = Id.decodeId fb let! group = Id.decodePinGroupId fb let! client = Id.decodeClientId fb @@ -2572,7 +2571,7 @@ type ColorPinD = // ** FromColors - static member FromColors(bytes: byte[]) : Either = + static member FromColors(bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> ColorPinFB.GetRootAsColorPinFB |> ColorPinD.FromFB @@ -2820,47 +2819,47 @@ type Slice = // ** FromFB - static member FromFB(fb: SliceFB) : Either = + static member FromFB(fb: SliceFB) : DiscoResult = match fb.SliceType with #if FABLE_COMPILER | x when x = SliceTypeFB.StringFB -> let slice = StringFB.Create() |> fb.Slice - StringSlice(index fb.Index, slice.Value) - |> Either.succeed + StringSlice(1 * fb.Index, slice.Value) + |> Result.succeed | x when x = SliceTypeFB.DoubleFB -> let slice = DoubleFB.Create() |> fb.Slice - NumberSlice(index fb.Index, slice.Value) - |> Either.succeed + NumberSlice(1 * fb.Index, slice.Value) + |> Result.succeed | x when x = SliceTypeFB.BoolFB -> let slice = BoolFB.Create() |> fb.Slice - BoolSlice(index fb.Index, slice.Trigger, slice.Value) - |> Either.succeed + BoolSlice(1 * fb.Index, slice.Trigger, slice.Value) + |> Result.succeed | x when x = SliceTypeFB.ByteFB -> let slice = ByteFB.Create() |> fb.Slice - ByteSlice(index fb.Index,String.decodeBase64 slice.Value) - |> Either.succeed + ByteSlice(1 * fb.Index,String.decodeBase64 slice.Value) + |> Result.succeed | x when x = SliceTypeFB.KeyValueFB -> - either { + result { let slice = KeyValueFB.Create() |> fb.Slice let! prop = Property.FromFB slice - return EnumSlice(index fb.Index,prop) + return EnumSlice(1 * fb.Index,prop) } | x when x = SliceTypeFB.ColorSpaceFB -> - either { + result { let slice = ColorSpaceFB.Create() |> fb.Slice let! color = ColorSpace.FromFB slice - return ColorSlice(index fb.Index, color) + return ColorSlice(1 * fb.Index, color) } | x -> sprintf "Could not parse slice. Unknown slice type %A" x |> Error.asParseError "Slice.FromFB" - |> Either.fail + |> Result.fail #else @@ -2868,76 +2867,76 @@ type Slice = let slice = fb.Slice() if slice.HasValue then let value = slice.Value - StringSlice(index fb.Index, value.Value) - |> Either.succeed + StringSlice(1 * fb.Index, value.Value) + |> Result.succeed else "Could not parse StringSlice" |> Error.asParseError "Slice.FromFB" - |> Either.fail + |> Result.fail | SliceTypeFB.DoubleFB -> let slice = fb.Slice() if slice.HasValue then let value = slice.Value - NumberSlice(index fb.Index,value.Value) - |> Either.succeed + NumberSlice(fb.Index * 1,value.Value) + |> Result.succeed else "Could not parse NumberSlice" |> Error.asParseError "Slice.FromFB" - |> Either.fail + |> Result.fail | SliceTypeFB.BoolFB -> let slice = fb.Slice() if slice.HasValue then let value = slice.Value - BoolSlice(index fb.Index, value.Trigger, value.Value) - |> Either.succeed + BoolSlice(fb.Index * 1, value.Trigger, value.Value) + |> Result.succeed else "Could not parse BoolSlice" |> Error.asParseError "Slice.FromFB" - |> Either.fail + |> Result.fail | SliceTypeFB.ByteFB -> let slice = fb.Slice() if slice.HasValue then let value = slice.Value - ByteSlice(index fb.Index, String.decodeBase64 value.Value) - |> Either.succeed + ByteSlice(fb.Index * 1, String.decodeBase64 value.Value) + |> Result.succeed else "Could not parse ByteSlice" |> Error.asParseError "Slice.FromFB" - |> Either.fail + |> Result.fail | SliceTypeFB.KeyValueFB -> let slice = fb.Slice() if slice.HasValue then - either { + result { let value = slice.Value let! prop = Property.FromFB value - return EnumSlice(index fb.Index, prop) + return EnumSlice(fb.Index * 1, prop) } else "Could not parse EnumSlice" |> Error.asParseError "Slice.FromFB" - |> Either.fail + |> Result.fail | SliceTypeFB.ColorSpaceFB -> let slice = fb.Slice() if slice.HasValue then - either { + result { let value = slice.Value let! color = ColorSpace.FromFB value - return ColorSlice(index fb.Index, color) + return ColorSlice(fb.Index * 1, color) } else "Could not parse ColorSlice" |> Error.asParseError "Slice.FromFB" - |> Either.fail + |> Result.fail | x -> sprintf "Cannot parse slice. Unknown slice type: %A" x |> Error.asParseError "Slice.FromFB" - |> Either.fail + |> Result.fail #endif @@ -2947,7 +2946,7 @@ type Slice = // ** FromBytes - static member FromBytes(bytes: byte[]) : Either = + static member FromBytes(bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> SliceFB.GetRootAsSliceFB |> Slice.FromFB @@ -3102,12 +3101,12 @@ type Slices = member self.Map (f: Slice -> 'a) : 'a array = match self with - | StringSlices (_,_,arr) -> Array.mapi (fun i el -> StringSlice (index i, el) |> f) arr - | NumberSlices (_,_,arr) -> Array.mapi (fun i el -> NumberSlice (index i, el) |> f) arr - | BoolSlices (_,_,t,arr) -> Array.mapi (fun i el -> BoolSlice (index i, t, el) |> f) arr - | ByteSlices (_,_,arr) -> Array.mapi (fun i el -> ByteSlice (index i, el) |> f) arr - | EnumSlices (_,_,arr) -> Array.mapi (fun i el -> EnumSlice (index i, el) |> f) arr - | ColorSlices (_,_,arr) -> Array.mapi (fun i el -> ColorSlice (index i, el) |> f) arr + | StringSlices (_,_,arr) -> Array.mapi (fun i el -> StringSlice (1 * i, el) |> f) arr + | NumberSlices (_,_,arr) -> Array.mapi (fun i el -> NumberSlice (1 * i, el) |> f) arr + | BoolSlices (_,_,t,arr) -> Array.mapi (fun i el -> BoolSlice (1 * i, t, el) |> f) arr + | ByteSlices (_,_,arr) -> Array.mapi (fun i el -> ByteSlice (1 * i, el) |> f) arr + | EnumSlices (_,_,arr) -> Array.mapi (fun i el -> EnumSlice (1 * i, el) |> f) arr + | ColorSlices (_,_,arr) -> Array.mapi (fun i el -> ColorSlice (1 * i, el) |> f) arr #if !FABLE_COMPILER @@ -3332,16 +3331,16 @@ type Slices = // ** FromFB - static member inline FromFB(fb: SlicesFB) : Either = - either { + static member inline FromFB(fb: SlicesFB) : DiscoResult = + result { let! id = Id.decodePinId fb let! client = try if fb.ClientIdLength = 0 - then Either.succeed None - else Id.decodeClientId fb |> Either.map Some + then Result.succeed None + else Id.decodeClientId fb |> Result.map Some with exn -> - Either.succeed None + Result.succeed None return! // _ ____ // | / ___| @@ -3354,79 +3353,79 @@ type Slices = let slices = StringsFB.Create() |> fb.Slices let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m parsed.[idx] <- slices.Values(idx) return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (strings, _) -> StringSlices(id,client,strings)) + |> Result.map (fun (strings, _) -> StringSlices(id,client,strings)) | x when x = SlicesTypeFB.DoublesFB -> let slices = DoublesFB.Create() |> fb.Slices let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m parsed.[idx] <- slices.Values(idx) return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (doubles,_) -> NumberSlices(id,client,doubles)) + |> Result.map (fun (doubles,_) -> NumberSlices(id,client,doubles)) | x when x = SlicesTypeFB.BoolsFB -> let slices = BoolsFB.Create() |> fb.Slices let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m parsed.[idx] <- slices.Values(idx) return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (bools,_) -> BoolSlices(id,client,slices.Trigger,bools)) + |> Result.map (fun (bools,_) -> BoolSlices(id,client,slices.Trigger,bools)) | x when x = SlicesTypeFB.BytesFB -> let slices = BytesFB.Create() |> fb.Slices let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m let bytes = slices.Values(idx) |> String.decodeBase64 parsed.[idx] <- bytes return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (bytes,_) -> ByteSlices(id,client,bytes)) + |> Result.map (fun (bytes,_) -> ByteSlices(id,client,bytes)) | x when x = SlicesTypeFB.KeyValuesFB -> let slices = KeyValuesFB.Create() |> fb.Slices let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m let! prop = let value = slices.Values(idx) Property.FromFB value parsed.[idx] <- prop return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (props,_) -> EnumSlices(id,client,props)) + |> Result.map (fun (props,_) -> EnumSlices(id,client,props)) | x when x = SlicesTypeFB.ColorSpacesFB -> let slices = ColorSpacesFB.Create() |> fb.Slices let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m let! color = let value = slices.Values(idx) ColorSpace.FromFB value parsed.[idx] <- color return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (colors,_) -> ColorSlices(id,client,colors)) + |> Result.map (fun (colors,_) -> ColorSlices(id,client,colors)) | x -> sprintf "unknown slices type: %O" x |> Error.asParseError "Slices.FromFB" - |> Either.fail + |> Result.fail // _ _ _____ _____ // | \ | | ____|_ _| @@ -3443,79 +3442,79 @@ type Slices = let slices = slicesish.Value let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m let value = try slices.Values(idx) with | _ -> null parsed.[idx] <- value return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (strings, _) -> StringSlices(id, client, strings)) + |> Result.map (fun (strings, _) -> StringSlices(id, client, strings)) else "empty slices value" |> Error.asParseError "Slices.FromFB" - |> Either.fail + |> Result.fail | SlicesTypeFB.DoublesFB -> let slicesish = fb.Slices() if slicesish.HasValue then let slices = slicesish.Value let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m parsed.[idx] <- slices.Values(idx) return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (doubles,_) -> NumberSlices(id, client, doubles)) + |> Result.map (fun (doubles,_) -> NumberSlices(id, client, doubles)) else "empty slices value" |> Error.asParseError "Slices.FromFB" - |> Either.fail + |> Result.fail | SlicesTypeFB.BoolsFB -> let slicesish = fb.Slices() if slicesish.HasValue then let slices = slicesish.Value let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m parsed.[idx] <- slices.Values(idx) return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (bools,_) -> BoolSlices(id, client, slices.Trigger, bools)) + |> Result.map (fun (bools,_) -> BoolSlices(id, client, slices.Trigger, bools)) else "empty slices value" |> Error.asParseError "Slices.FromFB" - |> Either.fail + |> Result.fail | SlicesTypeFB.BytesFB -> let slicesish = fb.Slices() if slicesish.HasValue then let slices = slicesish.Value let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m let bytes = slices.Values(idx) |> String.decodeBase64 parsed.[idx] <- bytes return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (bytes,_) -> ByteSlices(id, client, bytes)) + |> Result.map (fun (bytes,_) -> ByteSlices(id, client, bytes)) else "empty slices value" |> Error.asParseError "Slices.FromFB" - |> Either.fail + |> Result.fail | SlicesTypeFB.KeyValuesFB -> let slicesish = fb.Slices() if slicesish.HasValue then let slices = slicesish.Value let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m let! prop = let propish = slices.Values(idx) @@ -3525,23 +3524,23 @@ type Slices = else "could not parse empty property" |> Error.asParseError "Slices.FromFB" - |> Either.fail + |> Result.fail parsed.[idx] <- prop return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (props,_) -> EnumSlices(id, client, props)) + |> Result.map (fun (props,_) -> EnumSlices(id, client, props)) else "empty slices value" |> Error.asParseError "Slices.FromFB" - |> Either.fail + |> Result.fail | SlicesTypeFB.ColorSpacesFB -> let slicesish = fb.Slices() if slicesish.HasValue then let slices = slicesish.Value let arr = Array.zeroCreate slices.ValuesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (parsed,idx) = m let! color = let colorish = slices.Values(idx) @@ -3551,20 +3550,20 @@ type Slices = else "could not parse empty colorspace" |> Error.asParseError "Slices.FromFB" - |> Either.fail + |> Result.fail parsed.[idx] <- color return parsed, idx + 1 }) - (Right (arr, 0)) + (Ok (arr, 0)) arr - |> Either.map (fun (colors,_) -> ColorSlices(id,client,colors)) + |> Result.map (fun (colors,_) -> ColorSlices(id,client,colors)) else "empty slices value" |> Error.asParseError "Slices.FromFB" - |> Either.fail + |> Result.fail | x -> sprintf "unknown slices type: %O" x |> Error.asParseError "Slices.FromFB" - |> Either.fail + |> Result.fail #endif } @@ -3575,7 +3574,7 @@ type Slices = // ** FromBytes - static member FromBytes(raw: byte[]) : Either = + static member FromBytes(raw: byte[]) : DiscoResult = Binary.createBuffer raw |> SlicesFB.GetRootAsSlicesFB |> Slices.FromFB @@ -3725,17 +3724,17 @@ module SliceYaml = // ** toSlice - let toSlice (yml: SliceYaml) : Either = + let toSlice (yml: SliceYaml) : DiscoResult = match yml.SliceType with | "StringSlice" -> - Either.tryWith (Error.asParseError "SliceYaml.ToSlice (String)") <| fun _ -> + Result.tryWith (Error.asParseError "SliceYaml.ToSlice (String)") <| fun _ -> let parse (str: obj) = match str with | null -> null | _ -> str :?> String - StringSlice(index yml.Index, parse yml.Value) + StringSlice(1 * yml.Index, parse yml.Value) | "NumberSlice" -> - Either.tryWith (Error.asParseError "SliceYaml.ToSlice (Number)") <| fun _ -> + Result.tryWith (Error.asParseError "SliceYaml.ToSlice (Number)") <| fun _ -> let parse (value: obj) = try match value with @@ -3750,26 +3749,26 @@ module SliceYaml = |> sprintf "normalizing to 0.0. offending value: %A reason: %s" value |> Logger.err "toSlices (Number)" 0.0 - NumberSlice(index yml.Index, parse yml.Value) + NumberSlice(1 * yml.Index, parse yml.Value) | "BoolSlice" -> - Either.tryWith (Error.asParseError "SliceYaml.ToSlice (Bool)") <| fun _ -> - BoolSlice(index yml.Index, yml.Trigger, yml.Value :?> bool) + Result.tryWith (Error.asParseError "SliceYaml.ToSlice (Bool)") <| fun _ -> + BoolSlice(1 * yml.Index, yml.Trigger, yml.Value :?> bool) | "ByteSlice" -> - Either.tryWith (Error.asParseError "SliceYaml.ToSlice (Byte)") <| fun _ -> - ByteSlice(index yml.Index, yml.Value |> string |> Convert.FromBase64String) + Result.tryWith (Error.asParseError "SliceYaml.ToSlice (Byte)") <| fun _ -> + ByteSlice(1 * yml.Index, yml.Value |> string |> Convert.FromBase64String) | "EnumSlice" -> - Either.tryWith (Error.asParseError "SliceYaml.ToSlice (Enum)") <| fun _ -> + Result.tryWith (Error.asParseError "SliceYaml.ToSlice (Enum)") <| fun _ -> let pyml = yml.Value :?> PropertyYaml - EnumSlice(index yml.Index, { Key = pyml.Key; Value = pyml.Value }) + EnumSlice(1 * yml.Index, { Key = pyml.Key; Value = pyml.Value }) | "ColorSlice" -> - either { + result { let! color = Yaml.fromYaml(yml.Value :?> ColorYaml) - return ColorSlice(index yml.Index, color) + return ColorSlice(1 * yml.Index, color) } | unknown -> sprintf "Could not de-serialize unknown type: %A" unknown |> Error.asParseError "SliceYaml.ToSlice" - |> Either.fail + |> Result.fail // * SlicesYaml @@ -3838,7 +3837,7 @@ module SlicesYaml = let toSlices (yml: SlicesYaml) = match yml.SliceType with | "StringSlices" -> - Either.tryWith (Error.asParseError "SlicesYaml.ToSlice (String)") <| fun _ -> + Result.tryWith (Error.asParseError "SlicesYaml.ToSlice (String)") <| fun _ -> let parse (str: obj) = match str with | null -> null @@ -3846,7 +3845,7 @@ module SlicesYaml = let client = if isNull yml.ClientId then None else Some (DiscoId.Parse yml.ClientId) StringSlices(DiscoId.Parse yml.PinId, client, Array.map parse yml.Values) | "NumberSlices" -> - Either.tryWith (Error.asParseError "SlicesYaml.ToSlice (Number)") <| fun _ -> + Result.tryWith (Error.asParseError "SlicesYaml.ToSlice (Number)") <| fun _ -> let parse (value: obj) = try match value with @@ -3864,11 +3863,11 @@ module SlicesYaml = let client = if isNull yml.ClientId then None else Some (DiscoId.Parse yml.ClientId) NumberSlices(DiscoId.Parse yml.PinId, client, Array.map parse yml.Values) | "BoolSlices" -> - Either.tryWith (Error.asParseError "SlicesYaml.ToSlice (Bool)") <| fun _ -> + Result.tryWith (Error.asParseError "SlicesYaml.ToSlice (Bool)") <| fun _ -> let client = if isNull yml.ClientId then None else Some (DiscoId.Parse yml.ClientId) BoolSlices(DiscoId.Parse yml.PinId, client, yml.Trigger, Array.map unbox yml.Values) | "ByteSlices" -> - Either.tryWith (Error.asParseError "SlicesYaml.ToSlice (Byte)") <| fun _ -> + Result.tryWith (Error.asParseError "SlicesYaml.ToSlice (Byte)") <| fun _ -> let parse (value: obj) = match value with | :? String -> (value :?> String) |> Convert.FromBase64String @@ -3881,33 +3880,33 @@ module SlicesYaml = let client = if isNull yml.ClientId then None else Some (DiscoId.Parse yml.ClientId) ByteSlices(DiscoId.Parse yml.PinId, client, Array.map parse yml.Values) | "EnumSlices" -> - Either.tryWith (Error.asParseError "SlicesYaml.ToSlice (Enum)") <| fun _ -> + Result.tryWith (Error.asParseError "SlicesYaml.ToSlice (Enum)") <| fun _ -> let ofPyml (o: obj) = let pyml: PropertyYaml = unbox o { Key = pyml.Key; Value = pyml.Value } let client = if isNull yml.ClientId then None else Some (DiscoId.Parse yml.ClientId) EnumSlices(DiscoId.Parse yml.PinId, client, Array.map ofPyml yml.Values) | "ColorSlices" -> - either { + result { let! colors = Array.fold - (fun (m: Either) value -> either { + (fun (m: DiscoResult) value -> result { let! (idx, colors) = m let unboxed: ColorYaml = unbox value let! color = Yaml.fromYaml unboxed colors.[idx] <- color return (idx + 1, colors) }) - (Right(0, Array.zeroCreate yml.Values.Length)) + (Ok(0, Array.zeroCreate yml.Values.Length)) yml.Values - |> Either.map snd + |> Result.map snd let client = if isNull yml.ClientId then None else Some (DiscoId.Parse yml.ClientId) return ColorSlices(DiscoId.Parse yml.PinId, client, colors) } | unknown -> sprintf "Could not de-serialize unknown type: %A" unknown |> Error.asParseError "SlicesYaml.ToSlice" - |> Either.fail + |> Result.fail // * PinYaml @@ -4051,21 +4050,21 @@ module PinYaml = let toPin (yml: PinYaml) = let parseTags (yaml: PinYaml) = Array.fold - (fun (m: Either) yml -> - either { + (fun (m: DiscoResult< int * Property array>) yml -> + result { let! state = m let! parsed = Yaml.fromYaml yml (snd state).[fst state] <- parsed return (fst state + 1, snd state) }) - (Right (0, Array.zeroCreate yaml.Tags.Length)) + (Ok (0, Array.zeroCreate yaml.Tags.Length)) yaml.Tags - |> Either.map snd + |> Result.map snd try match yml.PinType with | "StringPin" -> - either { + result { let! id = DiscoId.TryParse yml.Id let! group = DiscoId.TryParse yml.PinGroupId let! client = DiscoId.TryParse yml.ClientId @@ -4076,14 +4075,14 @@ module PinYaml = let! (_, slices) = let arr = Array.zeroCreate yml.Values.Length Array.fold - (fun (m: Either) (yml: SliceYaml) -> - either { + (fun (m: DiscoResult) (yml: SliceYaml) -> + result { let! (i, arr) = m let! value = SliceYaml.toSlice yml arr.[i] <- (value.Value :?> String) return (i + 1, arr) }) - (Right(0, arr)) + (Ok(0, arr)) yml.Values return StringPin { @@ -4104,7 +4103,7 @@ module PinYaml = } } - | "NumberPin" -> either { + | "NumberPin" -> result { let! id = DiscoId.TryParse yml.Id let! group = DiscoId.TryParse yml.PinGroupId let! client = DiscoId.TryParse yml.ClientId @@ -4114,20 +4113,20 @@ module PinYaml = let! (_, slices) = let arr = Array.zeroCreate yml.Values.Length Array.fold - (fun (m: Either) (yml: SliceYaml) -> - either { + (fun (m: DiscoResult) (yml: SliceYaml) -> + result { let! (i, arr) = m let! value = SliceYaml.toSlice yml let! value = - try value.Value :?> double |> Either.succeed + try value.Value :?> double |> Result.succeed with | x -> sprintf "Could not parse double: %s" x.Message |> Error.asParseError "FromYaml NumberPin" - |> Either.fail + |> Result.fail arr.[i] <- value return (i + 1, arr) }) - (Right(0, arr)) + (Ok(0, arr)) yml.Values return NumberPin { @@ -4150,7 +4149,7 @@ module PinYaml = } } - | "BoolPin" -> either { + | "BoolPin" -> result { let! id = DiscoId.TryParse yml.Id let! group = DiscoId.TryParse yml.PinGroupId let! client = DiscoId.TryParse yml.ClientId @@ -4160,24 +4159,24 @@ module PinYaml = let! (_, slices) = let arr = Array.zeroCreate yml.Values.Length Array.fold - (fun (m: Either) (yml: SliceYaml) -> - either { + (fun (m: DiscoResult) (yml: SliceYaml) -> + result { let! (i, arr) = m let! value = SliceYaml.toSlice yml let! value = try value.Value :?> bool - |> Either.succeed + |> Result.succeed with | x -> sprintf "Could not parse double: %s" x.Message |> Error.asParseError "FromYaml NumberPin" - |> Either.fail + |> Result.fail arr.[i] <- value return (i + 1, arr) }) - (Right(0, arr)) + (Ok(0, arr)) yml.Values return BoolPin { @@ -4197,7 +4196,7 @@ module PinYaml = } } - | "BytePin" -> either { + | "BytePin" -> result { let! id = DiscoId.TryParse yml.Id let! group = DiscoId.TryParse yml.PinGroupId let! client = DiscoId.TryParse yml.ClientId @@ -4207,24 +4206,24 @@ module PinYaml = let! (_, slices) = let arr = Array.zeroCreate yml.Values.Length Array.fold - (fun (m: Either) (yml: SliceYaml) -> - either { + (fun (m: DiscoResult) (yml: SliceYaml) -> + result { let! (i, arr) = m let! value = SliceYaml.toSlice yml let! value = try value.Value :?> byte array - |> Either.succeed + |> Result.succeed with | x -> sprintf "Could not parse double: %s" x.Message |> Error.asParseError "FromYaml NumberPin" - |> Either.fail + |> Result.fail arr.[i] <- value return (i + 1, arr) }) - (Right(0, arr)) + (Ok(0, arr)) yml.Values return BytePin { @@ -4243,41 +4242,41 @@ module PinYaml = } } - | "EnumPin" -> either { + | "EnumPin" -> result { let! properties = Array.fold - (fun (m: Either) yml -> - either { + (fun (m: DiscoResult< int * Property array>) yml -> + result { let! state = m let! parsed = Yaml.fromYaml yml (snd state).[fst state] <- parsed return (fst state + 1, snd state) }) - (Right (0, Array.zeroCreate yml.Properties.Length)) + (Ok (0, Array.zeroCreate yml.Properties.Length)) yml.Properties - |> Either.map snd + |> Result.map snd let! (_, slices) = let arr = Array.zeroCreate yml.Values.Length Array.fold - (fun (m: Either) (yml: SliceYaml) -> - either { + (fun (m: DiscoResult) (yml: SliceYaml) -> + result { let! (i, arr) = m let! value = SliceYaml.toSlice yml let! value = try value.Value :?> Property - |> Either.succeed + |> Result.succeed with | x -> sprintf "Could not parse Property: %s" x.Message |> Error.asParseError "FromYaml NumberPin" - |> Either.fail + |> Result.fail arr.[i] <- value return (i + 1, arr) }) - (Right(0, arr)) + (Ok(0, arr)) yml.Values let! id = DiscoId.TryParse yml.Id @@ -4304,7 +4303,7 @@ module PinYaml = } } - | "ColorPin" -> either { + | "ColorPin" -> result { let! id = DiscoId.TryParse yml.Id let! group = DiscoId.TryParse yml.PinGroupId let! client = DiscoId.TryParse yml.ClientId @@ -4315,24 +4314,24 @@ module PinYaml = let! (_, slices) = let arr = Array.zeroCreate yml.Values.Length Array.fold - (fun (m: Either) (yml: SliceYaml) -> - either { + (fun (m: DiscoResult) (yml: SliceYaml) -> + result { let! (i, arr) = m let! value = SliceYaml.toSlice yml let! value = try value.Value :?> ColorSpace - |> Either.succeed + |> Result.succeed with | x -> sprintf "Could not parse Property: %s" x.Message |> Error.asParseError "FromYaml NumberPin" - |> Either.fail + |> Result.fail arr.[i] <- value return (i + 1, arr) }) - (Right(0, arr)) + (Ok(0, arr)) yml.Values return ColorPin { @@ -4354,12 +4353,11 @@ module PinYaml = | x -> sprintf "Could not parse PinYml type: %s" x |> Error.asParseError "PynYml.FromYaml" - |> Either.fail + |> Result.fail - with - | exn -> - sprintf "Could not parse PinYml: %s" exn.Message - |> Error.asParseError "PynYml.FromYaml" - |> Either.fail + with exn -> + sprintf "Could not parse PinYml: %s" exn.Message + |> Error.asParseError "PynYml.FromYaml" + |> Result.fail #endif diff --git a/src/Disco/Disco/Core/PinGroup.fs b/src/Disco/Disco/Core/PinGroup.fs index 5994527e..4a7d7184 100644 --- a/src/Disco/Disco/Core/PinGroup.fs +++ b/src/Disco/Disco/Core/PinGroup.fs @@ -54,18 +54,18 @@ type PinGroupYaml() = yml member yml.ToPinGroup() = - either { + result { let! id = DiscoId.TryParse yml.Id let! client = DiscoId.TryParse yml.ClientId let! pins = Array.fold - (fun (m: Either>) pinyml -> either { + (fun (m: DiscoResult>) pinyml -> result { let! pins = m let! (pin : Pin) = Yaml.fromYaml pinyml return Map.add pin.Id pin pins }) - (Right Map.empty) + (Ok Map.empty) yml.Pins let path = @@ -75,11 +75,11 @@ type PinGroupYaml() = let! refersTo = if isNull yml.RefersTo then - Either.succeed None + Result.succeed None else yml.RefersTo |> Yaml.fromYaml - |> Either.map Some + |> Result.map Some return { Id = id @@ -111,11 +111,11 @@ type ReferencedValueYaml() = member yml.ToReferencedValue() = match yml.Type.ToLowerInvariant() with - | "player" -> either { + | "player" -> result { let! id = DiscoId.TryParse yml.Id return ReferencedValue.Player id } - | "widget" -> either { + | "widget" -> result { let! id = DiscoId.TryParse yml.Id return ReferencedValue.Widget id } @@ -123,7 +123,7 @@ type ReferencedValueYaml() = other |> String.format "Could not parse ReferencedValue type: {0}" |> Error.asParseError "ReferencedValueYaml.ToReferencedValue" - |> Either.fail + |> Result.fail #endif @@ -192,22 +192,22 @@ type ReferencedValue = static member FromFB (fb: ReferencedValueFB) = #if FABLE_COMPILER match fb.Type with - | x when x = ReferencedValueTypeFB.PlayerFB -> Id.decodeId fb |> Either.map Player - | x when x = ReferencedValueTypeFB.WidgetFB -> Id.decodeId fb |> Either.map Widget + | x when x = ReferencedValueTypeFB.PlayerFB -> Id.decodeId fb |> Result.map Player + | x when x = ReferencedValueTypeFB.WidgetFB -> Id.decodeId fb |> Result.map Widget | x -> x |> String.format "Could not parse unknown ReferencedValueTypeFB {0}" |> Error.asParseError "ReferencedValue.FromFB" - |> Either.fail + |> Result.fail #else match fb.Type with - | ReferencedValueTypeFB.PlayerFB -> Id.decodeId fb |> Either.map Player - | ReferencedValueTypeFB.WidgetFB -> Id.decodeId fb |> Either.map Widget + | ReferencedValueTypeFB.PlayerFB -> Id.decodeId fb |> Result.map Player + | ReferencedValueTypeFB.WidgetFB -> Id.decodeId fb |> Result.map Widget | other -> other |> String.format "Could not parse unknown ReferencedValueTypeFB {0}" |> Error.asParseError "ReferencedValue.FromFB" - |> Either.fail + |> Result.fail #endif // ** ToOffset @@ -228,7 +228,7 @@ type ReferencedValue = // ** FromBytes - static member FromBytes (bytes: byte[]) : Either = + static member FromBytes (bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> ReferencedValueFB.GetRootAsReferencedValueFB |> ReferencedValue.FromFB @@ -319,11 +319,11 @@ type PinGroup = // |___/ static member FromFB (fb: PinGroupFB) = - either { + result { let! pins = let arr = Array.zeroCreate fb.PinsLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, pins) = m #if FABLE_COMPILER @@ -337,31 +337,31 @@ type PinGroup = else "Could not parse empty PinFB" |> Error.asParseError "PinGroup.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add pin.Id pin pins) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd let! refersTo = #if FABLE_COMPILER if isNull fb.RefersTo then - Either.succeed None + Result.succeed None else fb.RefersTo |> ReferencedValue.FromFB - |> Either.map Some + |> Result.map Some #else let refish = fb.RefersTo if refish.HasValue then let value = refish.Value ReferencedValue.FromFB value - |> Either.map Some + |> Result.map Some else - Either.succeed None + Result.succeed None #endif let path = @@ -410,7 +410,7 @@ type PinGroup = // ** FromBytes - static member FromBytes (bytes: byte[]) : Either = + static member FromBytes (bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> PinGroupFB.GetRootAsPinGroupFB |> PinGroup.FromFB @@ -430,12 +430,12 @@ type PinGroup = #if !FABLE_COMPILER && !DISCO_NODES - static member Load(path: FilePath) : Either = + static member Load(path: FilePath) : DiscoResult = DiscoData.load path // ** LoadAll - static member LoadAll(basePath: FilePath) : Either = + static member LoadAll(basePath: FilePath) : DiscoResult = basePath filepath Constants.PINGROUP_DIR |> DiscoData.loadAll @@ -527,7 +527,7 @@ module PinGroup = group |> persistedPins |> DiscoData.save basePath - else Either.succeed () + else Result.succeed () #endif @@ -801,7 +801,7 @@ type PinGroupMap = static member FromFB(fb: PinGroupMapFB) = [ 0 .. fb.GroupsLength - 1 ] |> List.fold - (fun (m: Either) idx -> either { + (fun (m: DiscoResult) idx -> result { let! current = m let! parsed = #if FABLE_COMPILER @@ -815,12 +815,12 @@ type PinGroupMap = else "Could not parse empty PinGroup value" |> Error.asParseError "PinGroupMap.FromFB" - |> Either.fail + |> Result.fail #endif return PinGroupMap.add parsed current }) - (Right PinGroupMap.empty) + (Ok PinGroupMap.empty) // ** ToBytes @@ -828,7 +828,7 @@ type PinGroupMap = // ** FromBytes - static member FromBytes (bytes: byte[]) : Either = + static member FromBytes (bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> PinGroupMapFB.GetRootAsPinGroupMapFB |> PinGroupMap.FromFB @@ -837,8 +837,8 @@ type PinGroupMap = #if !FABLE_COMPILER && !DISCO_NODES - static member Load(path: FilePath) : Either = - either { + static member Load(path: FilePath) : DiscoResult = + result { let! groups = Asset.loadAll path return PinGroupMap.ofArray groups } @@ -847,12 +847,12 @@ type PinGroupMap = member map.Save (basePath: FilePath) = Map.fold - (fun (m: Either) _ groups -> - either { + (fun (m: DiscoResult) _ groups -> + result { let! _ = m - return! Map.fold (Asset.saveMap basePath) Either.nothing groups + return! Map.fold (Asset.saveMap basePath) Result.nothing groups }) - Either.nothing + Result.nothing map.Groups #endif diff --git a/src/Disco/Disco/Core/PinMapping.fs b/src/Disco/Disco/Core/PinMapping.fs index ae2cba23..8b707b1e 100644 --- a/src/Disco/Disco/Core/PinMapping.fs +++ b/src/Disco/Disco/Core/PinMapping.fs @@ -46,7 +46,7 @@ type PinMappingYaml() = yml member yml.ToPinMapping() = - either { + result { let! id = DiscoId.TryParse yml.Id let! source = DiscoId.TryParse yml.Source return { @@ -86,7 +86,7 @@ type PinMapping = // ** FromFB static member FromFB (fb: PinMappingFB) = - either { + result { try let! id = Id.decodeId fb let! source = Id.decodeSource fb @@ -103,7 +103,7 @@ type PinMapping = return! exn.Message |> Error.asParseError "PinMapping.FromFB" - |> Either.fail + |> Result.fail } // ** ToOffset @@ -128,7 +128,7 @@ type PinMapping = // ** FromBytes - static member FromBytes (bytes: byte[]) : Either = + static member FromBytes (bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> PinMappingFB.GetRootAsPinMappingFB |> PinMapping.FromFB @@ -143,12 +143,12 @@ type PinMapping = #if !FABLE_COMPILER && !DISCO_NODES - static member Load(path: FilePath) : Either = + static member Load(path: FilePath) : DiscoResult = DiscoData.load path // ** LoadAll - static member LoadAll(basePath: FilePath) : Either = + static member LoadAll(basePath: FilePath) : DiscoResult = basePath filepath Constants.PINMAPPING_DIR |> DiscoData.loadAll diff --git a/src/Disco/Disco/Core/PinWidget.fs b/src/Disco/Disco/Core/PinWidget.fs index 2fc9a7bf..01891c48 100644 --- a/src/Disco/Disco/Core/PinWidget.fs +++ b/src/Disco/Disco/Core/PinWidget.fs @@ -48,7 +48,7 @@ type PinWidgetYaml() = yml member yml.ToPinWidget() = - either { + result { let! id = DiscoId.TryParse yml.Id let! widget = DiscoId.TryParse yml.WidgetType return { @@ -109,7 +109,7 @@ type PinWidget = // |___/ static member FromFB (fb: PinWidgetFB) = - either { + result { let! id = Id.decodeId fb let! widget = Id.decodeWidgetType fb return { @@ -137,7 +137,7 @@ type PinWidget = // ** FromBytes - static member FromBytes (bytes: byte[]) : Either = + static member FromBytes (bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> PinWidgetFB.GetRootAsPinWidgetFB |> PinWidget.FromFB @@ -152,12 +152,12 @@ type PinWidget = #if !FABLE_COMPILER && !DISCO_NODES - static member Load(path: FilePath) : Either = + static member Load(path: FilePath) : DiscoResult = DiscoData.load path // ** LoadAll - static member LoadAll(basePath: FilePath) : Either = + static member LoadAll(basePath: FilePath) : DiscoResult = basePath filepath Constants.PINWIDGET_DIR |> DiscoData.loadAll diff --git a/src/Disco/Disco/Core/Platform.fs b/src/Disco/Disco/Core/Platform.fs index b633dde2..347ce73c 100644 --- a/src/Disco/Disco/Core/Platform.fs +++ b/src/Disco/Disco/Core/Platform.fs @@ -39,16 +39,16 @@ type Platform = static member FromFB(fb: PlatformFB) = match fb with #if FABLE_COMPILER - | x when x = PlatformFB.WindowsFB -> Right Windows - | x when x = PlatformFB.UnixFB -> Right Unix + | x when x = PlatformFB.WindowsFB -> Ok Windows + | x when x = PlatformFB.UnixFB -> Ok Unix #else - | PlatformFB.WindowsFB -> Right Windows - | PlatformFB.UnixFB -> Right Unix + | PlatformFB.WindowsFB -> Ok Windows + | PlatformFB.UnixFB -> Ok Unix #endif | other -> string other + " is not a recognized platform identifier" |> Error.asParseError "Platform.FromFB" - |> Either.fail + |> Result.fail // * Platform module diff --git a/src/Disco/Disco/Core/Project.fs b/src/Disco/Disco/Core/Project.fs index a12b8d59..9e790268 100644 --- a/src/Disco/Disco/Core/Project.fs +++ b/src/Disco/Disco/Core/Project.fs @@ -117,7 +117,7 @@ type RaftConfig = // ** FromFB static member FromFB(fb: RaftConfigFB) = - either { + result { let! level = Disco.Core.LogLevel.TryParse fb.LogLevel return { RequestTimeout = fb.RequestTimeout * 1 @@ -202,7 +202,7 @@ type ClientExecutable = // ** FromFB static member FromFB(fb: ClientExecutableFB) = - either { + result { let! id = Id.decodeId fb return { Id = id @@ -271,11 +271,11 @@ type ClientConfig = ClientConfig of Map // ** FromFB static member FromFB(fb: ClientConfigFB) = - either { + result { let! executables = List.fold - (fun (m: Either>) idx -> - either { + (fun (m: DiscoResult>) idx -> + result { let! exes = m let! exe = #if FABLE_COMPILER @@ -289,11 +289,11 @@ type ClientConfig = ClientConfig of Map else "Could not parse empty ClientExecutableFB" |> Error.asParseError "ClientConfig.FromFB" - |> Either.fail + |> Result.fail #endif return Map.add exe.Id exe exes }) - (Right Map.empty) + (Ok Map.empty) [ for n in 0 .. fb.ExecutablesLength - 1 -> n ] return ClientConfig executables } @@ -387,14 +387,14 @@ type TimingConfig = // ** FromFB static member FromFB(fb: TimingConfigFB) = - either { + result { let! (_,servers) = let arr = fb.ServersLength |> Array.zeroCreate Array.fold - (fun (m: Either) _ -> - either { + (fun (m: DiscoResult) _ -> + result { let! (idx,servers) = m let! server = fb.Servers(idx) @@ -402,7 +402,7 @@ type TimingConfig = servers.[idx] <- server return (idx + 1, servers) }) - (Right(0, arr)) + (Ok(0, arr)) arr return @@ -467,7 +467,7 @@ type AudioConfig = // ** FromFB static member FromFB(fb: AudioConfigFB) = - either { + result { return { SampleRate = fb.SampleRate } } @@ -529,20 +529,20 @@ type HostGroup = // ** FromFB static member FromFB(fb: HostGroupFB) = - either { + result { let! (_,members) = let arr = fb.MembersLength |> Array.zeroCreate Array.fold - (fun (m: Either) _ -> - either { + (fun (m: DiscoResult) _ -> + result { let! (idx, ids) = m let! id = DiscoId.TryParse (fb.Members(idx)) ids.[idx] <- id return (idx + 1, ids) }) - (Right(0, arr)) + (Ok(0, arr)) arr return @@ -565,6 +565,221 @@ module HostGroup = let setName = Optic.set HostGroup.Name_ let setMembers = Optic.set HostGroup.Members_ +// * ClusterMember + +type ClusterMember = + { Id: MemberId + HostName: Name + IpAddress: IpAddress + MulticastAddress: IpAddress + MulticastPort: Port + HttpPort: Port + RaftPort: Port + WsPort: Port + GitPort: Port + ApiPort: Port + State: MemberState + Status: MemberStatus } + + // ** optics + + static member Id_ = + (fun (mem:ClusterMember) -> mem.Id), + (fun id (mem:ClusterMember) -> { mem with Id = id }) + + static member HostName_ = + (fun (mem:ClusterMember) -> mem.HostName), + (fun hostName (mem:ClusterMember) -> { mem with HostName = hostName }) + + static member IpAddress_ = + (fun (mem:ClusterMember) -> mem.IpAddress), + (fun ipAddress (mem:ClusterMember) -> { mem with IpAddress = ipAddress }) + + static member MulticastAddress_ = + (fun (mem:ClusterMember) -> mem.MulticastAddress), + (fun multicastAddress (mem:ClusterMember) -> { mem with MulticastAddress = multicastAddress }) + + static member MulticastPort_ = + (fun (mem:ClusterMember) -> mem.MulticastPort), + (fun multicastPort (mem:ClusterMember) -> { mem with MulticastPort = multicastPort }) + + static member RaftPort_ = + (fun (mem:ClusterMember) -> mem.RaftPort), + (fun raftPort (mem:ClusterMember) -> { mem with RaftPort = raftPort }) + + static member HttpPort_ = + (fun (mem:ClusterMember) -> mem.HttpPort), + (fun httpPort (mem:ClusterMember) -> { mem with HttpPort = httpPort }) + + static member WsPort_ = + (fun (mem:ClusterMember) -> mem.WsPort), + (fun wsPort (mem:ClusterMember) -> { mem with WsPort = wsPort }) + + static member GitPort_ = + (fun (mem:ClusterMember) -> mem.GitPort), + (fun gitPort (mem:ClusterMember) -> { mem with GitPort = gitPort }) + + static member ApiPort_ = + (fun (mem:ClusterMember) -> mem.ApiPort), + (fun apiPort (mem:ClusterMember) -> { mem with ApiPort = apiPort }) + + static member State_ = + (fun (mem:ClusterMember) -> mem.State), + (fun state (mem:ClusterMember) -> { mem with State = state }) + + static member Status_ = + (fun (mem:ClusterMember) -> mem.Status), + (fun status (mem:ClusterMember) -> { mem with Status = status }) + + // ** ToYaml + + #if !FABLE_COMPILER && !DISCO_NODES + + #endif + + // ** ToOffset + + member mem.ToOffset (builder: FlatBufferBuilder) = + let id = ClusterMemberFB.CreateIdVector(builder,mem.Id.ToByteArray()) + let ip = string mem.IpAddress |> builder.CreateString + let mcastip = string mem.MulticastAddress |> builder.CreateString + + let hostname = + let unwrapped = unwrap mem.HostName + if isNull unwrapped then + None + else + unwrapped |> builder.CreateString |> Some + + let state = mem.State.ToOffset(builder) + let status = mem.Status.ToOffset() + + ClusterMemberFB.StartClusterMemberFB(builder) + ClusterMemberFB.AddId(builder, id) + + match hostname with + | Some hostname -> ClusterMemberFB.AddHostName(builder, hostname) + | None -> () + + ClusterMemberFB.AddMulticastAddress(builder, mcastip) + ClusterMemberFB.AddMulticastPort(builder, unwrap mem.MulticastPort) + ClusterMemberFB.AddIpAddress(builder, ip) + ClusterMemberFB.AddRaftPort(builder, unwrap mem.RaftPort) + ClusterMemberFB.AddHttpPort(builder, unwrap mem.HttpPort) + ClusterMemberFB.AddWsPort(builder, unwrap mem.WsPort) + ClusterMemberFB.AddGitPort(builder, unwrap mem.GitPort) + ClusterMemberFB.AddApiPort(builder, unwrap mem.ApiPort) + ClusterMemberFB.AddState(builder, state) + ClusterMemberFB.AddStatus(builder, status) + ClusterMemberFB.EndClusterMemberFB(builder) + + // ** FromFB + + static member FromFB (fb: ClusterMemberFB) : DiscoResult = + result { + let! id = Id.decodeId fb + let! state = MemberState.FromFB fb.State + let! status = MemberStatus.FromFB fb.Status + let! ip = IpAddress.TryParse fb.IpAddress + let! mcastip = IpAddress.TryParse fb.MulticastAddress + return { + Id = id + State = state + Status = status + HostName = name fb.HostName + IpAddress = ip + MulticastAddress = mcastip + MulticastPort = port fb.MulticastPort + HttpPort = port fb.HttpPort + RaftPort = port fb.RaftPort + WsPort = port fb.WsPort + GitPort = port fb.GitPort + ApiPort = port fb.ApiPort + } + } + + // ** ToBytes + + member self.ToBytes () = Binary.buildBuffer self + + // ** FromBytes + + static member FromBytes (bytes: byte[]) = + Binary.createBuffer bytes + |> ClusterMemberFB.GetRootAsClusterMemberFB + |> ClusterMember.FromFB + + +// * ClusterMember module + +module ClusterMember = + + open Aether + + // ** getters + + let id = Optic.get ClusterMember.Id_ + let hostName = Optic.get ClusterMember.HostName_ + let ipAddress = Optic.get ClusterMember.IpAddress_ + let multicastAddress = Optic.get ClusterMember.MulticastAddress_ + let multicastPort = Optic.get ClusterMember.MulticastPort_ + let raftPort = Optic.get ClusterMember.RaftPort_ + let httpPort = Optic.get ClusterMember.HttpPort_ + let wsPort = Optic.get ClusterMember.WsPort_ + let gitPort = Optic.get ClusterMember.GitPort_ + let apiPort = Optic.get ClusterMember.ApiPort_ + let status = Optic.get ClusterMember.Status_ + let state = Optic.get ClusterMember.State_ + + // ** setters + + let setId = Optic.set ClusterMember.Id_ + let setHostName = Optic.set ClusterMember.HostName_ + let setIpAddress = Optic.set ClusterMember.IpAddress_ + let setMulticastAddress = Optic.set ClusterMember.MulticastAddress_ + let setMulticastPort = Optic.set ClusterMember.MulticastPort_ + let setRaftPort = Optic.set ClusterMember.RaftPort_ + let setHttpPort = Optic.set ClusterMember.HttpPort_ + let setWsPort = Optic.set ClusterMember.WsPort_ + let setGitPort = Optic.set ClusterMember.GitPort_ + let setApiPort = Optic.set ClusterMember.ApiPort_ + let setStatus = Optic.set ClusterMember.Status_ + let setState = Optic.set ClusterMember.State_ + + // ** create + + let create id = + #if FABLE_COMPILER + let hostname = Fable.Import.Browser.window.location.host + #else + let hostname = Network.getHostName () + #endif + { Id = id + HostName = name hostname + IpAddress = IPv4Address "127.0.0.1" + MulticastAddress = IpAddress.Parse Constants.DEFAULT_MCAST_ADDRESS + MulticastPort = Measure.port Constants.DEFAULT_MCAST_PORT + HttpPort = Measure.port Constants.DEFAULT_HTTP_PORT + RaftPort = Measure.port Constants.DEFAULT_RAFT_PORT + WsPort = Measure.port Constants.DEFAULT_WEB_SOCKET_PORT + GitPort = Measure.port Constants.DEFAULT_GIT_PORT + ApiPort = Measure.port Constants.DEFAULT_API_PORT + Status = Running + State = Follower } + + // ** toRaftMember + + let toRaftMember (mem:ClusterMember) = + { Id = mem.Id + IpAddress = mem.IpAddress + RaftPort = mem.RaftPort + Status = mem.Status + State = mem.State + Voting = true + VotedForMe = false + NextIndex = 1 + MatchIndex = 0 } + // * ClusterConfig // ____ _ _ @@ -576,7 +791,7 @@ module HostGroup = type ClusterConfig = { Id: ClusterId Name: Name - Members: Map + Members: Map Groups: HostGroup array } // ** optics @@ -641,34 +856,34 @@ type ClusterConfig = // ** FromFB static member FromFB(fb: ClusterConfigFB) = - either { + result { let! (_,members) = let arr = fb.MembersLength |> Array.zeroCreate Array.fold - (fun (m: Either>) _ -> - either { + (fun (m: DiscoResult>) _ -> + result { let! (idx,members) = m let! mem = #if FABLE_COMPILER fb.Members(idx) - |> RaftMember.FromFB + |> ClusterMember.FromFB #else let memish = fb.Members(idx) if memish.HasValue then let value = memish.Value - RaftMember.FromFB value + ClusterMember.FromFB value else - "Could not parse empty RaftMemberFB" + "Could not parse empty ClusterMemberFB" |> Error.asParseError "Cluster.FromFB" - |> Either.fail + |> Result.fail #endif return (idx + 1, Map.add mem.Id mem members) }) - (Right(0, Map.empty)) + (Ok(0, Map.empty)) arr let! (_,groups) = @@ -676,8 +891,8 @@ type ClusterConfig = fb.GroupsLength |> Array.zeroCreate Array.fold - (fun (m: Either) _ -> - either { + (fun (m: DiscoResult) _ -> + result { let! (idx,groups) = m let! group = @@ -692,13 +907,13 @@ type ClusterConfig = else "Could not parse empty HostGroupFB" |> Error.asParseError "Cluster.FromFB" - |> Either.fail + |> Result.fail #endif groups.[idx] <- group return (idx + 1, groups) }) - (Right(0, arr)) + (Ok(0, arr)) arr let! id = Id.decodeId fb @@ -747,7 +962,7 @@ type DiscoConfig = Clients: ClientConfig Raft: RaftConfig Timing: TimingConfig - Sites: ClusterConfig array } + Sites: Map } // ** optics @@ -798,7 +1013,7 @@ type DiscoConfig = Clients = ClientConfig.Default Raft = RaftConfig.Default Timing = TimingConfig.Default - Sites = [| |] } + Sites = Map.empty } // ** ToOffset @@ -823,7 +1038,9 @@ type DiscoConfig = self.ActiveSite let sites = - Array.map (Binary.toOffset builder) self.Sites + self.Sites + |> Map.toArray + |> Array.map (snd >> Binary.toOffset builder) |> fun sites -> ConfigFB.CreateSitesVector(builder, sites) ConfigFB.StartConfigFB(builder) @@ -840,16 +1057,16 @@ type DiscoConfig = // ** FromFB static member FromFB(fb: ConfigFB) = - either { + result { let version = fb.Version let! site = try if fb.ActiveSiteLength = 0 - then Either.succeed None - else Id.decodeActiveSite fb |> Either.map Some + then Result.succeed None + else Id.decodeActiveSite fb |> Result.map Some with exn -> - Either.succeed None + Result.succeed None let! machine = #if FABLE_COMPILER @@ -862,7 +1079,7 @@ type DiscoConfig = else "Unable to parse empty DiscoMachineFB value" |> Error.asParseError "DiscoConfig.FromFB" - |> Either.fail + |> Result.fail #endif let! audio = @@ -876,7 +1093,7 @@ type DiscoConfig = else "Could not parse empty AudioConfigFB" |> Error.asParseError "DiscoConfig.FromFB" - |> Either.fail + |> Result.fail #endif let! clients = @@ -890,7 +1107,7 @@ type DiscoConfig = else "Could not parse empty ClientConfigFB" |> Error.asParseError "DiscoConfig.FromFB" - |> Either.fail + |> Result.fail #endif let! raft = @@ -904,7 +1121,7 @@ type DiscoConfig = else "Could not parse empty RaftConfigFB" |> Error.asParseError "DiscoConfig.FromFB" - |> Either.fail + |> Result.fail #endif let! timing = @@ -918,16 +1135,13 @@ type DiscoConfig = else "Could not parse empty TimingConfigFB" |> Error.asParseError "DiscoConfig.FromFB" - |> Either.fail + |> Result.fail #endif let! (_, sites) = - let arr = - fb.SitesLength - |> Array.zeroCreate Array.fold - (fun (m: Either) _ -> - either { + (fun (m: DiscoResult>) _ -> + result { let! (idx, sites) = m let! site = #if FABLE_COMPILER @@ -941,13 +1155,12 @@ type DiscoConfig = else "Could not parse empty ClusterConfigFB" |> Error.asParseError "DiscoConfig.FromFB" - |> Either.fail + |> Result.fail #endif - sites.[idx] <- site - return (idx + 1, sites) + return (idx + 1, Map.add site.Id site sites) }) - (Right(0, arr)) - arr + (Ok(0, Map.empty)) + [| 0 .. fb.SitesLength - 1 |] return { Machine = machine @@ -988,6 +1201,11 @@ module DiscoConfig = let setTiming = Optic.set DiscoConfig.Timing_ let setSites = Optic.set DiscoConfig.Sites_ + // ** currentSite + + let currentSite (config:DiscoConfig) = + activeSite config + // * ProjectYaml #if !FABLE_COMPILER && !DISCO_NODES @@ -1035,12 +1253,28 @@ module ProjectYaml = [] val mutable Name: string [] val mutable Members: string array + // ** ClusterMemberYaml + + type ClusterMemberYaml() = + [] val mutable Id: string + [] val mutable HostName: string + [] val mutable IpAddress: string + [] val mutable MulticastAddress: string + [] val mutable MulticastPort: uint16 + [] val mutable HttpPort: uint16 + [] val mutable RaftPort: uint16 + [] val mutable WsPort: uint16 + [] val mutable GitPort: uint16 + [] val mutable ApiPort: uint16 + [] val mutable State: string + [] val mutable Status: string + // ** SiteYaml type SiteYaml () = [] val mutable Id: string [] val mutable Name: string - [] val mutable Members: RaftMemberYaml array + [] val mutable Members: ClusterMemberYaml array [] val mutable Groups: GroupYaml array // ** DiscoProjectYaml @@ -1062,22 +1296,22 @@ module ProjectYaml = // ** parseTuple - let internal parseTuple (input: string) : Either = + let internal parseTuple (input: string) : DiscoResult = input.Split [| '('; ','; ' '; ')' |] // split the string according to the specified chars |> Array.filter (String.length >> ((<) 0)) // filter out elements that have zero length |> fun parsed -> try match parsed with - | [| x; y |] -> Right (int x, int y) + | [| x; y |] -> Ok (int x, int y) | _ -> sprintf "Cannot parse %A as (int * int) tuple" input |> Error.asParseError "Config.parseTuple" - |> Either.fail + |> Result.fail with | exn -> sprintf "Cannot parse %A as (int * int) tuple: %s" input exn.Message |> Error.asParseError "Config.parseTuple" - |> Either.fail + |> Result.fail // ** parseStringProp @@ -1091,8 +1325,8 @@ module ProjectYaml = /// Parses the Audio configuration section of the passed-in configuration file. /// /// # Returns: AudioConfig - let internal parseAudio (config: DiscoProjectYaml) : Either = - Either.tryWith (Error.asParseError "Config.parseAudio") <| fun _ -> + let internal parseAudio (config: DiscoProjectYaml) : DiscoResult = + Result.tryWith (Error.asParseError "Config.parseAudio") <| fun _ -> { SampleRate = uint32 config.Audio.SampleRate } // ** saveAudio @@ -1110,8 +1344,8 @@ module ProjectYaml = // ** parseExecutable - let internal parseExecutable (exe: ClientExecutableYaml) : Either = - either { + let internal parseExecutable (exe: ClientExecutableYaml) : DiscoResult = + result { let! id = DiscoId.TryParse exe.Id return { Id = id @@ -1123,16 +1357,16 @@ module ProjectYaml = // ** parseClients - let internal parseClients (file: DiscoProjectYaml) : Either = - either { + let internal parseClients (file: DiscoProjectYaml) : DiscoResult = + result { let! executables = Seq.fold - (fun (m: Either>) exe -> either { + (fun (m: DiscoResult>) exe -> result { let! exes = m let! exe = parseExecutable exe return Map.add exe.Id exe exes }) - (Right Map.empty) + (Ok Map.empty) file.Clients return ClientConfig executables } @@ -1164,8 +1398,8 @@ module ProjectYaml = /// Parses the passed-in configuration file contents and returns a `RaftConfig` value. /// /// Returns: RaftConfig - let internal parseRaft (config: DiscoProjectYaml) : Either = - either { + let internal parseRaft (config: DiscoProjectYaml) : DiscoResult = + result { let! loglevel = Disco.Core.LogLevel.TryParse config.Engine.LogLevel try @@ -1182,7 +1416,7 @@ module ProjectYaml = return! sprintf "Could not parse Engine config: %s" exn.Message |> Error.asParseError "Config.parseRaft" - |> Either.fail + |> Result.fail } // ** saveRaft @@ -1218,8 +1452,8 @@ module ProjectYaml = /// Parse TimingConfig related values into a TimingConfig value and return it. /// /// # Returns: TimingConfig - let internal parseTiming (config: DiscoProjectYaml) : Either = - either { + let internal parseTiming (config: DiscoProjectYaml) : DiscoResult = + result { let timing = config.Timing let arr = timing.Servers @@ -1228,13 +1462,13 @@ module ProjectYaml = let! (_,servers) = Seq.fold - (fun (m: Either) thing -> either { + (fun (m: DiscoResult) thing -> result { let! (idx, lst) = m let! server = IpAddress.TryParse thing lst.[idx] <- server return (idx + 1, lst) }) - (Right(0, arr)) + (Ok(0, arr)) timing.Servers try @@ -1249,16 +1483,12 @@ module ProjectYaml = return! sprintf "Could not parse Timing config: %s" exn.Message |> Error.asParseError "Config.parseTiming" - |> Either.fail + |> Result.fail } // ** saveTiming - /// ### Transfer the TimingConfig options to the passed configuration file - /// - /// - /// - /// # Returns: ConfigFile + /// Transfer the TimingConfig options to the passed configuration file let internal saveTiming (file: DiscoProjectYaml, config: DiscoConfig) = let timing = TimingYaml() timing.Framebase <- int (config.Timing.Framebase) @@ -1269,14 +1499,55 @@ module ProjectYaml = servers.Add(string srv) timing.Servers <- servers.ToArray() - timing.TCPPort <- int (config.Timing.TCPPort) timing.UDPPort <- int (config.Timing.UDPPort) file.Timing <- timing - (file, config) + // ** parseMember + + let internal parseMember (yaml:ClusterMemberYaml) = + result { + let! id = DiscoId.TryParse yaml.Id + let! ip = IpAddress.TryParse yaml.IpAddress + let! mcastip = IpAddress.TryParse yaml.MulticastAddress + let! state = MemberState.TryParse yaml.State + let! status = MemberStatus.TryParse yaml.Status + return { + Id = id + HostName = name yaml.HostName + MulticastAddress = mcastip + MulticastPort = port yaml.MulticastPort + IpAddress = ip + HttpPort = port yaml.HttpPort + RaftPort = port yaml.RaftPort + WsPort = port yaml.WsPort + GitPort = port yaml.GitPort + ApiPort = port yaml.ApiPort + State = state + Status = status + } + } + // ** saveMember + + let internal saveMember (mem:ClusterMember) = + let yaml = ClusterMemberYaml() + yaml.Id <- string mem.Id + yaml.HostName <- unwrap mem.HostName + yaml.IpAddress <- string mem.IpAddress + yaml.MulticastAddress <- string mem.MulticastAddress + yaml.MulticastPort <- unwrap mem.MulticastPort + yaml.HttpPort <- unwrap mem.HttpPort + yaml.RaftPort <- unwrap mem.RaftPort + yaml.WsPort <- unwrap mem.WsPort + yaml.GitPort <- unwrap mem.GitPort + yaml.ApiPort <- unwrap mem.ApiPort + yaml.State <- string mem.State + yaml.Status <- string mem.Status + yaml + + // ** parseMembers /// ## Parse a collectio of Member definitions @@ -1286,17 +1557,17 @@ module ProjectYaml = /// ### Signature: /// - mems: MemberYaml collection /// - /// Returns: Either - let internal parseMembers mems : Either> = - either { + /// Returns: DiscoResult + let internal parseMembers mems : DiscoResult> = + result { let! (_,mems) = Seq.fold - (fun (m: Either>) mem -> either { + (fun (m: DiscoResult>) mem -> result { let! (idx, mems) = m - let! mem = RaftMember.FromYaml mem + let! mem = parseMember mem return (idx + 1, Map.add mem.Id mem mems) }) - (Right(0, Map.empty)) + (Ok(0, Map.empty)) mems return mems @@ -1304,8 +1575,8 @@ module ProjectYaml = // ** parseGroup - let internal parseGroup (group: GroupYaml) : Either = - either { + let internal parseGroup (group: GroupYaml) : DiscoResult = + result { let ids = Seq.map (string >> DiscoId.Parse) group.Members |> Seq.toArray return { Name = name group.Name @@ -1315,8 +1586,8 @@ module ProjectYaml = // ** parseGroups - let internal parseGroups groups : Either = - either { + let internal parseGroups groups : DiscoResult = + result { let arr = groups |> Seq.length @@ -1324,13 +1595,13 @@ module ProjectYaml = let! (_, groups) = Seq.fold - (fun (m: Either) group -> either { + (fun (m: DiscoResult) group -> result { let! (idx, groups) = m let! group = parseGroup group groups.[idx] <- group return (idx + 1, groups) }) - (Right(0,arr)) + (Ok(0,arr)) groups return groups @@ -1338,14 +1609,15 @@ module ProjectYaml = // ** parseCluster + /// ### Parse the Cluster configuration section /// /// Parse the cluster configuration section of a given configuration file into a `Cluster` value. /// /// # Returns: Cluster - let internal parseCluster (cluster: SiteYaml) : Either = - either { + let internal parseCluster (cluster: SiteYaml) : DiscoResult = + result { let! groups = parseGroups cluster.Groups let! mems = parseMembers cluster.Members let! id = DiscoId.TryParse cluster.Id @@ -1359,25 +1631,18 @@ module ProjectYaml = // ** parseSites - let internal parseSites (config: DiscoProjectYaml) : Either = - either { - let arr = - config.Sites - |> Seq.length - |> Array.zeroCreate - + let internal parseSites (config: DiscoProjectYaml) = + result { let! (_, sites) = Seq.fold - (fun (m: Either) cfg -> - either { + (fun (m: DiscoResult>) cfg -> + result { let! (idx, sites) = m let! site = parseCluster cfg - sites.[idx] <- site - return (idx + 1, sites) + return (idx + 1, Map.add site.Id site sites) }) - (Right(0, arr)) + (Ok(0, Map.empty)) config.Sites - return sites } @@ -1395,16 +1660,16 @@ module ProjectYaml = | Some id -> file.ActiveSite <- string id | None -> file.ActiveSite <- null - for cluster in config.Sites do + for KeyValue(id, cluster) in config.Sites do let cfg = SiteYaml() let members = ResizeArray() let groups = ResizeArray() - cfg.Id <- string cluster.Id + cfg.Id <- string id cfg.Name <- unwrap cluster.Name for KeyValue(_,mem) in cluster.Members do - let mem = mem.ToYaml() + let mem = saveMember mem members.Add(mem) for group in cluster.Groups do @@ -1459,12 +1724,12 @@ module ProjectYaml = try str |> Yaml.deserialize - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asParseError "ProjectYaml.parse" - |> Either.fail + |> Result.fail #endif @@ -1489,8 +1754,8 @@ module Config = let fromFile (file: ProjectYaml.DiscoProjectYaml) (machine: DiscoMachine) - : Either = - either { + : DiscoResult = + result { let version = file.Version let! raftcfg = ProjectYaml.parseRaft file let! timing = ProjectYaml.parseTiming file @@ -1500,8 +1765,8 @@ module Config = let! site = if isNull file.ActiveSite || file.ActiveSite = "" - then Right None - else DiscoId.TryParse file.ActiveSite |> Either.map Some + then Ok None + else DiscoId.TryParse file.ActiveSite |> Result.map Some return { Machine = machine @@ -1547,7 +1812,7 @@ module Config = Audio = AudioConfig.Default Raft = RaftConfig.Default Timing = TimingConfig.Default - Sites = [| |] } + Sites = Map.empty } // ** updateMachine @@ -1574,33 +1839,14 @@ module Config = let updateTiming (timing: TimingConfig) (config: DiscoConfig) = { config with Timing = timing } - // ** updateCluster - - let updateCluster (cluster: ClusterConfig) (config: DiscoConfig) = - let sites = - Array.map - (fun (site: ClusterConfig) -> - if cluster.Id = site.Id - then cluster - else site) - config.Sites - { config with Sites = sites } - // ** updateSite let updateSite (site: ClusterConfig) (config: DiscoConfig) = - let sites = - Array.map - (fun existing -> - if ClusterConfig.id existing = ClusterConfig.id site - then site - else existing) - config.Sites - { config with Sites = sites } + { config with Sites = Map.add site.Id site config.Sites } // ** updateSites - let updateSites (sites: ClusterConfig array) (config: DiscoConfig) = + let updateSites (sites: Map) (config: DiscoConfig) = { config with Sites = sites } // ** findMember @@ -1608,61 +1854,61 @@ module Config = let findMember (config: DiscoConfig) (id: MemberId) = match config.ActiveSite with | Some active -> - match Array.tryFind (fun (clst: ClusterConfig) -> clst.Id = active) config.Sites with + match Map.tryFind active config.Sites with | Some cluster -> match Map.tryFind id cluster.Members with - | Some mem -> Either.succeed mem + | Some mem -> Result.succeed mem | _ -> ErrorMessages.PROJECT_MISSING_MEMBER + ": " + (string id) |> Error.asProjectError "Config.findMember" - |> Either.fail + |> Result.fail | _ -> ErrorMessages.PROJECT_MISSING_CLUSTER + ": " + (string active) |> Error.asProjectError "Config.findMember" - |> Either.fail + |> Result.fail | None -> ErrorMessages.PROJECT_NO_ACTIVE_CONFIG |> Error.asProjectError "Config.findMember" - |> Either.fail + |> Result.fail // ** tryFindMember let tryFindMember (config: DiscoConfig) (id: MemberId) = match findMember config id with - | Right mem -> Some mem + | Ok mem -> Some mem | _ -> None // ** getMembers - let getMembers (config: DiscoConfig) : Either> = + let getMembers (config: DiscoConfig) = match config.ActiveSite with | Some active -> - match Array.tryFind (fun (clst: ClusterConfig) -> clst.Id = active) config.Sites with - | Some site -> site.Members |> Either.succeed + match Map.tryFind active config.Sites with + | Some site -> site.Members |> Result.succeed | None -> ErrorMessages.PROJECT_MISSING_CLUSTER + ": " + (string active) |> Error.asProjectError "Config.getMembers" - |> Either.fail + |> Result.fail | None -> ErrorMessages.PROJECT_NO_ACTIVE_CONFIG |> Error.asProjectError "Config.getMembers" - |> Either.fail + |> Result.fail // ** setActiveSite let setActiveSite (id: SiteId) (config: DiscoConfig) = - if config.Sites |> Array.exists (fun x -> x.Id = id) - then Right { config with ActiveSite = Some id } + if Map.containsKey id config.Sites + then Ok { config with ActiveSite = Some id } else ErrorMessages.PROJECT_MISSING_MEMBER + ": " + (string id) |> Error.asProjectError "Config.setActiveSite" - |> Either.fail + |> Result.fail // ** getActiveSite let getActiveSite (config: DiscoConfig) = match config.ActiveSite with - | Some id -> Array.tryFind (fun (site: ClusterConfig) -> site.Id = id) config.Sites + | Some id -> Map.tryFind id config.Sites | None -> None // ** getActiveMember @@ -1674,12 +1920,12 @@ module Config = // ** setMembers - let setMembers (mems: Map) (config: DiscoConfig) = + let setMembers (mems: Map) (config: DiscoConfig) = match config.ActiveSite with | Some active -> - match Array.tryFind (fun (clst: ClusterConfig) -> clst.Id = active) config.Sites with + match Map.tryFind active config.Sites with | Some site -> - updateCluster { site with Members = mems } config + updateSite { site with Members = mems } config | None -> config | None -> config @@ -1692,7 +1938,7 @@ module Config = // ** validateSettings /// Cross-check the settins in a given cluster member definition with this machines settings - let validateSettings (mem: RaftMember) (machine:DiscoMachine): Either = + let validateSettings (mem: ClusterMember) (machine:DiscoMachine): DiscoResult = let errorMsg tag a b = sprintf "Member %s: %O is different from Machine %s: %O\n" tag a tag b let errors = [ @@ -1708,23 +1954,20 @@ module Config = yield errorMsg "WS Post" mem.WsPort machine.WsPort ] if List.isEmpty errors - then Either.nothing + then Result.nothing else errors |> List.fold ((+)) "" |> Error.asProjectError (tag "validateSettings") - |> Either.fail + |> Result.fail // ** addSitePrivate let private addSitePrivate (site: ClusterConfig) setActive (config: DiscoConfig) = - let i = config.Sites |> Array.tryFindIndex (fun s -> s.Id = site.Id) - let copy = Array.zeroCreate (config.Sites.Length + (if Option.isSome i then 0 else 1)) - Array.iteri (fun i s -> copy.[i] <- s) config.Sites - copy.[match i with Some i -> i | None -> config.Sites.Length] <- site + let sites = Map.add site.Id site config.Sites if setActive - then { config with ActiveSite = Some site.Id; Sites = copy } - else { config with Sites = copy } + then { config with ActiveSite = Some site.Id; Sites = sites } + else { config with Sites = sites } // ** addSite @@ -1741,19 +1984,18 @@ module Config = // ** removeSite let removeSite (id: SiteId) (config: DiscoConfig) = - let sites = Array.filter (fun (site: ClusterConfig) -> site.Id <> id) config.Sites - { config with Sites = sites } + { config with Sites = Map.remove id config.Sites } // ** siteByMember let siteByMember (memid: SiteId) (config: DiscoConfig) = - Array.fold - (fun (m: ClusterConfig option) site -> + Map.fold + (fun (m: ClusterConfig option) _ site -> match m with | Some _ -> m | None -> - if Map.containsKey memid site.Members then - Some site + if Map.containsKey memid site.Members + then Some site else None) None config.Sites @@ -1761,17 +2003,17 @@ module Config = // ** findSite let findSite (id: SiteId) (config: DiscoConfig) = - Array.tryFind (fun (site: ClusterConfig) -> site.Id = id) config.Sites + Map.tryFind id config.Sites // ** addMember - let addMember (mem: RaftMember) (config: DiscoConfig) = + let addMember (mem: ClusterMember) (config: DiscoConfig) = match config.ActiveSite with | Some active -> - match Array.tryFind (fun clst -> ClusterConfig.id clst = active) config.Sites with + match Map.tryFind active config.Sites with | Some site -> let mems = Map.add mem.Id mem site.Members - updateCluster { site with Members = mems } config + updateSite { site with Members = mems } config | None -> config | None -> config @@ -1780,10 +2022,10 @@ module Config = let removeMember (id: MemberId) (config: DiscoConfig) = match config.ActiveSite with | Some active -> - match Array.tryFind (fun (clst:ClusterConfig) -> clst.Id = active) config.Sites with + match Map.tryFind active config.Sites with | Some site -> let mems = Map.remove id site.Members - updateCluster { site with Members = mems } config + updateSite { site with Members = mems } config | None -> config | None -> config @@ -1923,7 +2165,7 @@ Config: %A // |_____\___/ \__,_|\__,_| static member Load (basepath: FilePath, machine: DiscoMachine) = - either { + result { let filename = PROJECT_FILENAME + ASSET_EXTENSION let normalizedPath = @@ -1941,7 +2183,7 @@ Config: %A return! sprintf "Project Not Found: %O" normalizedPath |> Error.asProjectError "Project.load" - |> Either.fail + |> Result.fail else let! project = DiscoData.load normalizedPath return @@ -2015,26 +2257,26 @@ Config: %A // ** FromFB static member FromFB(fb: ProjectFB) = - either { + result { let nll = sprintf "%A" null let! lastsaved = match fb.LastSaved with - | null -> Right None - | value when value = nll -> Right (Some null) - | date -> Right (Some date) + | null -> Ok None + | value when value = nll -> Ok (Some null) + | date -> Ok (Some date) let! copyright = match fb.Copyright with - | null -> Right None - | value when value = nll -> Right (Some null) - | str -> Right (Some str) + | null -> Ok None + | value when value = nll -> Ok (Some null) + | str -> Ok (Some str) let! author = match fb.Author with - | null -> Right None - | value when value = nll -> Right (Some null) - | str -> Right (Some str) + | null -> Ok None + | value when value = nll -> Ok (Some null) + | str -> Ok (Some str) let! config = #if FABLE_COMPILER @@ -2047,7 +2289,7 @@ Config: %A else "Could not parse empty ConfigFB" |> Error.asParseError "DiscoProject.FromFB" - |> Either.fail + |> Result.fail #endif let! id = Id.decodeId fb @@ -2104,7 +2346,7 @@ Config: %A // ** FromYaml static member FromYaml(meta: ProjectYaml.DiscoProjectYaml) = - either { + result { let lastSaved = match meta.LastSaved with | null | "" -> None @@ -2149,21 +2391,15 @@ module Project = let id = Optic.get DiscoProject.Id_ let name = Optic.get DiscoProject.Name_ + let config = Optic.get DiscoProject.Config_ + let path = Optic.get DiscoProject.Path_ // ** setters let setId = Optic.set DiscoProject.Id_ let setName = Optic.set DiscoProject.Name_ - - // ** toFilePath - - let toFilePath (path: FilePath) = - path |> unwrap |> filepath - - // ** ofFilePath - - let ofFilePath (path: FilePath) = - path |> unwrap |> filepath + let setConfig = Optic.set DiscoProject.Config_ + let setPath = Optic.set DiscoProject.Path_ // ** repository @@ -2173,11 +2409,9 @@ module Project = /// /// Computes the path to the passed projects' git repository from its `Path` field and checks /// whether it exists. If so, construct a git Repository object and return that. - /// - /// # Returns: Repository option + let repository (project: DiscoProject) = - project.Path - |> Git.Repo.repository + Git.Repo.repository project.Path #endif @@ -2186,14 +2420,14 @@ module Project = let localRemote (project: DiscoProject) = project.Config |> Config.getActiveMember - |> Option.map (Uri.gitUri project.Name) + |> Option.map (fun mem -> Uri.gitUri project.Name mem.IpAddress mem.GitPort) // ** currentBranch #if !FABLE_COMPILER && !DISCO_NODES let currentBranch (project: DiscoProject) = - either { + result { let! repo = repository project return Git.Branch.current repo } @@ -2205,7 +2439,7 @@ module Project = #if !FABLE_COMPILER && !DISCO_NODES let checkoutBranch (name: string) (project: DiscoProject) = - either { + result { let! repo = repository project return! Git.Repo.checkout name repo } @@ -2228,9 +2462,9 @@ module Project = if File.exists path |> not then sprintf "Project Not Found: %O" projectName |> Error.asProjectError (tag "checkPath") - |> Either.fail + |> Result.fail else - Either.succeed path + Result.succeed path #endif @@ -2259,7 +2493,7 @@ module Project = #if !FABLE_COMPILER && !DISCO_NODES let private writeDaemonExportFile (repo: Repository) = - either { + result { let path = repo.Info.Path <.> "git-daemon-export-ok" let! _ = DiscoData.write path (Payload "") return () @@ -2272,7 +2506,7 @@ module Project = #if !FABLE_COMPILER && !DISCO_NODES let private writeGitIgnoreFile (repo: Repository) = - either { + result { let parent = Git.Repo.parentPath repo let path = parent filepath ".gitignore" let! _ = DiscoData.write path (Payload GITIGNORE) @@ -2286,7 +2520,7 @@ module Project = #if !FABLE_COMPILER && !DISCO_NODES let private createAssetDir (repo: Repository) (dir: FilePath) = - either { + result { let parent = Git.Repo.parentPath repo let target = parent dir do! FileSystem.mkDir target @@ -2316,14 +2550,14 @@ module Project = (committer: Signature) (msg : string) (project: DiscoProject) : - Either = - either { + DiscoResult = + result { let! repo = repository project let abspath = if Path.isPathRooted filepath then filepath else - toFilePath project.Path filepath + project.Path filepath do! Git.Repo.stage repo abspath let! commit = Git.Repo.commit repo msg committer return commit, project @@ -2340,9 +2574,9 @@ module Project = (committer: Signature) (msg : string) (project: DiscoProject) : - Either = + DiscoResult = - either { + result { let info = File.info path do! info.Directory.FullName |> filepath |> FileSystem.mkDir let! _ = DiscoData.write path (Payload contents) @@ -2359,8 +2593,8 @@ module Project = (committer: Signature) (msg : string) (project: DiscoProject) : - Either = - either { + DiscoResult = + result { let! _ = DiscoData.remove path return! commitPath path committer msg project } @@ -2381,7 +2615,7 @@ module Project = /// - committer: User the thing to save. Must implement certain methods/getters /// - project: Project to save file into /// - /// Returns: Either + /// Returns: DiscoResult let inline saveAsset (thing: ^t) (committer: User) (project: DiscoProject) = let payload = thing |> Yaml.encode let filepath = project.Path Asset.path thing @@ -2405,7 +2639,7 @@ module Project = /// - msg: User committing the change /// - project: DiscoProject to work on /// - /// Returns: Either + /// Returns: DiscoResult let inline deleteAsset (thing: ^t) (committer: User) (project: DiscoProject) = let filepath = project.Path Asset.path thing let signature = committer.Signature @@ -2438,15 +2672,15 @@ module Project = /// exists, otherwise creating it. /// /// # Returns: Repository - let private initRepo (project: DiscoProject) : Either = - either { + let private initRepo (project: DiscoProject) : DiscoResult = + result { let! repo = project.Path |> Git.Repo.init do! writeDaemonExportFile repo do! Git.Repo.setReceivePackConfig repo do! writeGitIgnoreFile repo do! List.fold - (fun m dir -> Either.bind (fun () -> createAssetDir repo (filepath dir)) m) - Either.nothing + (fun m dir -> Result.bind (fun () -> createAssetDir repo (filepath dir)) m) + Result.nothing Constants.GLOBAL_ASSET_DIRS let relPath = Asset.path User.Admin let absPath = project.Path relPath @@ -2471,7 +2705,7 @@ module Project = /// /// # Returns: DiscoProject let create (path: FilePath) (projectName: string) (machine: DiscoMachine) = - either { + result { let project = { Id = DiscoId.Create() Name = Measure.name projectName @@ -2483,43 +2717,29 @@ module Project = Config = Config.create machine } do! initRepo project - let! _ = DiscoData.saveWithCommit (toFilePath path) User.Admin.Signature project + let! _ = DiscoData.saveWithCommit path User.Admin.Signature project return project } #endif - // ** config - - let config (project: DiscoProject) : DiscoConfig = project.Config - - // ** updatePath - - let updatePath (path: FilePath) (project: DiscoProject) : DiscoProject = - { project with Path = path } - - // ** updateConfig - - let updateConfig (config: DiscoConfig) (project: DiscoProject) : DiscoProject = - { project with Config = config } - // ** updateDataDir let updateDataDir (raftDir: FilePath) (project: DiscoProject) : DiscoProject = { project.Config.Raft with DataDir = raftDir } |> flip Config.updateEngine project.Config - |> flip updateConfig project + |> flip setConfig project // ** addMember - let addMember (mem: RaftMember) (project: DiscoProject) : DiscoProject = + let addMember (mem: ClusterMember) (project: DiscoProject) : DiscoProject = project.Config |> Config.addMember mem - |> flip updateConfig project + |> flip setConfig project // ** updateMember - let updateMember (mem: RaftMember) (project: DiscoProject) : DiscoProject = + let updateMember (mem: ClusterMember) (project: DiscoProject) : DiscoProject = addMember mem project // ** removeMember @@ -2527,7 +2747,7 @@ module Project = let removeMember (mem: MemberId) (project: DiscoProject) : DiscoProject = project.Config |> Config.removeMember mem - |> flip updateConfig project + |> flip setConfig project // ** findMember @@ -2541,13 +2761,13 @@ module Project = // ** addMembers - let addMembers (mems: RaftMember list) (project: DiscoProject) : DiscoProject = + let addMembers (mems: ClusterMember list) (project: DiscoProject) : DiscoProject = List.fold - (fun config (mem: RaftMember) -> + (fun config (mem: ClusterMember) -> Config.addMember mem config) project.Config mems - |> flip updateConfig project + |> flip setConfig project // ** updateMachine @@ -2560,16 +2780,16 @@ module Project = /// Using the current active site configuration, update git remotes to reflect the configured /// members' details. This allows the service to use `git push` to those peers. - let updateRemotes (project: DiscoProject) = either { + let updateRemotes (project: DiscoProject) = result { let! repo = repository project // delete all current remotes let current = Git.Config.remotes repo do! Map.fold - (fun kontinue name _ -> either { + (fun kontinue name _ -> result { do! kontinue do! Git.Config.delRemote repo name }) - (Right ()) + (Ok ()) current let! mem = Config.selfMember project.Config @@ -2578,18 +2798,45 @@ module Project = do! match Config.getActiveSite project.Config with | Some cluster -> Map.fold - (fun kontinue id peer -> either { + (fun kontinue id peer -> result { do! kontinue if id <> mem.Id then - let url = Uri.gitUri project.Name peer + let url = Uri.gitUri project.Name peer.IpAddress peer.GitPort let name = string peer.Id do! Git.Config.addRemote repo name url - |> Either.iterError (string >> Logger.err (tag "updateRemotes")) - |> Either.succeed + |> Result.iterError (string >> Logger.err (tag "updateRemotes")) + |> Result.succeed }) - (Right ()) + (Ok ()) cluster.Members - | None -> Either.nothing + | None -> Result.nothing } #endif + +// * Machine module + +module Machine = + + // ** toClusterMember + + let toClusterMember (machine: DiscoMachine) = + { Id = machine.MachineId + HostName = machine.HostName + IpAddress = machine.BindAddress + MulticastAddress = machine.MulticastAddress + MulticastPort = machine.MulticastPort + HttpPort = machine.WebPort + RaftPort = machine.RaftPort + WsPort = machine.WsPort + GitPort = machine.GitPort + ApiPort = machine.ApiPort + State = MemberState.Follower + Status = MemberStatus.Running } + + // ** toRaftMember + + let toRaftMember (machine: DiscoMachine) = + { Member.create machine.MachineId with + IpAddress = machine.BindAddress + RaftPort = machine.RaftPort } diff --git a/src/Disco/Disco/Core/Property.fs b/src/Disco/Disco/Core/Property.fs index 6a926674..13982266 100644 --- a/src/Disco/Disco/Core/Property.fs +++ b/src/Disco/Disco/Core/Property.fs @@ -68,7 +68,7 @@ type Property = static member FromFB(fb: KeyValueFB) = { Key = fb.Key; Value = fb.Value } - |> Either.succeed + |> Result.succeed // ** ToYaml @@ -79,14 +79,14 @@ type Property = // ** FromYaml - static member FromYaml(yml: PropertyYaml) : Either = + static member FromYaml(yml: PropertyYaml) : DiscoResult = try { Key = yml.Key; Value = yml.Value } - |> Either.succeed + |> Result.succeed with | exn -> ("Property.FromYaml",sprintf "Could not parse PropteryYaml: %s" exn.Message) |> ParseError - |> Either.fail + |> Result.fail #endif diff --git a/src/Disco/Disco/Core/Serialization.fs b/src/Disco/Disco/Core/Serialization.fs index c76a2564..9d6959d7 100644 --- a/src/Disco/Disco/Core/Serialization.fs +++ b/src/Disco/Disco/Core/Serialization.fs @@ -21,12 +21,12 @@ open FlatBuffers #endif -// * EitherExt module +// * ResultExt module [] -module EitherExt = +module ResultExt = - let bindGeneratorToArray loc length generator (f: 'a -> Either) = + let bindGeneratorToArray loc length generator (f: 'a -> DiscoResult<'b>) = let mutable i = 0 let mutable error = None let arr = Array.zeroCreate length @@ -41,11 +41,11 @@ module EitherExt = let item = generator i #endif match f item with - | Right value -> arr.[i] <- value; i <- i + 1 - | Left err -> error <- Some err + | Ok value -> arr.[i] <- value; i <- i + 1 + | Error err -> error <- Some err match error with - | Some err -> Left err - | None -> Right arr + | Some err -> Error err + | None -> Ok arr // * Binary module @@ -75,16 +75,16 @@ module Binary = // ** decode - let inline decode< ^t when ^t : (static member FromBytes : byte[] -> Either)> + let inline decode< ^t when ^t : (static member FromBytes : byte[] -> DiscoResult< ^t >)> (bytes: byte[]) : - Either = + DiscoResult< ^t > = try - (^t : (static member FromBytes : byte[] -> Either) bytes) + (^t : (static member FromBytes : byte[] -> DiscoResult< ^t >) bytes) with | exn -> ((typeof< ^t >).Name + ".FromBytes", exn.Message) |> ParseError - |> Either.fail + |> Result.fail // ** toOffset @@ -145,9 +145,9 @@ module Yaml = // ** fromYaml - let inline fromYaml< ^err, ^a, ^t when ^t : (static member FromYaml : ^a -> Either< ^err, ^t >)> + let inline fromYaml< ^err, ^a, ^t when ^t : (static member FromYaml : ^a -> Result< ^t,^err >)> (thing: ^a) = - (^t : (static member FromYaml : ^a -> Either< ^err, ^t >) thing) + (^t : (static member FromYaml : ^a -> Result< ^t,^err >) thing) // ** encode @@ -156,14 +156,14 @@ module Yaml = // ** decode - let inline decode< ^a, ^t when ^t : (static member FromYaml: ^a -> Either)> + let inline decode< ^a, ^t when ^t : (static member FromYaml: ^a -> DiscoResult< ^t >)> (str: string) = try let thing = str |> deserialize< ^a > - (^t : (static member FromYaml : ^a -> Either) thing) + (^t : (static member FromYaml : ^a -> DiscoResult< ^t >) thing) with exn -> exn.Message |> Error.asParseError "Yaml.decode" - |> Either.fail + |> Result.fail #endif diff --git a/src/Disco/Disco/Core/Session.fs b/src/Disco/Disco/Core/Session.fs index 35bb71e2..2758f69c 100644 --- a/src/Disco/Disco/Core/Session.fs +++ b/src/Disco/Disco/Core/Session.fs @@ -79,8 +79,8 @@ type Session = // |____/|_|_| |_|\__,_|_| \__, | // |___/ - static member FromFB(fb: SessionFB) : Either = - either { + static member FromFB(fb: SessionFB) : DiscoResult = + result { let! ip = IpAddress.TryParse fb.IpAddress let! id = Id.decodeId fb return { @@ -92,7 +92,7 @@ type Session = // ** FromBytes - static member FromBytes(bytes: byte[]) : Either = + static member FromBytes(bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> SessionFB.GetRootAsSessionFB |> Session.FromFB @@ -132,7 +132,7 @@ type Session = // ** FromYaml static member FromYaml (yml: SessionYaml) = - either { + result { let! ip = IpAddress.TryParse yml.IpAddress let! id = DiscoId.TryParse yml.Id return { diff --git a/src/Disco/Disco/Core/StateMachine.fs b/src/Disco/Disco/Core/StateMachine.fs index 5f50980e..4fba43be 100644 --- a/src/Disco/Disco/Core/StateMachine.fs +++ b/src/Disco/Disco/Core/StateMachine.fs @@ -86,7 +86,7 @@ type AppCommand = // ** TryParse static member TryParse (str: string) = - Either.tryWith (Error.asParseError "AppCommand.TryParse") <| fun _ -> + Result.tryWith (Error.asParseError "AppCommand.TryParse") <| fun _ -> str |> AppCommand.Parse // ** FromFB @@ -94,24 +94,24 @@ type AppCommand = static member FromFB (fb: StateMachineActionFB) = #if FABLE_COMPILER match fb with - | x when x = StateMachineActionFB.UndoFB -> Right Undo - | x when x = StateMachineActionFB.RedoFB -> Right Redo - | x when x = StateMachineActionFB.ResetFB -> Right Reset - | x when x = StateMachineActionFB.SaveFB -> Right Save + | x when x = StateMachineActionFB.UndoFB -> Ok Undo + | x when x = StateMachineActionFB.RedoFB -> Ok Redo + | x when x = StateMachineActionFB.ResetFB -> Ok Reset + | x when x = StateMachineActionFB.SaveFB -> Ok Save | x -> sprintf "Could not parse %A as AppCommand" x |> Error.asParseError "AppCommand.FromFB" - |> Either.fail + |> Result.fail #else match fb with - | StateMachineActionFB.UndoFB -> Right Undo - | StateMachineActionFB.RedoFB -> Right Redo - | StateMachineActionFB.ResetFB -> Right Reset - | StateMachineActionFB.SaveFB -> Right Save + | StateMachineActionFB.UndoFB -> Ok Undo + | StateMachineActionFB.RedoFB -> Ok Redo + | StateMachineActionFB.ResetFB -> Ok Reset + | StateMachineActionFB.SaveFB -> Ok Save | x -> sprintf "Could not parse %A as AppCommand" x |> Error.asParseError "AppCommand.FromFB" - |> Either.fail + |> Result.fail #endif // ** ToOffset @@ -254,8 +254,8 @@ type State = #if !FABLE_COMPILER && !DISCO_NODES static member Load (path: FilePath, machine: DiscoMachine) = - either { - let inline toMap value = Either.map (Array.map toPair >> Map.ofArray) value + result { + let inline toMap value = Result.map (Array.map toPair >> Map.ofArray) value let! project = Asset.loadWithMachine path machine let! groups = Asset.load project.Path let! widgets = Asset.loadAll project.Path |> toMap @@ -293,13 +293,13 @@ type State = #if !FABLE_COMPILER && !DISCO_NODES member state.Save (basePath: FilePath) = - either { - do! Map.fold (Asset.saveMap basePath) Either.nothing state.PinMappings - do! Map.fold (Asset.saveMap basePath) Either.nothing state.PinWidgets - do! Map.fold (Asset.saveMap basePath) Either.nothing state.Cues - do! Map.fold (Asset.saveMap basePath) Either.nothing state.CueLists - do! Map.fold (Asset.saveMap basePath) Either.nothing state.Users - do! Map.fold (Asset.saveMap basePath) Either.nothing state.CuePlayers + result { + do! Map.fold (Asset.saveMap basePath) Result.nothing state.PinMappings + do! Map.fold (Asset.saveMap basePath) Result.nothing state.PinWidgets + do! Map.fold (Asset.saveMap basePath) Result.nothing state.Cues + do! Map.fold (Asset.saveMap basePath) Result.nothing state.CueLists + do! Map.fold (Asset.saveMap basePath) Result.nothing state.Users + do! Map.fold (Asset.saveMap basePath) Result.nothing state.CuePlayers do! Asset.save basePath state.PinGroups do! Asset.save basePath state.Project } @@ -390,8 +390,8 @@ type State = // ** FromFB - static member FromFB(fb: StateFB) : Either = - either { + static member FromFB(fb: StateFB) : DiscoResult< State> = + result { // PROJECT let! project = @@ -405,7 +405,7 @@ type State = else "Could not parse empty ProjectFB" |> Error.asParseError "State.FromFB" - |> Either.fail + |> Result.fail #endif // GROUPS @@ -421,7 +421,7 @@ type State = else "Could not parse empty group map payload" |> Error.asParseError "State.FromFB" - |> Either.fail + |> Result.fail #endif // MAPPINGS @@ -429,7 +429,7 @@ type State = let! mappings = let arr = Array.zeroCreate fb.PinMappingsLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, map) = m #if FABLE_COMPILER @@ -443,21 +443,21 @@ type State = else "Could not parse empty PinMapping payload" |> Error.asParseError "State.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add group.Id group map) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd // WIDGETS let! widgets = let arr = Array.zeroCreate fb.PinWidgetsLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, map) = m #if FABLE_COMPILER @@ -471,21 +471,21 @@ type State = else "Could not parse empty PinWidget payload" |> Error.asParseError "State.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add group.Id group map) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd // CUES let! cues = let arr = Array.zeroCreate fb.CuesLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, map) = m #if FABLE_COMPILER @@ -499,21 +499,21 @@ type State = else "Could not parse empty Cue payload" |> Error.asParseError "State.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add cue.Id cue map) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd // CUES let! fsTrees = let arr = Array.zeroCreate fb.FsTreesLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, map) = m #if FABLE_COMPILER @@ -527,21 +527,21 @@ type State = else "Could not parse empty FsTree payload" |> Error.asParseError "State.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add fsTree.HostId fsTree map) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd // CUELISTS let! cuelists = let arr = Array.zeroCreate fb.CueListsLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, map) = m #if FABLE_COMPILER @@ -555,21 +555,21 @@ type State = else "Could not parse empty CueList payload" |> Error.asParseError "State.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add cuelist.Id cuelist map) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd // USERS let! users = let arr = Array.zeroCreate fb.UsersLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, map) = m #if FABLE_COMPILER @@ -583,21 +583,21 @@ type State = else "Could not parse empty User payload" |> Error.asParseError "State.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add user.Id user map) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd // SESSIONS let! sessions = let arr = Array.zeroCreate fb.SessionsLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, map) = m #if FABLE_COMPILER @@ -611,21 +611,21 @@ type State = else "Could not parse empty Session payload" |> Error.asParseError "State.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add session.Id session map) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd // CLIENTS let! clients = let arr = Array.zeroCreate fb.ClientsLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, map) = m #if FABLE_COMPILER @@ -639,21 +639,21 @@ type State = else "Could not parse empty Client payload" |> Error.asParseError "Client.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add client.Id client map) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd // PLAYERS let! players = let arr = Array.zeroCreate fb.CuePlayersLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, map) = m #if FABLE_COMPILER @@ -667,21 +667,21 @@ type State = else "Could not parse empty CuePlayer payload" |> Error.asParseError "CuePlayer.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add player.Id player map) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd // DISCOVERED SERVICES let! discoveredServices = let arr = Array.zeroCreate fb.DiscoveredServicesLength Array.fold - (fun (m: Either>) _ -> either { + (fun (m: DiscoResult>) _ -> result { let! (i, map) = m #if FABLE_COMPILER @@ -695,14 +695,14 @@ type State = else "Could not parse empty DiscoveredService payload" |> Error.asParseError "DiscoveredService.FromFB" - |> Either.fail + |> Result.fail #endif return (i + 1, Map.add service.Id service map) }) - (Right (0, Map.empty)) + (Ok (0, Map.empty)) arr - |> Either.map snd + |> Result.map snd return { Project = project @@ -722,7 +722,7 @@ type State = // ** FromBytes - static member FromBytes (bytes: byte[]) : Either = + static member FromBytes (bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> StateFB.GetRootAsStateFB |> State.FromFB @@ -1106,18 +1106,18 @@ module State = // ** addMember - let addMember (mem: RaftMember) (state: State) = + let addMember (mem: ClusterMember) (state: State) = { state with Project = Project.addMember mem state.Project } // ** updateMember - let updateMember (mem: RaftMember) (state: State) = + let updateMember (mem: ClusterMember) (state: State) = { state with Project = Project.updateMember mem state.Project } // ** removeMember - let removeMember (mem: RaftMember) (state: State) = - { state with Project = Project.removeMember mem.Id state.Project } + let removeMember (mem: MemberId) (state: State) = + { state with Project = Project.removeMember mem state.Project } // ____ _ _ _ // / ___| (_) ___ _ __ | |_ @@ -1125,6 +1125,18 @@ module State = // | |___| | | __/ | | | |_ // \____|_|_|\___|_| |_|\__| + // ** updateRaftMember + + let updateRaftMember (mem: RaftMember) (state: State) = + match Project.findMember mem.Id state.Project with + | Ok clusterMember -> + let mem = + clusterMember + |> ClusterMember.setState mem.State + |> ClusterMember.setStatus mem.Status + { state with Project = Project.updateMember mem state.Project } + | _ -> state + // ** addClient let addClient (client: DiscoClient) (state: State) = @@ -1199,7 +1211,7 @@ module State = // ** updateConfig let updateConfig (config: DiscoConfig) (state: State) = - { state with Project = Project.updateConfig config state.Project } + { state with Project = Project.setConfig config state.Project } // ** updateProject @@ -1212,6 +1224,11 @@ module State = let onSave (state: State) = { state with PinGroups = PinGroupMap.mapPins (Pin.setDirty false) state.PinGroups } + // ** processBatch + + let processBatch (state: State) (Transaction batch) = + List.fold update state batch + // ** update let update (state: State) = function @@ -1246,7 +1263,10 @@ module State = | AddMember mem -> addMember mem state | UpdateMember mem -> updateMember mem state - | RemoveMember mem -> removeMember mem state + | RemoveMember mem -> removeMember mem.Id state + + | UpdateMachine mem -> updateRaftMember mem state + | RemoveMachine mem -> removeMember mem.Id state | AddClient client -> addClient client state | UpdateClient client -> updateClient client state @@ -1275,14 +1295,20 @@ module State = | UpdateDiscoveredService service -> addOrUpdateService service state | RemoveDiscoveredService service -> removeService service state - | Command AppCommand.Save -> onSave state - - | _ -> state + | Command AppCommand.Save -> onSave state - // ** processBatch + | DataSnapshot snapshot -> snapshot + | CommandBatch batch -> processBatch state batch - let processBatch (state: State) (batch: Transaction) = - List.fold update state batch.Commands + | UnloadProject /// handled one level up in Store.Dispatch + | UpdateClock _ /// not handled in-state for now + | SetLogLevel _ /// TODO: should eventually be saved in MachineConfig + | LogMsg _ /// logs bear no relevance to the state + | CallCue _ /// the service resolves the cue + | AddMachine _ /// not handled since we don't know how to convert to ClusterMember + | Command AppCommand.Undo /// application commands handled one level up + | Command AppCommand.Redo + | Command AppCommand.Reset -> state // ** initialize @@ -1410,19 +1436,13 @@ type History (action: StoreAction) = // |____/ \__\___/|_| \___| // -/// ## Store -/// /// The `Store` centrally manages all state changes and notifies interested parties of changes to /// the carried state (e.g. views, socket transport). Clients of the `Store` can subscribe to change /// notifications by regis a callback handler. `Store` is used in all parts of the Disco cluster /// application, from the front-end, at the service level, to all registered clients. `StateMachine` /// commands replicated via `Raft` are applied in the same order to it to ensure that all parties /// have the same data. -/// -/// ### Signature: -/// - state: `State` - the intitial state to use for the store -/// -/// Returns: Store + type Store(state : State)= let mutable state = state @@ -1473,34 +1493,27 @@ type Store(state : State)= // ** Dispatch - /// ## Dispatch - /// /// Disgroup an action (StateMachine command) to be executed against the current version of the /// `State` to produce the next `State`. /// /// Then notify all listeners of the change, and record a history item for this change. /// - /// ### Signature: /// - ev: `StateMachine` - command to apply to the `State` - /// - /// Returns: unit - member self.Dispatch (ev : StateMachine) : unit = - let andRender (newstate: State) = - state <- newstate // 1) create new state - self.Notify(ev) // 2) notify all - history.Append({ Event = ev // 3) store this action and new state - State = state }) // 4) append to undo history + + member self.Dispatch ev = + let updateState (newstate: State) = + state <- newstate // 1) create new state + self.Notify(ev) // 2) notify all + history.Append + { Event = ev // 3) store this action and new state + State = state } // 4) append to undo history match ev with | Command (AppCommand.Redo) -> self.Redo() | Command (AppCommand.Undo) -> self.Undo() | Command (AppCommand.Reset) -> () // do nothing for now - | UnloadProject -> self.Notify(ev) // This event doesn't actually modify the state - - | CommandBatch batch -> State.processBatch state batch |> andRender - - | other -> State.update state other |> andRender + | other -> State.update state other |> updateState // ** Subscribe @@ -1608,23 +1621,23 @@ type Transaction = Transaction of StateMachine list // ** FromFB static member FromFB(batch: TransactionFB) = - either { + result { let input = Array.zeroCreate batch.CommandsLength let! (_,commands) = #if FABLE_COMPILER Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult< int * StateMachine array>) _ -> result { let! (idx, arr) = m let! cmd = batch.Commands(idx) |> StateMachine.FromFB do arr.[idx] <- cmd return (idx + 1, arr) }) - (Right (0, input)) + (Ok (0, input)) input #else Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult< int * StateMachine array>) _ -> result { let! (idx, arr) = m let cmdish = batch.Commands(idx) if cmdish.HasValue then @@ -1636,9 +1649,9 @@ type Transaction = Transaction of StateMachine list return! "Could not parse empty CommandBatch *value* payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail }) - (Right (0, input)) + (Ok (0, input)) input #endif return Transaction (List.ofArray commands) @@ -1677,7 +1690,7 @@ type SlicesMap = SlicesMap of Map static member FromFB(fb: SlicesMapFB) = [ 0 .. fb.SlicesLength - 1 ] |> List.fold - (fun (m: Either>) (idx: int) -> either { + (fun (m: DiscoResult>) (idx: int) -> result { let! output = m #if FABLE_COMPILER let! parsed = fb.Slices(idx) |> Slices.FromFB @@ -1692,11 +1705,11 @@ type SlicesMap = SlicesMap of Map return! "Could not parse empty SlicesFB value" |> Error.asParseError "SlicesMap" - |> Either.fail + |> Result.fail #endif }) - (Right Map.empty) - |> Either.map SlicesMap + (Ok Map.empty) + |> Result.map SlicesMap // * SlicesMap module @@ -1790,9 +1803,14 @@ type StateMachine = | UnloadProject // Member - | AddMember of RaftMember - | UpdateMember of RaftMember - | RemoveMember of RaftMember + | AddMember of ClusterMember + | UpdateMember of ClusterMember + | RemoveMember of ClusterMember + + // Machine + | AddMachine of RaftMember + | UpdateMachine of RaftMember + | RemoveMachine of RaftMember // Client | AddClient of DiscoClient @@ -1885,6 +1903,11 @@ type StateMachine = | UpdateMember _ -> "UpdateMember" | RemoveMember _ -> "RemoveMember" + // Machine + | AddMachine _ -> "AddMachine" + | UpdateMachine _ -> "UpdateMachine" + | RemoveMachine _ -> "RemoveMachine" + // Client | AddClient _ -> "AddClient" | UpdateClient _ -> "UpdateClient" @@ -1973,6 +1996,11 @@ type StateMachine = | AddMember _ | RemoveMember _ -> Commit + // Machine + | AddMachine _ + | UpdateMachine _ + | RemoveMachine _ -> Save + // Client | AddClient _ | UpdateClient _ @@ -2064,6 +2092,10 @@ type StateMachine = | UpdateMember _ | RemoveMember _ -> ParameterFB.RaftMemberFB + | AddMachine _ + | UpdateMachine _ + | RemoveMachine _ -> ParameterFB.ClusterMemberFB + | AddClient _ | UpdateClient _ | RemoveClient _ -> ParameterFB.DiscoClientFB @@ -2150,6 +2182,7 @@ type StateMachine = | AddClient _ | AddFsEntry _ | AddFsTree _ + | AddMachine _ | AddMember _ -> ApiCommandFB.AddFB | UpdateClock _ @@ -2166,6 +2199,7 @@ type StateMachine = | UpdatePinWidget _ | UpdateClient _ | UpdateMember _ + | UpdateMachine _ | UpdateFsEntry _ | UpdateProject _ -> ApiCommandFB.UpdateFB @@ -2182,6 +2216,7 @@ type StateMachine = | RemoveClient _ | RemoveFsEntry _ | RemoveFsTree _ + | RemoveMachine _ | RemoveMember _ -> ApiCommandFB.RemoveFB | CallCue _ -> ApiCommandFB.CallCueFB @@ -2224,13 +2259,13 @@ type StateMachine = match fb.Action with | x when x = StateMachineActionFB.UpdateFB -> let project = fb.ProjectFB |> DiscoProject.FromFB - Either.map UpdateProject project + Result.map UpdateProject project | x when x = StateMachineActionFB.RemoveFB -> - Right UnloadProject + Ok UnloadProject | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // __ __ _ // | \/ | ___ _ __ ___ | |__ ___ _ __ @@ -2241,15 +2276,34 @@ type StateMachine = let mem = fb.RaftMemberFB |> RaftMember.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddMember mem + Result.map AddMachine mem + | x when x = StateMachineActionFB.UpdateFB -> + Result.map UpdateMachine mem + | x when x = StateMachineActionFB.RemoveFB -> + Result.map RemoveMachine mem + | x -> + sprintf "Could not parse unknown StateMachineActionFB %A" x + |> Error.asParseError "StateMachine.FromFB" + |> Result.fail + + // __ __ _ + // | \/ | ___ _ __ ___ | |__ ___ _ __ + // | |\/| |/ _ \ '_ ` _ \| '_ \ / _ \ '__| + // | | | | __/ | | | | | |_) | __/ | + // |_| |_|\___|_| |_| |_|_.__/ \___|_| + | x when x = StateMachinePayloadFB.ClusterMemberFB -> + let mem = fb.ClusterMemberFB |> ClusterMember.FromFB + match fb.Action with + | x when x = StateMachineActionFB.AddFB -> + Result.map AddMember mem | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdateMember mem + Result.map UpdateMember mem | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemoveMember mem + Result.map RemoveMember mem | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ _ _ _ // / ___| (_) ___ _ __ | |_ @@ -2260,15 +2314,15 @@ type StateMachine = let client = fb.DiscoClientFB |> DiscoClient.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddClient client + Result.map AddClient client | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdateClient client + Result.map UpdateClient client | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemoveClient client + Result.map RemoveClient client | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ // / ___|_ __ ___ _ _ _ __ @@ -2280,15 +2334,15 @@ type StateMachine = let group = fb.PinGroupFB |> PinGroup.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddPinGroup group + Result.map AddPinGroup group | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdatePinGroup group + Result.map UpdatePinGroup group | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemovePinGroup group + Result.map RemovePinGroup group | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // __ __ _ // | \/ | __ _ _ __ _ __ (_)_ __ __ _ @@ -2300,15 +2354,15 @@ type StateMachine = let mapping = fb.PinMappingFB |> PinMapping.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddPinMapping mapping + Result.map AddPinMapping mapping | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdatePinMapping mapping + Result.map UpdatePinMapping mapping | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemovePinMapping mapping + Result.map RemovePinMapping mapping | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // __ ___ _ _ // \ \ / (_) __| | __ _ ___| |_ @@ -2320,15 +2374,15 @@ type StateMachine = let widget = fb.PinWidgetFB |> PinWidget.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddPinWidget widget + Result.map AddPinWidget widget | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdatePinWidget widget + Result.map UpdatePinWidget widget | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemovePinWidget widget + Result.map RemovePinWidget widget | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ _ // | _ \(_)_ __ @@ -2339,15 +2393,15 @@ type StateMachine = let pin = fb.PinFB |> Pin.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddPin pin + Result.map AddPin pin | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdatePin pin + Result.map UpdatePin pin | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemovePin pin + Result.map RemovePin pin | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ _ _ // / ___|| (_) ___ ___ ___ @@ -2358,11 +2412,11 @@ type StateMachine = let slices = fb.SlicesMapFB |> SlicesMap.FromFB match fb.Action with | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdateSlices slices + Result.map UpdateSlices slices | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ // / ___| _ ___ @@ -2373,15 +2427,15 @@ type StateMachine = let cue = fb.CueFB |> Cue.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddCue cue + Result.map AddCue cue | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdateCue cue + Result.map UpdateCue cue | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemoveCue cue + Result.map RemoveCue cue | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ _ _ _ // / ___| _ ___| | (_)___| |_ @@ -2392,15 +2446,15 @@ type StateMachine = let cuelist = fb.CueListFB |> CueList.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddCueList cuelist + Result.map AddCueList cuelist | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdateCueList cuelist + Result.map UpdateCueList cuelist | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemoveCueList cuelist + Result.map RemoveCueList cuelist | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ ____ _ // / ___| _ ___| _ \| | __ _ _ _ ___ _ __ @@ -2412,15 +2466,15 @@ type StateMachine = let cuelist = fb.CuePlayerFB |> CuePlayer.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddCuePlayer cuelist + Result.map AddCuePlayer cuelist | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdateCuePlayer cuelist + Result.map UpdateCuePlayer cuelist | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemoveCuePlayer cuelist + Result.map RemoveCuePlayer cuelist | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // _ _ // | | | |___ ___ _ __ @@ -2431,15 +2485,15 @@ type StateMachine = let user = fb.UserFB |> User.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddUser user + Result.map AddUser user | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdateUser user + Result.map UpdateUser user | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemoveUser user + Result.map RemoveUser user | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ _ // / ___| ___ ___ ___(_) ___ _ __ @@ -2450,15 +2504,15 @@ type StateMachine = let session = fb.SessionFB |> Session.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddSession session + Result.map AddSession session | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdateSession session + Result.map UpdateSession session | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemoveSession session + Result.map RemoveSession session | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail /// _____ _____ _ /// | ___|__| ____|_ __ | |_ _ __ _ _ @@ -2470,19 +2524,19 @@ type StateMachine = let fsEntryUpdate = fb.FsEntryUpdateFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - either { + result { let! id = Id.decodeHostId fsEntryUpdate let! entry = FsEntry.FromFB fsEntryUpdate.Entry return AddFsEntry (id,entry) } | x when x = StateMachineActionFB.UpdateFB -> - either { + result { let! id = Id.decodeHostId fsEntryUpdate let! entry = FsEntry.FromFB fsEntryUpdate.Entry return UpdateFsEntry (id,entry) } | x when x = StateMachineActionFB.RemoveFB -> - either { + result { let! id = Id.decodeHostId fsEntryUpdate let! path = FsPath.FromFB fsEntryUpdate.Path return RemoveFsEntry (id,path) @@ -2490,7 +2544,7 @@ type StateMachine = | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail /// _____ _____ /// | ___|_|_ _| __ ___ ___ @@ -2501,19 +2555,19 @@ type StateMachine = let fsTreeUpdate = fb.FsTreeUpdateFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - either { + result { let! tree = FsTree.FromFB fsTreeUpdate.Tree return AddFsTree tree } | x when x = StateMachineActionFB.RemoveFB -> - either { + result { let! hostId = Id.decodeHostId fsTreeUpdate return RemoveFsTree hostId } | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ _ _ // | _ \(_)___ ___ _____ _____ _ __ ___ __| | @@ -2524,15 +2578,15 @@ type StateMachine = let discoveredService = fb.DiscoveredServiceFB |> DiscoveredService.FromFB match fb.Action with | x when x = StateMachineActionFB.AddFB -> - Either.map AddDiscoveredService discoveredService + Result.map AddDiscoveredService discoveredService | x when x = StateMachineActionFB.UpdateFB -> - Either.map UpdateDiscoveredService discoveredService + Result.map UpdateDiscoveredService discoveredService | x when x = StateMachineActionFB.RemoveFB -> - Either.map RemoveDiscoveredService discoveredService + Result.map RemoveDiscoveredService discoveredService | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ _ _ // / ___| _ __ __ _ _ __ ___| |__ ___ | |_ @@ -2543,7 +2597,7 @@ type StateMachine = | x when x = StateMachinePayloadFB.StateFB && fb.Action = StateMachineActionFB.DataSnapshotFB -> fb.StateFB |> State.FromFB - |> Either.map DataSnapshot + |> Result.map DataSnapshot // _ _____ _ // | | ___ __ _| ____|_ _____ _ __ | |_ @@ -2554,7 +2608,7 @@ type StateMachine = | x when x = StateMachinePayloadFB.LogEventFB -> fb.LogEventFB |> LogEvent.FromFB - |> Either.map LogMsg + |> Result.map LogMsg // ____ _ _ // / ___|| |_ _ __(_)_ __ __ _ @@ -2567,11 +2621,11 @@ type StateMachine = | x when x = StateMachineActionFB.SetLogLevelFB -> fb.StringFB.Value |> LogLevel.TryParse - |> Either.map SetLogLevel + |> Result.map SetLogLevel | x -> sprintf "Could not parse unknown StateMachineActionFB %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail // ____ _ _ // / ___| | ___ ___| | __ @@ -2580,7 +2634,7 @@ type StateMachine = // \____|_|\___/ \___|_|\_\ | x when x = StateMachinePayloadFB.ClockFB -> UpdateClock(fb.ClockFB.Value) - |> Either.succeed + |> Result.succeed // ____ _ _ // | __ ) __ _| |_ ___| |__ @@ -2588,7 +2642,7 @@ type StateMachine = // | |_) | (_| | || (__| | | | // |____/ \__,_|\__\___|_| |_| | x when x = StateMachinePayloadFB.TransactionFB -> - either { + result { let fb = fb.TransactionFB let! batch = Transaction.FromFB fb return CommandBatch batch @@ -2602,7 +2656,7 @@ type StateMachine = | _ -> fb.Action |> AppCommand.FromFB - |> Either.map Command + |> Result.map Command #else @@ -2618,7 +2672,7 @@ type StateMachine = // |_| |_| \___// |\___|\___|\__| // |__/ | StateMachinePayloadFB.ProjectFB -> - either { + result { match fb.Action with | StateMachineActionFB.UpdateFB -> let projectish = fb.Payload() @@ -2626,17 +2680,17 @@ type StateMachine = if projectish.HasValue then projectish.Value |> DiscoProject.FromFB - |> Either.map UpdateProject + |> Result.map UpdateProject else "Could not parse empty project payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail | StateMachineActionFB.RemoveFB -> return UnloadProject | x -> return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ @@ -2645,7 +2699,7 @@ type StateMachine = // | |__| |_| | __/ // \____\__,_|\___| | StateMachinePayloadFB.CueFB -> - either { + result { let! cue = let cueish = fb.Payload() if cueish.HasValue then @@ -2654,7 +2708,7 @@ type StateMachine = else "Could not parse empty cue payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddCue cue) | StateMachineActionFB.UpdateFB -> return (UpdateCue cue) @@ -2664,7 +2718,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ _ _ @@ -2673,7 +2727,7 @@ type StateMachine = // | |___| | | __/ | | | |_ // \____|_|_|\___|_| |_|\__| | StateMachinePayloadFB.DiscoClientFB -> - either { + result { let! client = let clientish = fb.Payload() if clientish.HasValue then @@ -2682,7 +2736,7 @@ type StateMachine = else "Could not parse empty client payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddClient client) | StateMachineActionFB.UpdateFB -> return (UpdateClient client) @@ -2691,7 +2745,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ _ _ @@ -2700,7 +2754,7 @@ type StateMachine = // | |__| |_| | __/ |___| \__ \ |_ // \____\__,_|\___|_____|_|___/\__| | StateMachinePayloadFB.CueListFB -> - either { + result { let! cuelist = let cuelistish = fb.Payload() if cuelistish.HasValue then @@ -2709,7 +2763,7 @@ type StateMachine = else "Could not parse empty cuelist payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddCueList cuelist) | StateMachineActionFB.UpdateFB -> return (UpdateCueList cuelist) @@ -2718,7 +2772,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ ____ _ @@ -2728,7 +2782,7 @@ type StateMachine = // \____\__,_|\___|_| |_|\__,_|\__, |\___|_| // |___/ | StateMachinePayloadFB.CuePlayerFB -> - either { + result { let! player = let playerish = fb.Payload() if playerish.HasValue then @@ -2737,7 +2791,7 @@ type StateMachine = else "Could not parse empty player payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddCuePlayer player) | StateMachineActionFB.UpdateFB -> return (UpdateCuePlayer player) @@ -2746,7 +2800,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ @@ -2756,7 +2810,7 @@ type StateMachine = // \____|_| \___/ \__,_| .__/ // |_| | StateMachinePayloadFB.PinGroupFB -> - either { + result { let! group = let groupish = fb.Payload() if groupish.HasValue then @@ -2765,7 +2819,7 @@ type StateMachine = else "Could not parse empty groupe payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddPinGroup group) | StateMachineActionFB.UpdateFB -> return (UpdatePinGroup group) @@ -2774,7 +2828,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // __ __ _ @@ -2784,7 +2838,7 @@ type StateMachine = // |_| |_|\__,_| .__/| .__/|_|_| |_|\__, | // |_| |_| |___/ | StateMachinePayloadFB.PinMappingFB -> - either { + result { let! mapping = let mappingish = fb.Payload() if mappingish.HasValue then @@ -2793,7 +2847,7 @@ type StateMachine = else "Could not parse empty mapping payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddPinMapping mapping) | StateMachineActionFB.UpdateFB -> return (UpdatePinMapping mapping) @@ -2802,7 +2856,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // __ ___ _ _ @@ -2812,7 +2866,7 @@ type StateMachine = // \_/\_/ |_|\__,_|\__, |\___|\__| // |___/ | StateMachinePayloadFB.PinWidgetFB -> - either { + result { let! widget = let widgetish = fb.Payload() if widgetish.HasValue then @@ -2821,7 +2875,7 @@ type StateMachine = else "Could not parse empty widget payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddPinWidget widget) | StateMachineActionFB.UpdateFB -> return (UpdatePinWidget widget) @@ -2830,7 +2884,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ @@ -2839,7 +2893,7 @@ type StateMachine = // | __/| | | | | // |_| |_|_| |_| | StateMachinePayloadFB.PinFB -> - either { + result { let! pin = let pinish = fb.Payload() if pinish.HasValue then @@ -2848,7 +2902,7 @@ type StateMachine = else "Could not parse empty pin payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddPin pin) | StateMachineActionFB.UpdateFB -> return (UpdatePin pin) @@ -2857,7 +2911,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ _ @@ -2866,7 +2920,7 @@ type StateMachine = // ___) | | | (_| __/\__ \ // |____/|_|_|\___\___||___/ | StateMachinePayloadFB.SlicesMapFB -> - either { + result { let! slices = let slicesMapish = fb.Payload() if slicesMapish.HasValue then @@ -2875,23 +2929,23 @@ type StateMachine = else "Could not parse empty slices payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.UpdateFB -> return (UpdateSlices slices) | x -> return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } - // _ _ _ - // | \ | | ___ __| | ___ - // | \| |/ _ \ / _` |/ _ \ - // | |\ | (_) | (_| | __/ - // |_| \_|\___/ \__,_|\___| + /// __ __ _ + /// | \/ | ___ _ __ ___ | |__ ___ _ __ + /// | |\/| |/ _ \ '_ ` _ \| '_ \ / _ \ '__| + /// | | | | __/ | | | | | |_) | __/ | + /// |_| |_|\___|_| |_| |_|_.__/ \___|_| | StateMachinePayloadFB.RaftMemberFB -> - either { + result { let! mem = let memish = fb.Payload() if memish.HasValue then @@ -2900,16 +2954,43 @@ type StateMachine = else "Could not parse empty mem payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail + match fb.Action with + | StateMachineActionFB.AddFB -> return (AddMachine mem) + | StateMachineActionFB.UpdateFB -> return (UpdateMachine mem) + | StateMachineActionFB.RemoveFB -> return (RemoveMachine mem) + | x -> + return! + sprintf "Could not parse command. Unknown ActionTypeFB: %A" x + |> Error.asParseError "StateMachine.FromFB" + |> Result.fail + } + + /// __ __ _ + /// | \/ | ___ _ __ ___ | |__ ___ _ __ + /// | |\/| |/ _ \ '_ ` _ \| '_ \ / _ \ '__| + /// | | | | __/ | | | | | |_) | __/ | + /// |_| |_|\___|_| |_| |_|_.__/ \___|_| + | StateMachinePayloadFB.ClusterMemberFB -> + result { + let! mem = + let memish = fb.Payload() + if memish.HasValue then + memish.Value + |> ClusterMember.FromFB + else + "Could not parse empty mem payload" + |> Error.asParseError "StateMachine.FromFB" + |> Result.fail match fb.Action with - | StateMachineActionFB.AddFB -> return (AddMember mem) + | StateMachineActionFB.AddFB -> return (AddMember mem) | StateMachineActionFB.UpdateFB -> return (UpdateMember mem) | StateMachineActionFB.RemoveFB -> return (RemoveMember mem) | x -> return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } /// _____ _____ _ @@ -2919,15 +3000,15 @@ type StateMachine = /// |_| |___/_____|_| |_|\__|_| \__, | /// |___/ | StateMachinePayloadFB.FsEntryUpdateFB -> - either { + result { let! fsEntryUpdate = let fsEntryish = fb.Payload() if fsEntryish.HasValue then - Either.succeed fsEntryish.Value + Result.succeed fsEntryish.Value else "Could not parse empty FsEntryUpdateFB payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail let! hostId = Id.decodeHostId fsEntryUpdate match fb.Action with | StateMachineActionFB.AddFB -> @@ -2939,7 +3020,7 @@ type StateMachine = else "Could not parse empty FsEntryFB payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail return AddFsEntry (hostId, entry) | StateMachineActionFB.UpdateFB -> let! entry = @@ -2950,7 +3031,7 @@ type StateMachine = else "Could not parse empty FsEntryFB payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail return UpdateFsEntry(hostId, entry) | StateMachineActionFB.RemoveFB -> let! path = @@ -2961,13 +3042,13 @@ type StateMachine = else "Could not parse empty FsPathFB payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail return RemoveFsEntry (hostId, path) | x -> return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } /// _____ _____ @@ -2976,15 +3057,15 @@ type StateMachine = /// | _|\__ \| || | | __/ __/ /// |_| |___/|_||_| \___|\___| | StateMachinePayloadFB.FsTreeUpdateFB -> - either { + result { let! fsTreeUpdate = let updateish = fb.Payload() if updateish.HasValue then - Either.succeed updateish.Value + Result.succeed updateish.Value else "Could not parse empty FsTreeUpdateFB payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> let! tree = @@ -2995,7 +3076,7 @@ type StateMachine = else "Could not parse empty FsTreeFB payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail return AddFsTree tree | StateMachineActionFB.RemoveFB -> let! fsTreeId = Id.decodeHostId fsTreeUpdate @@ -3004,7 +3085,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // _ _ @@ -3013,7 +3094,7 @@ type StateMachine = // | |_| \__ \ __/ | // \___/|___/\___|_| | StateMachinePayloadFB.UserFB -> - either { + result { let! user = let userish = fb.Payload() if userish.HasValue then @@ -3022,7 +3103,7 @@ type StateMachine = else "Could not parse empty user payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddUser user) | StateMachineActionFB.UpdateFB -> return (UpdateUser user) @@ -3031,7 +3112,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ @@ -3040,7 +3121,7 @@ type StateMachine = // ___) | __/\__ \__ \ | (_) | | | | // |____/ \___||___/___/_|\___/|_| |_| | StateMachinePayloadFB.SessionFB -> - either { + result { let! session = let sessionish = fb.Payload() if sessionish.HasValue then @@ -3049,7 +3130,7 @@ type StateMachine = else "Could not parse empty session payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddSession session) | StateMachineActionFB.UpdateFB -> return (UpdateSession session) @@ -3058,7 +3139,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ _ @@ -3067,7 +3148,7 @@ type StateMachine = // | |_| | \__ \ (_| (_) \ V / __/ | | __/ (_| | // |____/|_|___/\___\___/ \_/ \___|_| \___|\__,_| | StateMachinePayloadFB.DiscoveredServiceFB -> - either { + result { let! discoveredService = let discoveredServiceish = fb.Payload() if discoveredServiceish.HasValue then @@ -3076,7 +3157,7 @@ type StateMachine = else "Could not parse empty discoveredService payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail match fb.Action with | StateMachineActionFB.AddFB -> return (AddDiscoveredService discoveredService) | StateMachineActionFB.UpdateFB -> return (UpdateDiscoveredService discoveredService) @@ -3085,7 +3166,7 @@ type StateMachine = return! sprintf "Could not parse command. Unknown ActionTypeFB: %A" x |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // __ __ _ @@ -3094,7 +3175,7 @@ type StateMachine = // | | | | \__ \ (__ // |_| |_|_|___/\___| | StateMachinePayloadFB.LogEventFB -> - either { + result { let logish = fb.Payload() if logish.HasValue then let! log = LogEvent.FromFB logish.Value @@ -3103,7 +3184,7 @@ type StateMachine = return! "Could not parse empty LogEvent payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ _ @@ -3113,7 +3194,7 @@ type StateMachine = // |____/|_| |_|\__,_| .__/|___/_| |_|\___/ \__| // |_| | StateMachinePayloadFB.StateFB -> - either { + result { let stateish = fb.Payload() if stateish.HasValue then let state = stateish.Value @@ -3123,7 +3204,7 @@ type StateMachine = return! "Could not parse empty state payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ _ @@ -3133,7 +3214,7 @@ type StateMachine = // |____/ \__|_| |_|_| |_|\__, | // |___/ | StateMachinePayloadFB.StringFB -> - either { + result { let stringish = fb.Payload () if stringish.HasValue then let value = stringish.Value @@ -3143,7 +3224,7 @@ type StateMachine = return! "Could not parse empty string payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ _ @@ -3152,7 +3233,7 @@ type StateMachine = // | |___| | (_) | (__| < // \____|_|\___/ \___|_|\_\ | StateMachinePayloadFB.ClockFB -> - either { + result { let clockish = fb.Payload () if clockish.HasValue then let clock = clockish.Value @@ -3161,7 +3242,7 @@ type StateMachine = return! "Could not parse empty clock payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ ____ _ _ @@ -3170,7 +3251,7 @@ type StateMachine = // | |__| (_) | | | | | | | | | | | (_| | | | | (_| | |_) | (_| | || (__| | | | // \____\___/|_| |_| |_|_| |_| |_|\__,_|_| |_|\__,_|____/ \__,_|\__\___|_| |_| | StateMachinePayloadFB.TransactionFB -> - either { + result { let batchish = fb.Payload () if batchish.HasValue then let batch = batchish.Value @@ -3180,7 +3261,7 @@ type StateMachine = return! "Could not parse empty CommandBatch payload" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail } // ____ _ @@ -3188,7 +3269,7 @@ type StateMachine = // | | / _ \| '_ ` _ \| '_ ` _ \ / _` | '_ \ / _` | // | |__| (_) | | | | | | | | | | | (_| | | | | (_| | // \____\___/|_| |_| |_|_| |_| |_|\__,_|_| |_|\__,_| - | _ -> either { + | _ -> result { let! cmd = AppCommand.FromFB fb.Action return (Command cmd) } @@ -3242,7 +3323,48 @@ type StateMachine = // | |\/| |/ _ \ '_ ` _ \| '_ \ / _ \ '__| // | | | | __/ | | | | | |_) | __/ | // |_| |_|\___|_| |_| |_|_.__/ \___|_| - | AddMember mem -> + | AddMember mem -> + let mem = mem.ToOffset(builder) + StateMachineFB.StartStateMachineFB(builder) + StateMachineFB.AddAction(builder, StateMachineActionFB.AddFB) + StateMachineFB.AddPayloadType(builder, StateMachinePayloadFB.ClusterMemberFB) +#if FABLE_COMPILER + StateMachineFB.AddPayload(builder, mem) +#else + StateMachineFB.AddPayload(builder, mem.Value) +#endif + StateMachineFB.EndStateMachineFB(builder) + + | UpdateMember mem -> + let mem = mem.ToOffset(builder) + StateMachineFB.StartStateMachineFB(builder) + StateMachineFB.AddAction(builder, StateMachineActionFB.UpdateFB) + StateMachineFB.AddPayloadType(builder, StateMachinePayloadFB.ClusterMemberFB) +#if FABLE_COMPILER + StateMachineFB.AddPayload(builder, mem) +#else + StateMachineFB.AddPayload(builder, mem.Value) +#endif + StateMachineFB.EndStateMachineFB(builder) + + | RemoveMember mem -> + let mem = mem.ToOffset(builder) + StateMachineFB.StartStateMachineFB(builder) + StateMachineFB.AddAction(builder, StateMachineActionFB.RemoveFB) + StateMachineFB.AddPayloadType(builder, StateMachinePayloadFB.ClusterMemberFB) +#if FABLE_COMPILER + StateMachineFB.AddPayload(builder, mem) +#else + StateMachineFB.AddPayload(builder, mem.Value) +#endif + StateMachineFB.EndStateMachineFB(builder) + + // __ __ _ + // | \/ | ___ _ __ ___ | |__ ___ _ __ + // | |\/| |/ _ \ '_ ` _ \| '_ \ / _ \ '__| + // | | | | __/ | | | | | |_) | __/ | + // |_| |_|\___|_| |_| |_|_.__/ \___|_| + | AddMachine mem -> let mem = mem.ToOffset(builder) StateMachineFB.StartStateMachineFB(builder) StateMachineFB.AddAction(builder, StateMachineActionFB.AddFB) @@ -3254,7 +3376,7 @@ type StateMachine = #endif StateMachineFB.EndStateMachineFB(builder) - | UpdateMember mem -> + | UpdateMachine mem -> let mem = mem.ToOffset(builder) StateMachineFB.StartStateMachineFB(builder) StateMachineFB.AddAction(builder, StateMachineActionFB.UpdateFB) @@ -3266,7 +3388,7 @@ type StateMachine = #endif StateMachineFB.EndStateMachineFB(builder) - | RemoveMember mem -> + | RemoveMachine mem -> let mem = mem.ToOffset(builder) StateMachineFB.StartStateMachineFB(builder) StateMachineFB.AddAction(builder, StateMachineActionFB.RemoveFB) @@ -3939,7 +4061,7 @@ type StateMachine = // ** FromBytes - static member FromBytes (bytes: byte[]) : Either = + static member FromBytes (bytes: byte[]) : DiscoResult = Binary.createBuffer bytes |> StateMachineFB.GetRootAsStateMachineFB |> StateMachine.FromFB diff --git a/src/Disco/Disco/Core/Uri.fs b/src/Disco/Disco/Core/Uri.fs index bc23335d..9c550932 100644 --- a/src/Disco/Disco/Core/Uri.fs +++ b/src/Disco/Disco/Core/Uri.fs @@ -84,7 +84,7 @@ module Uri = /// /// Returns: string - let gitUri (name: Name) (mem: RaftMember) = + let gitUri (name: Name) ip port = let path = #if FABLE_COMPILER name @@ -95,4 +95,4 @@ module Uri = |> unwrap |> System.Web.HttpUtility.UrlEncode #endif - toUri HTTP None (Some path) (string mem.IpAddress) (mem.GitPort |> Some) + toUri HTTP None (Some path) (string ip) (Some port) diff --git a/src/Disco/Disco/Core/User.fs b/src/Disco/Disco/Core/User.fs index fdf789bf..a12cd8a6 100644 --- a/src/Disco/Disco/Core/User.fs +++ b/src/Disco/Disco/Core/User.fs @@ -65,7 +65,7 @@ type UserYaml() = yaml member yaml.ToUser() = - either { + result { let! id = DiscoId.TryParse yaml.Id return { Id = id @@ -247,8 +247,8 @@ type User = // ** FromFB - static member FromFB(fb: UserFB) : Either = - either { + static member FromFB(fb: UserFB) : DiscoResult< User> = + result { let! id = Id.decodeId fb return { Id = id @@ -265,7 +265,7 @@ type User = // ** FromBytes - static member FromBytes (bytes: byte[]) : Either = + static member FromBytes (bytes: byte[]) : DiscoResult< User> = UserFB.GetRootAsUserFB(Binary.createBuffer bytes) |> User.FromFB @@ -297,12 +297,12 @@ type User = #if !FABLE_COMPILER && !DISCO_NODES - static member Load(path: FilePath) : Either = + static member Load(path: FilePath) : DiscoResult< User> = DiscoData.load path // ** LoadAll - static member LoadAll(basePath: FilePath) : Either = + static member LoadAll(basePath: FilePath) : DiscoResult< User array> = basePath filepath USER_DIR |> DiscoData.loadAll diff --git a/src/Disco/Disco/Core/Util.fs b/src/Disco/Disco/Core/Util.fs index 60143927..46b208e5 100644 --- a/src/Disco/Disco/Core/Util.fs +++ b/src/Disco/Disco/Core/Util.fs @@ -367,11 +367,11 @@ module Time = let parse (str: string) = match DateTime.TryParse(str) with - | (true, date) -> Either.succeed date + | (true, date) -> Result.succeed date | _ -> sprintf "Could not parse date string: %s" str |> Error.asParseError "Time.parse" - |> Either.fail + |> Result.fail // * Process @@ -531,6 +531,10 @@ module Functional = let cons (xs: 'a list) (x: 'a) = x::xs + // ** ($) + + let ($) = (<|) /// $ rules! + // * Tuple module Tuple = diff --git a/src/Disco/Disco/MockClient/Main.fs b/src/Disco/Disco/MockClient/Main.fs index d5f345fc..c1c98de8 100644 --- a/src/Disco/Disco/MockClient/Main.fs +++ b/src/Disco/Disco/MockClient/Main.fs @@ -608,10 +608,11 @@ Usage: Tier = Tier.Client UseColors = true Level = LogLevel.Debug + Fields = LogEventFields.Default } let result = - either { + result { let server = { Port = if parsed.Contains <@ Port @> @@ -640,7 +641,7 @@ Usage: } match result with - | Right client -> + | Ok client -> let patch : PinGroup = { Id = patchid Name = name "MockClient Patch" @@ -668,7 +669,7 @@ Usage: loop client loaded patch dispose client exit 0 - | Left error -> + | Error error -> Console.Error.WriteLine("Encountered error starting client: {0}", Error.toMessage error) Console.Error.WriteLine("Aborting.") error diff --git a/src/Disco/Disco/Net/Core.fs b/src/Disco/Disco/Net/Core.fs index 143ce4e9..2864c428 100644 --- a/src/Disco/Disco/Net/Core.fs +++ b/src/Disco/Disco/Net/Core.fs @@ -581,7 +581,7 @@ type TcpServerEvent = type ITcpServer = inherit IDisposable abstract Id: PeerId - abstract Start: unit -> Either + abstract Start: unit -> DiscoResult abstract Subscribe: (TcpServerEvent -> unit) -> IDisposable abstract Request: client:Guid -> Request -> unit abstract Respond: Response -> unit @@ -593,7 +593,7 @@ type PubSubEvent = type IPubSub = inherit IDisposable - abstract Start: unit -> Either + abstract Start: unit -> DiscoResult abstract Send: byte array -> unit abstract Subscribe: (PubSubEvent -> unit) -> IDisposable diff --git a/src/Disco/Disco/Net/PubSub.fs b/src/Disco/Disco/Net/PubSub.fs index b1b875d1..1f416c1a 100644 --- a/src/Disco/Disco/Net/PubSub.fs +++ b/src/Disco/Disco/Net/PubSub.fs @@ -110,19 +110,19 @@ module rec PubSub = let externalAddress = mem - |> Member.ipAddress + |> ClusterMember.ipAddress |> string |> IPAddress.Parse let remoteAddress = mem - |> Member.multicastAddress + |> ClusterMember.multicastAddress |> string |> IPAddress.Parse let remotePort = mem - |> Member.multicastPort + |> ClusterMember.multicastPort |> int let remoteEp = IPEndPoint(remoteAddress, remotePort) @@ -131,8 +131,7 @@ module rec PubSub = let state = { new IState with member state.Id - with get () = Member.id mem - + with get () = ClusterMember.id mem member state.LocalEndPoint with get () = localEp @@ -153,12 +152,12 @@ module rec PubSub = do client.Client.Bind(localEp) do client.JoinMulticastGroup(remoteAddress, externalAddress) do beginReceive state - Either.nothing + Result.nothing with | exn -> exn.Message |> Error.asSocketError (tag "Start") - |> Either.fail + |> Result.fail member pubsub.Send(bytes: byte array) = try diff --git a/src/Disco/Disco/Net/TcpClient.fs b/src/Disco/Disco/Net/TcpClient.fs index 2bd4f38b..5d005a53 100644 --- a/src/Disco/Disco/Net/TcpClient.fs +++ b/src/Disco/Disco/Net/TcpClient.fs @@ -149,16 +149,10 @@ module rec TcpClient = member state.Request (request: Request) = // this socket is asking something, so we need to track this in pending requests - do request.RequestId - |> sprintf "sending to %A (id: %A)" request.PeerId - |> Logger.debug (tag "Request") do pending.TryAdd(request.RequestId, request) |> ignore do request |> RequestBuilder.serialize |> sender.Post member state.Respond (response: Response) = - do response.RequestId - |> sprintf "sending to %A (id: %A)" response.PeerId - |> Logger.debug (tag "Respond") do response |> RequestBuilder.serialize |> sender.Post member state.StartReceiving() = @@ -200,10 +194,6 @@ module rec TcpClient = |> String.format "{0} in socket operation" |> Error.asSocketError (tag "onSend") |> handleError state - else - args.BytesTransferred - |> String.format "sent {0} bytes" - |> Logger.debug (tag "onSend") // ** sendAsync diff --git a/src/Disco/Disco/Net/TcpServer.fs b/src/Disco/Disco/Net/TcpServer.fs index 44aad545..c02b65cc 100644 --- a/src/Disco/Disco/Net/TcpServer.fs +++ b/src/Disco/Disco/Net/TcpServer.fs @@ -68,7 +68,6 @@ module TcpServer = inherit IDisposable abstract Connections: Connections abstract Subscriptions: Subscriptions - abstract BufferManager: IBufferManager abstract BufferedArgs: BufferedArgs abstract Listener: Socket abstract EndPoint: IPEndPoint @@ -79,7 +78,7 @@ module TcpServer = // *** cleanUp - let cleanUp (connections: Connections) = function + let private cleanUp (connections: Connections) = function | TcpServerEvent.Disconnect id -> match connections.TryRemove id with | true, connection -> @@ -104,17 +103,12 @@ module TcpServer = new SocketAsyncEventArgs() |> args.Add - let manager = BufferManager.create Core.MAX_CONNECTIONS Core.BUFFER_SIZE - let cleaner = connections |> cleanUp |> flip Observable.subscribe subscriptions { new IState with - member state.BufferManager - with get () = manager - member state.BufferedArgs with get () = args @@ -271,9 +265,6 @@ module TcpServer = if args.SocketError <> SocketError.Success then do onError "onSend" state args else - args.BytesTransferred - |> String.format "sent {0} bytes" - |> Logger.debug (tag "onSend") do returnArgs state args do dispose listener @@ -370,7 +361,7 @@ module TcpServer = with get () = options.ServerId member server.Start() = - either { + result { try do! Network.ensureAvailability options.Listen options.Port do state.Listener.Bind(state.EndPoint) @@ -380,7 +371,7 @@ module TcpServer = return! exn.Message |> Error.asSocketError (tag "Start") - |> Either.fail + |> Result.fail } member server.Request (client: Guid) (request: Request) = diff --git a/src/Disco/Disco/Nodes/Nodes/ApiClientNode.fs b/src/Disco/Disco/Nodes/Nodes/ApiClientNode.fs index 4f362e46..36ce6793 100644 --- a/src/Disco/Disco/Nodes/Nodes/ApiClientNode.fs +++ b/src/Disco/Disco/Nodes/Nodes/ApiClientNode.fs @@ -112,8 +112,8 @@ module Api = let private serverInfo (state: PluginState) = let ip = match IpAddress.TryParse state.InServerIp.[0] with - | Right ip -> ip - | Left error -> + | Ok ip -> ip + | Error error -> Logger.err "serverInfo" error.Message IPv4Address "127.0.0.1" @@ -146,7 +146,7 @@ module Api = let client = ApiClient.create server myself match client.Start() with - | Right () -> + | Ok () -> let apiobs = client.Subscribe(enqueueEvent state) Logger.info "startClient" "successfully started ApiClient" { state with @@ -154,7 +154,7 @@ module Api = Status = ServiceStatus.Starting ApiClient = client Disposables = [ apiobs ] } - | Left error -> + | Error error -> Logger.err "startClient" error.Message { state with Initialized = true @@ -453,10 +453,6 @@ type ApiClientNode() = [] val mutable OutConnected: ISpread - [] - [] - val mutable OutCount: ISpread - [] [] val mutable OutUpdate: ISpread diff --git a/src/Disco/Disco/Nodes/Nodes/ClientIdNode.fs b/src/Disco/Disco/Nodes/Nodes/ClientIdNode.fs index 3d5ffe22..150347dc 100644 --- a/src/Disco/Disco/Nodes/Nodes/ClientIdNode.fs +++ b/src/Disco/Disco/Nodes/Nodes/ClientIdNode.fs @@ -53,20 +53,21 @@ type ClientIdNode() = self.InStr.[0] |> DiscoId.TryParse |> function - | Right id -> id - | Left _ -> + | Ok id -> id + | Error _ -> DISCO_CLIENT_ID_ENV_VAR |> Environment.GetEnvironmentVariable |> DiscoId.TryParse |> function - | Right id -> id - | Left _ -> DiscoId.Create() + | Ok id -> id + | Error _ -> DiscoId.Create() do Logger.initialize { MachineId = id Tier = Tier.Client UseColors = false Level = LogLevel.Debug + Fields = LogEventFields.Default } self.OutClientId.[0] <- id diff --git a/src/Disco/Disco/Nodes/Nodes/ClusterConfigNode.fs b/src/Disco/Disco/Nodes/Nodes/ClusterConfigNode.fs index 875e6ced..45354eb0 100644 --- a/src/Disco/Disco/Nodes/Nodes/ClusterConfigNode.fs +++ b/src/Disco/Disco/Nodes/Nodes/ClusterConfigNode.fs @@ -48,7 +48,7 @@ type ClusterConfigNode() = [] [] - val mutable OutMembers: ISpread> + val mutable OutMembers: ISpread> [] [] diff --git a/src/Disco/Disco/Nodes/Nodes/ConfigNode.fs b/src/Disco/Disco/Nodes/Nodes/ConfigNode.fs index 59a59105..9a48dde5 100644 --- a/src/Disco/Disco/Nodes/Nodes/ConfigNode.fs +++ b/src/Disco/Disco/Nodes/Nodes/ConfigNode.fs @@ -79,14 +79,18 @@ type ConfigNode() = member self.Evaluate (_: int) : unit = if self.InUpdate.[0] && not (Util.isNullReference self.InConfig.[0]) then let config = self.InConfig.[0] + let sites = + config.Sites + |> Map.toArray + |> Array.map snd self.OutMachine.[0] <- config.Machine self.OutAudio.[0] <- config.Audio self.OutClients.[0] <- config.Clients self.OutRaft.[0] <- config.Raft self.OutTiming.[0] <- config.Timing - self.OutSites.SliceCount <- Array.length config.Sites - self.OutSites.AssignFrom config.Sites + self.OutSites.SliceCount <- Map.count config.Sites + self.OutSites.AssignFrom sites self.OutVersion.[0] <- string config.Version if self.InUpdate.IsChanged then diff --git a/src/Disco/Disco/Nodes/Nodes/GraphNode.fs b/src/Disco/Disco/Nodes/Nodes/GraphNode.fs index bd3699dc..9a635cd7 100644 --- a/src/Disco/Disco/Nodes/Nodes/GraphNode.fs +++ b/src/Disco/Disco/Nodes/Nodes/GraphNode.fs @@ -183,11 +183,11 @@ module rec Graph = try str |> IOBoxType.Parse - |> Either.succeed + |> Result.succeed with exn -> exn.Message |> Error.asParseError "IOBoxType" - |> Either.fail + |> Result.fail // ** ValueType @@ -214,12 +214,12 @@ module rec Graph = try str |> ValueType.Parse - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asParseError "ValueType.TryParse" - |> Either.fail + |> Result.fail static member IsBool (vt: ValueType) = match vt with @@ -250,11 +250,11 @@ module rec Graph = try str |> Behavior.Parse - |> Either.succeed + |> Result.succeed with exn -> exn.Message |> Error.asParseError "Behavior.TryParse" - |> Either.fail + |> Result.fail static member IsTrigger (bh: Behavior) = match bh with @@ -281,15 +281,15 @@ module rec Graph = let private findPin (name: string) (pins: IPin2 seq) = Seq.fold - (fun (m: Either) (pin: IPin2) -> + (fun (m: DiscoResult) (pin: IPin2) -> match m with - | Right _ -> m - | Left error -> + | Ok _ -> m + | Error error -> if pin.Name = name then - Right pin + Ok pin else - Left error) - (Left (Other("findPin", (sprintf "could not find pin %A" name)))) + Error error) + (Error (Other("findPin", (sprintf "could not find pin %A" name)))) pins // ** visibleInputPins @@ -327,7 +327,7 @@ module rec Graph = // ** parseValueType let private parseValueType (node: INode2) = - either { + result { let! vtp = findPin Settings.VALUE_TYPE_PIN node.Pins return! ValueType.TryParse vtp.[0] } @@ -335,7 +335,7 @@ module rec Graph = // ** parseBehavior let private parseBehavior (node: INode2) = - either { + result { let! bhp = findPin Settings.BEHAVIOR_PIN node.Pins return! Behavior.TryParse bhp.[0] } @@ -344,13 +344,13 @@ module rec Graph = let private isTrigger (node: INode2) = match parseBehavior node with - | Right bh -> Behavior.IsTrigger bh + | Ok bh -> Behavior.IsTrigger bh | _ -> false // ** parseName let private parseName (node: INode2) = - either { + result { let! np = findPin Settings.DESCRIPTIVE_NAME_PIN node.Pins return if isNull np.[0] @@ -403,7 +403,7 @@ module rec Graph = |> node.FindPin |> fun pin -> pin.[0] |> function - | "Input" -> Either.succeed VecSize.Dynamic + | "Input" -> Result.succeed VecSize.Dynamic | _ -> let cols = try @@ -424,7 +424,7 @@ module rec Graph = with | _ -> 1us cols * rows * pages |> VecSize.Fixed - |> Either.succeed + |> Result.succeed // ** parseBoolValues @@ -458,37 +458,37 @@ module rec Graph = // ** parseMin let private parseMin (node: INode2) = - either { + result { let! min = findPin Settings.MIN_PIN node.Pins let! value = try min.[0] |> Int32.Parse - |> Either.succeed + |> Result.succeed with _ -> - Either.succeed -99999999 + Result.succeed -99999999 return value } // ** parseMax let private parseMax (node: INode2) = - either { + result { let! max = findPin Settings.MAX_PIN node.Pins let! value = try max.[0] |> Int32.Parse - |> Either.succeed + |> Result.succeed with _ -> - Either.succeed 99999999 + Result.succeed 99999999 return value } // ** parseUnits let private parseUnits (node: INode2) = - either { + result { let! units = findPin Settings.UNITS_PIN node.Pins return if isNull units.[0] then "" else units.[0] } @@ -496,15 +496,15 @@ module rec Graph = // ** parsePrecision let private parsePrecision (node: INode2) = - either { + result { let! precision = findPin Settings.PRECISION_PIN node.Pins let! value = try precision.[0] |> UInt32.Parse - |> Either.succeed + |> Result.succeed with _ -> - Either.succeed 4ul + Result.succeed 4ul return value } @@ -610,7 +610,7 @@ module rec Graph = // ** parsePinType let private parsePinType (node: INode2) = - either { + result { let! boxtype = IOBoxType.TryParse (node.NodeInfo.ToString()) match boxtype with | IOBoxType.Value -> @@ -627,7 +627,7 @@ module rec Graph = return! sprintf "unsupported type %A" x |> Error.asParseError "parsePinType" - |> Either.fail + |> Result.fail } // ** addCommand @@ -655,7 +655,7 @@ module rec Graph = let pp = node.FindPin Settings.PAGES_PIN let tp = node.FindPin Settings.TAG_PIN let trig = isTrigger node - let tipe = parsePinType node |> Either.defaultValue PinType.Number + let tipe = parsePinType node |> Result.defaultValue PinType.Number let props = parseEnumProperties node let vecsizeUpdate _ _ = @@ -748,7 +748,7 @@ module rec Graph = // ** parseValuePin let private parseValuePin clientId nodeId groupId (node:INode2) (pin: IPin2) = - either { + result { let path = generateNodePath node pin let pinId = generatePinId nodeId groupId pin let cnf = parseConfiguration pin @@ -823,13 +823,13 @@ module rec Graph = // ** parseSeqWith - type private Parser = IPin2 -> Either + type private Parser = IPin2 -> DiscoResult let private parseSeqWith (parse: Parser) (pins: IPin2 seq) : (IPin2 * Pin) list = Seq.fold (fun lst pin -> parse pin |> function - | Right parsed -> (pin, parsed) :: lst - | Left error -> + | Ok parsed -> (pin, parsed) :: lst + | Error error -> error |> string |> Logger.err "parseSeqWith" @@ -852,7 +852,7 @@ module rec Graph = // ** parseStringType let private parseStringType (node: INode2) = - either { + result { let! st = findPin Settings.STRING_TYPE_PIN node.Pins return! Disco.Core.Behavior.TryParse st.[0] } @@ -860,22 +860,22 @@ module rec Graph = // ** parseMaxChars let private parseMaxChars (node: INode2) = - either { + result { let! mc = findPin Settings.MAXCHAR_PIN node.Pins let! value = try mc.[0] |> Int32.Parse - |> Either.succeed + |> Result.succeed with _ -> - Either.succeed -1 + Result.succeed -1 return value } // ** parseStringPin let private parseStringPin clientId nodeId groupId (node:INode2) (pin: IPin2) = - either { + result { let path = generateNodePath node pin let id = generatePinId nodeId groupId pin let cnf = parseConfiguration pin @@ -917,7 +917,7 @@ module rec Graph = // ** parseEnumPin let private parseEnumPin clientId nodeId groupId (node: INode2) (pin: IPin2) = - either { + result { let path = generateNodePath node pin let id = generatePinId nodeId groupId pin let cnf = parseConfiguration pin @@ -957,7 +957,7 @@ module rec Graph = // ** parseColorPin let private parseColorPin clientId nodeId groupId (node:INode2) (pin: IPin2) = - either { + result { let path = generateNodePath node pin let id = generatePinId nodeId groupId pin let cnf = parseConfiguration pin @@ -995,7 +995,7 @@ module rec Graph = // ** parseINode2 let private parseINode2 clientId nodeId groupId (node: INode2) = - either { + result { let! boxtype = IOBoxType.TryParse (string node.NodeInfo) match boxtype with | IOBoxType.Value -> return parseValueBox clientId nodeId groupId node @@ -1006,7 +1006,7 @@ module rec Graph = return! sprintf "unsupported type %A" x |> Error.asParseError "parseINode2" - |> Either.fail + |> Result.fail } // ** parseGroupName @@ -1100,10 +1100,10 @@ module rec Graph = /// parse all visibile pin on this node and match parseINode2 clientId nodeId groupId node with - | Left error -> + | Error error -> Logger.err (tag "nodeAdded") error.Message state - | Right pins -> + | Ok pins -> Seq.fold (fun (state: PluginState) (pin:IPin2, parsed: Pin) -> addPin state nodeId node pin parsed) @@ -1197,7 +1197,7 @@ module rec Graph = let private pinNameChange (state: PluginState) groupId pinId (node:INode2) = parseName node - |> Either.defaultValue "" + |> Result.defaultValue "" |> name |> Pin.setName |> updatePinWith state groupId pinId (Some UpdatePin) @@ -1213,7 +1213,7 @@ module rec Graph = let private pinVecSizeChange (state: PluginState) groupId pinId node = parseVecSize node - |> Either.defaultValue VecSize.Dynamic + |> Result.defaultValue VecSize.Dynamic |> Pin.setVecSize |> updatePinWith state groupId pinId (Some UpdatePin) @@ -1225,9 +1225,9 @@ module rec Graph = | None -> state | Some nodeId -> match parseINode2 state.ClientId nodeId groupId node with - | Right [] -> state - | Left error -> Logger.err "processing" error.Message; state - | Right parsed -> + | Ok [] -> state + | Error error -> Logger.err "processing" error.Message; state + | Ok parsed -> List.fold (fun (state:PluginState) (pin,parsed) -> pin @@ -1267,9 +1267,9 @@ module rec Graph = let cnf = parseConfiguration pin let tipe, props = match parsePinType node with - | Right PinType.Enum -> PinType.Enum, Some (parseEnumProperties node) - | Right tipe -> tipe, None - | Left _ -> PinType.String, None /// default is string + | Ok PinType.Enum -> PinType.Enum, Some (parseEnumProperties node) + | Ok tipe -> tipe, None + | Error _ -> PinType.String, None /// default is string { PinId = id GroupId = groupId NodePath = node.GetNodePath(false) diff --git a/src/Disco/Disco/Nodes/Nodes/LoggingNode.fs b/src/Disco/Disco/Nodes/Nodes/LoggingNode.fs index b88c0e2a..19c88725 100644 --- a/src/Disco/Disco/Nodes/Nodes/LoggingNode.fs +++ b/src/Disco/Disco/Nodes/Nodes/LoggingNode.fs @@ -88,7 +88,7 @@ type LoggingNode() = if self.InUpdate.[0] && not (Util.isNullReference self.InClientId.[0]) then match LogLevel.TryParse self.InLevel.[0].Name with - | Right level -> Logger.log level "Log" self.InLog.[0] + | Ok level -> Logger.log level "Log" self.InLog.[0] | _ -> () if logs.IsEmpty then diff --git a/src/Disco/Disco/Nodes/Nodes/MemberNode.fs b/src/Disco/Disco/Nodes/Nodes/MemberNode.fs index 730c47ba..0cba2ab6 100644 --- a/src/Disco/Disco/Nodes/Nodes/MemberNode.fs +++ b/src/Disco/Disco/Nodes/Nodes/MemberNode.fs @@ -42,10 +42,6 @@ type MemberNode() = [] val mutable OutId: ISpread - [] - [] - val mutable OutHostName: ISpread - [] [] val mutable OutIpAddress: ISpread @@ -55,16 +51,8 @@ type MemberNode() = val mutable OutRaftPort: ISpread [] - [] - val mutable OutWsPort: ISpread - - [] - [] - val mutable OutGitPort: ISpread - - [] - [] - val mutable OutApiPort: ISpread + [] + val mutable OutState: ISpread [] [] @@ -78,25 +66,17 @@ type MemberNode() = member self.Evaluate (spreadMax: int) : unit = if self.InUpdate.[0] then self.OutId.SliceCount <- self.InMember.SliceCount - self.OutHostName.SliceCount <- self.InMember.SliceCount self.OutIpAddress.SliceCount <- self.InMember.SliceCount + self.OutState.SliceCount <- self.InMember.SliceCount self.OutStatus.SliceCount <- self.InMember.SliceCount self.OutRaftPort.SliceCount <- self.InMember.SliceCount - self.OutWsPort.SliceCount <- self.InMember.SliceCount - self.OutGitPort.SliceCount <- self.InMember.SliceCount - self.OutApiPort.SliceCount <- self.InMember.SliceCount - for n in 0 .. (spreadMax - 1) do if not (Util.isNullReference self.InMember.[n]) then let mem = self.InMember.[n] self.OutId.[n] <- string mem.Id - self.OutHostName.[n] <- unwrap mem.HostName self.OutIpAddress.[n] <- string mem.IpAddress self.OutStatus.[n] <- string mem.Status + self.OutState.[n] <- string mem.State self.OutRaftPort.[n] <- int mem.RaftPort - self.OutWsPort.[n] <- int mem.WsPort - self.OutGitPort.[n] <- int mem.GitPort - self.OutApiPort.[n] <- int mem.ApiPort - if self.InUpdate.IsChanged then self.OutUpdate.[0] <- self.InUpdate.[0] diff --git a/src/Disco/Disco/Raft/Log.fs b/src/Disco/Disco/Raft/Log.fs index c7fc633c..1ac074d7 100644 --- a/src/Disco/Disco/Raft/Log.fs +++ b/src/Disco/Disco/Raft/Log.fs @@ -15,20 +15,33 @@ open FlatBuffers open Disco.Core open Disco.Serialization -// * RaftLog +// * Log -// ____ __ _ _ -// | _ \ __ _ / _| |_| | ___ __ _ -// | |_) / _` | |_| __| | / _ \ / _` | -// | _ < (_| | _| |_| |__| (_) | (_| | -// |_| \_\__,_|_| \__|_____\___/ \__, | -// |___/ +// _ +// | | ___ __ _ +// | | / _ \ / _` | +// | |__| (_) | (_| | +// |_____\___/ \__, | +// |___/ + +type Log = + { Data: LogEntry option + Depth: int + Index: Index } + + // ** optics + + static member Data_ = + (fun (log:Log) -> log.Data), + (fun data (log:Log) -> { log with Data = data }) + + static member Depth_ = + (fun (log:Log) -> log.Depth), + (fun depth (log:Log) -> { log with Depth = depth }) -type RaftLog = - { Data : RaftLogEntry option - ; Depth : int - ; Index : Index - } + static member Index_ = + (fun (log:Log) -> log.Index), + (fun index (log:Log) -> { log with Index = index }) // ** ToString @@ -81,19 +94,19 @@ type RaftLog = /// ### Signature: /// - logs: LogFB array /// - /// Returns: Either - static member FromFB (logs: LogFB array) : Either = - either { - let! entries = RaftLogEntry.FromFB logs + /// Returns: DiscoResult + static member FromFB (logs: LogFB array) : DiscoResult = + result { + let! entries = LogEntry.FromFB logs match entries with | Some entries as value -> return { Data = value Depth = LogEntry.depth entries - Index = LogEntry.getIndex entries } + Index = LogEntry.index entries } | _ -> return { Data = None Depth = 0 - Index = index 0 } + Index = 0 } } // * Log Module @@ -108,18 +121,33 @@ type RaftLog = [] module Log = - // ** Log.empty + open Aether + + // ** getters + + let depth = Optic.get Log.Depth_ + let data = Optic.get Log.Data_ + let index = Optic.get Log.Index_ + + // ** setters + + let setDepth = Optic.set Log.Depth_ + let setData = Optic.set Log.Data_ + let setIndex = Optic.set Log.Index_ + + // ** empty /// ## Construct an empty log. /// /// Build a new, empty log data structure. /// /// Returns: RaftLog - let empty = { Depth = 0 - ; Index = index 0 - ; Data = None } + let empty = + { Depth = 0 + Index = 0 + Data = None } - // ** Log.fromEntries + // ** fromEntries /// ## Construct a new log value from entries /// @@ -129,12 +157,12 @@ module Log = /// - entries: LogEntry's to construct RaftLog from /// /// Returns: RaftLog - let fromEntries (entries: RaftLogEntry) = + let fromEntries (entries: LogEntry) = { Depth = LogEntry.depth entries - ; Index = LogEntry.getIndex entries - ; Data = Some entries } + Index = LogEntry.index entries + Data = Some entries } - // ** Log.length + // ** length /// ## Length of logg /// @@ -146,19 +174,7 @@ module Log = /// Returns: Long let length log = log.Depth - // ** Log.index - - /// ## Return the current Index in the log - /// - /// Return the current index in the RaftLog value - /// - /// ### Signature: - /// - log: RaftLog to get index for - /// - /// Returns: Long - let getIndex log = log.Index - - // ** Log.prevIndex + // ** prevIndex /// ## Return the index of the previous element /// @@ -171,7 +187,7 @@ module Log = let prevIndex log = Option.bind LogEntry.prevIndex log.Data - // ** Log.term + // ** term /// ## Return the Term of the latest log entry /// @@ -181,12 +197,12 @@ module Log = /// - log: RaftLog to return term for /// /// Returns: Long - let getTerm log = + let term log = match log.Data with - | Some entries -> LogEntry.getTerm entries - | _ -> term 0 + | Some entries -> LogEntry.term entries + | _ -> 0 - // ** Log.prevTerm + // ** prevTerm /// ## Return the Term of the previous entry /// @@ -199,7 +215,7 @@ module Log = let prevTerm log = Option.bind LogEntry.prevTerm log.Data - // ** Log.previous + // ** previous /// Return the last Entry, if it exists /// @@ -210,150 +226,149 @@ module Log = match LogEntry.prevEntry entries with | Some entry -> { Depth = LogEntry.depth entry - ; Index = LogEntry.getIndex entry + ; Index = LogEntry.index entry ; Data = Some entry } |> Some | _ -> None | _ -> None - // ** Log.prevEntry + // ** prevEntry let prevEntry log = Option.bind (LogEntry.prevEntry) log.Data - // ** Log.foldLogL + // ** foldLogL let foldLogL f m log = match log.Data with | Some entries -> LogEntry.foldl f m entries | _ -> m - // ** Log.foldLogR + // ** foldLogR let foldLogR f m log = match log.Data with | Some entries -> LogEntry.foldr f m entries | _ -> m - // ** Log.at + // ** at let at idx log = Option.bind (LogEntry.at idx) log.Data - // ** Log.until + // ** until let until idx log = Option.bind (LogEntry.until idx) log.Data - // ** Log.untilExcluding + // ** untilExcluding let untilExcluding idx log = Option.bind (LogEntry.untilExcluding idx) log.Data - // ** Log.append + // ** append - let append newentries log : RaftLog = + let append newentries log: Log = match log.Data with | Some entries -> let newlog = LogEntry.append newentries entries - { Index = LogEntry.getIndex newlog + { Index = LogEntry.index newlog Depth = LogEntry.depth newlog Data = Some newlog } | _ -> let entries = LogEntry.rewrite newentries - { Index = LogEntry.getIndex entries + { Index = LogEntry.index entries Depth = LogEntry.depth entries Data = Some entries } - // ** Log.find + // ** find let find id log = Option.bind (LogEntry.find id) log.Data - // ** Log.make + // ** make let make term data = LogEntry.make term data - // ** Log.mkConfig + // ** configuration - let mkConfig term nodes = LogEntry.mkConfig term nodes + let configuration = LogEntry.configuration - // ** Log.mkConfigChange + // ** jointConsensus - let mkConfigChange term changes = - LogEntry.mkConfigChange term changes + let jointConsensus = LogEntry.jointConsensus let calculateChanges oldnodes newnodes = LogEntry.calculateChanges oldnodes newnodes - // ** Log.entries + // ** entries let entries log = log.Data - // ** Log.aggregate + // ** aggregate let aggregate f m log = Option.map (LogEntry.aggregate f m) log.Data - // ** Log.snapshot + // ** snapshot let snapshot nodes data log = match log.Data with | Some entries -> let snapshot = LogEntry.snapshot nodes data entries - { Index = LogEntry.getIndex snapshot + { Index = LogEntry.index snapshot Depth = 1 Data = Some snapshot } | _ -> log - // ** Log.head + // ** head let head log = Option.map LogEntry.head log.Data - // ** Log.lastTerm + // ** lastTerm let lastTerm log = Option.bind LogEntry.lastTerm log.Data - // ** Log.lastTerm + // ** lastTerm let lastIndex log = Option.bind LogEntry.lastIndex log.Data - // ** Log.last + // ** last /// Return the last entry in the chain of logs. let last log = Option.map LogEntry.last log.Data - // ** Log.iter + // ** iter /// Iterate over log entries, in order of newsest to oldest. let iter f log = Option.map (LogEntry.iter f) log.Data |> ignore - // ** Log.firstIndex + // ** firstIndex /// Retrieve the index of the first log entry for the given term. Return None /// if no result was found; let firstIndex term log = Option.bind (LogEntry.firstIndex term) log.Data - // ** Log.getn + // ** getn let getn count log = Option.bind (LogEntry.getn count) log.Data - // ** Log.contains + // ** contains - let contains (f: RaftLogEntry -> bool) log : bool = + let contains (f: LogEntry -> bool) log : bool = match Option.map (LogEntry.contains f) log.Data with | Some result -> result | _ -> false - // ** Log.map + // ** map let map f log = Option.map (LogEntry.map f) log.Data diff --git a/src/Disco/Disco/Raft/LogEntry.fs b/src/Disco/Disco/Raft/LogEntry.fs index 0fa987ad..479786d9 100644 --- a/src/Disco/Disco/Raft/LogEntry.fs +++ b/src/Disco/Disco/Raft/LogEntry.fs @@ -40,7 +40,7 @@ type SnapshotYaml() = #endif -// * RaftLogEntry +// * LogEntry /// _ _____ _ /// | | ___ __ _| ____|_ __ | |_ _ __ _ _ @@ -87,7 +87,7 @@ type SnapshotYaml() = /// Data : StateMachine // state machine data /// -type RaftLogEntry = +type LogEntry = // Member Configuration Entry | Configuration of @@ -95,7 +95,7 @@ type RaftLogEntry = Index : Index * Term : Term * Members : RaftMember array * - Previous : RaftLogEntry option + Previous : LogEntry option // Entry type for configuration changes | JointConsensus of @@ -103,7 +103,7 @@ type RaftLogEntry = Index : Index * Term : Term * Changes : ConfigChange array * - Previous : RaftLogEntry option + Previous : LogEntry option // Regular Log Entries | LogEntry of @@ -111,7 +111,7 @@ type RaftLogEntry = Index : Index * Term : Term * Data : StateMachine * - Previous : RaftLogEntry option + Previous : LogEntry option | Snapshot of Id : LogId * @@ -122,6 +122,43 @@ type RaftLogEntry = Members : RaftMember array * Data : StateMachine + // ** optics + + static member Id_ = + (function + | Configuration(id,_,_,_,_) -> id + | JointConsensus(id,_,_,_,_) -> id + | LogEntry(id,_,_,_,_) -> id + | Snapshot(id,_,_,_,_,_,_) -> id), + (fun id -> function + | Configuration(_,idx,term,mems,prev) -> Configuration(id,idx,term,mems,prev) + | JointConsensus(_,idx,term,changes,prev) -> JointConsensus(id,idx,term,changes,prev) + | LogEntry(_,idx,term,data,prev) -> LogEntry(id,idx,term,data,prev) + | Snapshot(_,idx,term,lidx,lterm,mems,data) -> Snapshot(id,idx,term,lidx,lterm,mems,data)) + + static member Index_ = + (function + | Configuration(_,idx,_,_,_) -> idx + | JointConsensus(_,idx,_,_,_) -> idx + | LogEntry(_,idx,_,_,_) -> idx + | Snapshot(_,idx,_,_,_,_,_) -> idx), + (fun idx -> function + | Configuration(id,_,term,mems,prev) -> Configuration(id,idx,term,mems,prev) + | JointConsensus(id,_,term,changes,prev) -> JointConsensus(id,idx,term,changes,prev) + | LogEntry(id,_,term,data,prev) -> LogEntry(id,idx,term,data,prev) + | Snapshot(id,_,term,lidx,lterm,mems,data) -> Snapshot(id,idx,term,lidx,lterm,mems,data)) + + static member Term_ = + (function + | Configuration(_,_,term,_,_) -> term + | JointConsensus(_,_,term,_,_) -> term + | LogEntry(_,_,term,_,_) -> term + | Snapshot(_,_,term,_,_,_,_) -> term), + (fun term -> function + | Configuration(id,idx,_,mems,prev) -> Configuration(id,idx,term,mems,prev) + | JointConsensus(id,idx,_,changes,prev) -> JointConsensus(id,idx,term,changes,prev) + | LogEntry(id,idx,_,data,prev) -> LogEntry(id,idx,term,data,prev) + | Snapshot(id,idx,_,lidx,lterm,mems,data) -> Snapshot(id,idx,term,lidx,lterm,mems,data)) // ** ToString @@ -191,13 +228,12 @@ type RaftLogEntry = /// Get the current log's Id. /// /// Returns: Id - member self.Id - with get () = - match self with - | Configuration(id,_,_,_,_) -> id - | JointConsensus(id,_,_,_,_) -> id - | LogEntry(id,_,_,_,_) -> id - | Snapshot(id,_,_,_,_,_,_) -> id + member self.Id = + match self with + | Configuration(id,_,_,_,_) -> id + | JointConsensus(id,_,_,_,_) -> id + | LogEntry(id,_,_,_,_) -> id + | Snapshot(id,_,_,_,_,_,_) -> id // ** Depth @@ -206,20 +242,19 @@ type RaftLogEntry = /// Compute the depth of the current log. /// /// Returns: int - member self.Depth - with get () = - let rec _depth i thing = - let inline count i prev = - let cnt = i + 1 - match prev with - | Some other -> _depth cnt other - | _ -> cnt - match thing with - | Configuration(_,_,_,_,prev) -> count i prev - | JointConsensus(_,_,_,_,prev) -> count i prev - | LogEntry(_,_,_,_,prev) -> count i prev - | Snapshot _ -> i + 1 - _depth 0 self + member self.Depth = + let rec _depth i thing = + let inline count i prev = + let cnt = i + 1 + match prev with + | Some other -> _depth cnt other + | _ -> cnt + match thing with + | Configuration(_,_,_,_,prev) -> count i prev + | JointConsensus(_,_,_,_,prev) -> count i prev + | LogEntry(_,_,_,_,prev) -> count i prev + | Snapshot _ -> i + 1 + _depth 0 self // ** Iter @@ -231,28 +266,15 @@ type RaftLogEntry = /// - f: int -> RaftLogEntry -> unit /// /// Returns: unit - member self.Iter (f : int -> RaftLogEntry -> unit) = + member self.Iter (f : int -> LogEntry -> unit) = let rec impl start = function - | Configuration(_,_,_,_,Some prev) as curr -> - f start curr; impl (start + 1) prev - - | Configuration(_,_,_,_,None) as curr -> - f start curr - - | JointConsensus(_,_,_,_,Some prev) as curr -> - f start curr; impl (start + 1) prev - - | JointConsensus(_,_,_,_,None) as curr -> - f start curr - - | LogEntry(_,_,_,_,Some prev) as curr -> - f start curr; impl (start + 1) prev - - | LogEntry(_,_,_,_,None) as curr -> - f start curr - - | Snapshot _ as curr -> - f start curr + | Configuration(_,_,_,_,Some prev) as curr -> f start curr; impl (start + 1) prev + | Configuration(_,_,_,_,None) as curr -> f start curr + | JointConsensus(_,_,_,_,Some prev) as curr -> f start curr; impl (start + 1) prev + | JointConsensus(_,_,_,_,None) as curr -> f start curr + | LogEntry(_,_,_,_,Some prev) as curr -> f start curr; impl (start + 1) prev + | LogEntry(_,_,_,_,None) as curr -> f start curr + | Snapshot _ as curr -> f start curr impl 0 self @@ -271,7 +293,7 @@ type RaftLogEntry = LogFB.AddEntry(builder, value) LogFB.EndLogFB(builder) - let toOffset (log: RaftLogEntry) = + let toOffset (log: LogEntry) = match log with // ____ __ _ _ _ // / ___|___ _ __ / _(_) __ _ _ _ _ __ __ _| |_(_) ___ _ __ @@ -348,7 +370,7 @@ type RaftLogEntry = buildLogFB LogTypeFB.SnapshotFB entry.Value let arr = Array.zeroCreate (self.Depth |> int) - self.Iter (fun i (log: RaftLogEntry) -> arr.[int i] <- toOffset log) + self.Iter (fun i (log: LogEntry) -> arr.[int i] <- toOffset log) arr // ** ParseLogFB @@ -362,12 +384,12 @@ type RaftLogEntry = /// - fb: LogFB FlatBuffer object /// - sibling: an sibling (None also legal, for the first mem), or the previous error /// - /// Returns: Either + /// Returns: DiscoResult static member ParseLogFB (fb: LogFB) - (sibling: Either) - : Either = + (sibling: DiscoResult) + : DiscoResult = match fb.EntryType with - | LogTypeFB.ConfigurationFB -> either { + | LogTypeFB.ConfigurationFB -> result { // the previous log entry. An error, if occurred previously let! previous = sibling @@ -381,7 +403,7 @@ type RaftLogEntry = let! mems = let arr = Array.zeroCreate logentry.MembersLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (i, arr) = m let! mem = let value = logentry.Members(i) @@ -390,27 +412,27 @@ type RaftLogEntry = else "Could not parse empty MemberFB value" |> Error.asParseError "StateMachine.ParseLogFB" - |> Either.fail + |> Result.fail arr.[i] <- mem return (i + 1, arr) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd + |> Result.map snd let! id = Id.decodeId logentry // successfully parsed this LogEntry, so return it wrapped in an option - return (id, index logentry.Index, term logentry.Term, mems, previous) + return (id, 1 * logentry.Index, 1 * logentry.Term, mems, previous) |> Configuration |> Some else return! "Could not parse empty LogTypeFB.ConfigurationFB" |> Error.asParseError "StateMachine.ParseLogFB" - |> Either.fail + |> Result.fail } - | LogTypeFB.JointConsensusFB -> either { + | LogTypeFB.JointConsensusFB -> result { // the previous entry, or an error. short-circuits here on error. let! previous = sibling @@ -423,7 +445,7 @@ type RaftLogEntry = let! changes = let arr = Array.zeroCreate logentry.ChangesLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (i, changes) = m // pull the index and array out let! change = let value = logentry.Changes(i) @@ -433,26 +455,26 @@ type RaftLogEntry = else "Could not parse empty ConfigChangeFB value" |> Error.asParseError "StateMachine.FromFB" - |> Either.fail + |> Result.fail changes.[i] <- change return (i + 1, changes) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd + |> Result.map snd let! id = Id.decodeId logentry - return (id, index logentry.Index, term logentry.Term, changes, previous) + return (id, 1 * logentry.Index, 1 * logentry.Term, changes, previous) |> JointConsensus |> Some else return! "Could not parse empty LogTypeFB.JointConsensusFB" |> Error.asParseError "StateMachine.ParseLogFB" - |> Either.fail + |> Result.fail } - | LogTypeFB.LogEntryFB -> either { + | LogTypeFB.LogEntryFB -> result { let! previous = sibling let entry = fb.Entry() @@ -462,22 +484,22 @@ type RaftLogEntry = if data.HasValue then let! command = StateMachine.FromFB data.Value let! id = Id.decodeId logentry - return(id, index logentry.Index, term logentry.Term, command, previous) + return(id, 1 * logentry.Index, 1 * logentry.Term, command, previous) |> LogEntry |> Some else return! "Could not parse empty StateMachineFB" |> Error.asParseError "StateMachine.ParseLogFB" - |> Either.fail + |> Result.fail else return! "Could not parse empty LogTypeFB.LogEntry" |> Error.asParseError "StateMachine.ParseLogFB" - |> Either.fail + |> Result.fail } - | LogTypeFB.SnapshotFB -> either { + | LogTypeFB.SnapshotFB -> result { // Snapshots don't have ancestors, so move ahead right away let entry = fb.Entry() if entry.HasValue then @@ -491,7 +513,7 @@ type RaftLogEntry = let! mems = let arr = Array.zeroCreate logentry.MembersLength Array.fold - (fun (m: Either) _ -> either { + (fun (m: DiscoResult) _ -> result { let! (i, mems) = m let! mem = @@ -502,39 +524,40 @@ type RaftLogEntry = else "Could not parse empty RaftMemberFB" |> Error.asParseError "StateMachine.ParseLogFB" - |> Either.fail + |> Result.fail mems.[i] <- mem return (i + 1, mems) }) - (Right (0, arr)) + (Ok (0, arr)) arr - |> Either.map snd - - return Snapshot(id, - index logentry.Index, - term logentry.Term, - index logentry.LastIndex, - term logentry.LastTerm, - mems, - state) - |> Some + |> Result.map snd + + return + Some $ Snapshot( + id, + 1 * logentry.Index, + 1 * logentry.Term, + 1 * logentry.LastIndex, + 1 * logentry.LastTerm, + mems, + state) else return! "Could not parse empty StateMachineFB" |> Error.asParseError "StateMachine.ParseLogFB" - |> Either.fail + |> Result.fail else return! "Could not parse empty LogTypeFB.SnapshotFB" |> Error.asParseError "StateMachine.ParseLogFB" - |> Either.fail + |> Result.fail } | x -> sprintf "Could not parse unknown LogTypeFB; %A" x |> Error.asParseError "StateMachine.ParseLogFB" - |> Either.fail + |> Result.fail // ** FromFB @@ -550,8 +573,10 @@ type RaftLogEntry = /// - log: previous RaftLogEntry value to reconstruct the chain of events /// /// Returns: RaftLogEntry option - static member FromFB (logs: LogFB array) : Either = - Array.foldBack RaftLogEntry.ParseLogFB logs (Right None) + static member FromFB (logs: LogFB array): DiscoResult = + Array.foldBack LogEntry.ParseLogFB logs (Ok None) + + // ** AssetPath // _ _ // / \ ___ ___ ___| |_ @@ -565,10 +590,12 @@ type RaftLogEntry = with get () = Constants.RAFT_DIRECTORY <.> Constants.SNAPSHOT_FILENAME + Constants.ASSET_EXTENSION + // ** Save + member log.Save (basePath: FilePath) = match log with | Snapshot(id, idx, term, lastidx, lastterm, mems, _) -> - either { + result { let serializer = Serializer() let path = basePath Asset.path log use! repo = Git.Repo.repository basePath @@ -588,7 +615,7 @@ type RaftLogEntry = | _ -> "Only snapshots can be saved" |> Error.asAssetError "LogEntry.Save" - |> Either.fail + |> Result.fail #endif @@ -597,26 +624,25 @@ type RaftLogEntry = [] module LogEntry = - // ** LogEntry.getId + open Aether - // _ _ - // (_) __| | - // | |/ _` | - // | | (_| | - // |_|\__,_| - // + // ** getters - /// ## Get the Id of a log entry - /// - /// Get the unique identifier of the top-most log entry - /// - /// ### Signature: - /// - log: RaftLogEntry to get Id ofg - /// - /// Returns: Id - let getId (log: RaftLogEntry) = log.Id + let id = Optic.get LogEntry.Id_ + let index = Optic.get LogEntry.Index_ + let term = Optic.get LogEntry.Term_ - // ** LogEntry.isConfigChange + // ** setters + + let setId = Optic.set LogEntry.Id_ + let setIndex = Optic.set LogEntry.Index_ + let setTerm = Optic.set LogEntry.Term_ + + // ** create + + let create index term entry = LogEntry(DiscoId.Create(),index,term,entry,None) + + // ** isConfigChange // _ ____ __ _ ____ _ // (_)___ / ___|___ _ __ / _(_) __ _ / ___| |__ __ _ _ __ __ _ ___ @@ -629,7 +655,7 @@ module LogEntry = | JointConsensus _ -> true | _ -> false - // ** LogEntry.isConfiguration + // ** isConfiguration // _ ____ __ _ _ _ // (_)___ / ___|___ _ __ / _(_) __ _ _ _ _ __ __ _| |_(_) ___ _ __ @@ -642,7 +668,7 @@ module LogEntry = | Configuration _ -> true | _ -> false - // ** LogEntry.depth + // ** depth // _ _ _ // __| | ___ _ __ | |_| |__ @@ -653,26 +679,10 @@ module LogEntry = // /// compute the actual depth of the log (e.g. for compacting) - let depth (log: RaftLogEntry) = + let depth (log: LogEntry) = log.Depth - // ** LogEntry.index - - // _ _ - // (_)_ __ __| | _____ __ - // | | '_ \ / _` |/ _ \ \/ / - // | | | | | (_| | __/> < - // |_|_| |_|\__,_|\___/_/\_\ - // - /// Return the index of the current log entry. - - let getIndex = function - | Configuration(_,idx,_,_,_) -> idx - | JointConsensus(_,idx,_,_,_) -> idx - | LogEntry(_,idx,_,_,_) -> idx - | Snapshot(_,idx,_,_,_,_,_) -> idx - - // ** LogEntry.prevIndex + // ** prevIndex // ___ _ // _ __ _ __ _____ _|_ _|_ __ __| | _____ __ @@ -684,29 +694,13 @@ module LogEntry = /// Return the index of the previous element if present. let prevIndex = function - | Configuration(_,_,_,_,Some prev) -> Some (getIndex prev) - | JointConsensus(_,_,_,_,Some prev) -> Some (getIndex prev) - | LogEntry(_,_,_,_,Some prev) -> Some (getIndex prev) + | Configuration(_,_,_,_,Some prev) -> Some (index prev) + | JointConsensus(_,_,_,_,Some prev) -> Some (index prev) + | LogEntry(_,_,_,_,Some prev) -> Some (index prev) | Snapshot(_,_,_,idx,_,_,_) -> Some idx | _ -> None - // ** LogEntry.term - - // _ - // | |_ ___ _ __ _ __ ___ - // | __/ _ \ '__| '_ ` _ \ - // | || __/ | | | | | | | - // \__\___|_| |_| |_| |_| - // - /// Extract the `Term` field from a RaftLogEntry - - let getTerm = function - | Configuration(_,_,term,_,_) -> term - | JointConsensus(_,_,term,_,_) -> term - | LogEntry(_,_,term,_,_) -> term - | Snapshot(_,_,term,_,_,_,_) -> term - - // ** LogEntry.prevTerm + // ** prevTerm // _____ // _ __ _ __ _____ _|_ _|__ _ __ _ __ ___ @@ -718,13 +712,13 @@ module LogEntry = /// Return the previous elements' term, if present. let prevTerm = function - | Configuration(_,_,_,_,Some prev) -> Some (getTerm prev) - | JointConsensus(_,_,_,_,Some prev) -> Some (getTerm prev) - | LogEntry(_,_,_,_,Some prev) -> Some (getTerm prev) + | Configuration(_,_,_,_,Some prev) -> Some (term prev) + | JointConsensus(_,_,_,_,Some prev) -> Some (term prev) + | LogEntry(_,_,_,_,Some prev) -> Some (term prev) | Snapshot(_,_,_,_,term,_,_) -> Some term | _ -> None - // ** LogEntry.prevEntry + // ** prevEntry // _____ _ // _ __ _ __ _____ _| ____|_ __ | |_ _ __ _ _ @@ -741,7 +735,7 @@ module LogEntry = | LogEntry(_,_,_,_,prev) -> prev | Snapshot _ -> None - // ** LogEntry.data + // ** data // _ _ // __| | __ _| |_ __ _ @@ -756,7 +750,7 @@ module LogEntry = | Snapshot(_,_,_,_,_,_,d) -> Some d | _ -> None - // ** LogEntry.mems + // ** members // _ // _ __ ___ __| | ___ ___ @@ -766,12 +760,12 @@ module LogEntry = // /// Return the current log entry's mems property, should it have one - let mems = function + let members = function | Configuration(_,_,_,d,_) -> Some d | Snapshot(_,_,_,_,_,d,_) -> Some d | _ -> None - // ** LogEntry.changes + // ** changes // _ // ___| |__ __ _ _ __ __ _ ___ ___ @@ -788,7 +782,7 @@ module LogEntry = | _ -> None - // ** LogEntry.at + // ** at // _ // __ _| |_ @@ -818,7 +812,7 @@ module LogEntry = | _ when idx <= lidx' -> Some curr | _ -> None - // ** LogEntry.until + // ** until // _ _ _ // _ _ _ __ | |_(_) | @@ -838,14 +832,8 @@ module LogEntry = | Configuration(id,index,term,mems,Some prev) -> match idx with - | _ when idx = index -> - Configuration(id,index,term,mems,None) - |> Some - - | _ when idx < index -> - Configuration(id,index,term,mems,until idx prev) - |> Some - + | _ when idx = index -> Some $ Configuration(id,index,term,mems,None) + | _ when idx < index -> Some $ Configuration(id,index,term,mems,until idx prev) | _ -> None | JointConsensus(_,index,_,_,None) as curr -> @@ -855,14 +843,8 @@ module LogEntry = | JointConsensus(id,index,term,changes,Some prev) -> match idx with - | _ when idx = index -> - JointConsensus(id,index,term,changes,None) - |> Some - - | _ when idx < index -> - JointConsensus(id,index,term,changes,until idx prev) - |> Some - + | _ when idx = index -> Some $ JointConsensus(id,index,term,changes,None) + | _ when idx < index -> Some $ JointConsensus(id,index,term,changes,until idx prev) | _ -> None | LogEntry(_,index,_,_,None) as curr -> @@ -872,17 +854,11 @@ module LogEntry = | LogEntry(id,index,term,data,Some prev) -> match idx with - | _ when idx = index -> - LogEntry(id,index,term,data,None) - |> Some - - | _ when idx < index -> - LogEntry(id,index,term,data,until idx prev) - |> Some - + | _ when idx = index -> Some $ LogEntry(id,index,term,data,None) + | _ when idx < index -> Some $ LogEntry(id,index,term,data,until idx prev) | _ -> None - // ** LogEntry.untilExcluding + // ** untilExcluding /// _ _ _ _____ _ _ _ /// _ _ _ __ | |_(_) | ____|_ _____| |_ _ __| (_)_ __ __ _ @@ -890,35 +866,26 @@ module LogEntry = /// | |_| | | | | |_| | | |___ > < (__| | |_| | (_| | | | | | (_| | /// \__,_|_| |_|\__|_|_|_____/_/\_\___|_|\__,_|\__,_|_|_| |_|\__, | /// |___/ - /// ### Complextiy: O(n) + /// ### Complexity: O(n) let rec untilExcluding idx = function | Snapshot _ as curr -> Some curr + | Configuration(_,index,_,_,Some _) when idx >= index -> None | Configuration(id,index,term,mems,Some prev) -> - if idx >= index then - None - else - Configuration(id,index,term,mems,untilExcluding idx prev) - |> Some + Some $ Configuration(id,index,term,mems,untilExcluding idx prev) + | JointConsensus(_,index,_,_,Some _) when idx >= index -> None | JointConsensus(id,index,term,changes,Some prev) -> - if idx >= index then - None - else - JointConsensus(id,index,term,changes,untilExcluding idx prev) - |> Some + Some $ JointConsensus(id,index,term,changes,untilExcluding idx prev) + | LogEntry(_,index,_,_,Some _) when idx >= index -> None | LogEntry(id,index,term,data,Some prev) -> - if idx >= index then - None - else - LogEntry(id,index,term,data,untilExcluding idx prev) - |> Some + Some $ LogEntry(id,index,term,data,untilExcluding idx prev) | _ -> None - // ** LogEntry.find + // ** find /// _____ _ _ /// | ___(_)_ __ __| | @@ -943,7 +910,7 @@ module LogEntry = | Snapshot(id',_,_,_,_,_,_) as curr -> if id' <> id then None else Some curr - // ** LogEntry.make + // ** make /// __ __ _ /// | \/ | __ _| | _____ @@ -952,26 +919,24 @@ module LogEntry = /// |_| |_|\__,_|_|\_\___| let make term data = - LogEntry(DiscoId.Create(), index 0, term, data, None) + LogEntry(DiscoId.Create(), 0, term, data, None) - // ** LogEntry.mkConfig + // ** configuration /// Add an Configuration log entry onto the queue - /// - /// ### Complexity: 0(1) - let mkConfig term mems = - Configuration(DiscoId.Create(), index 0, term, mems, None) + let configuration term mems = + Configuration(DiscoId.Create(), 0, term, mems, None) - // ** LogEntry.mkConfigChange + // ** jointConsensus /// Add an intermediate configuration entry for 2-phase commit onto /// the log queue - /// - /// ### Complexity: 0(1) - let mkConfigChange term changes = - JointConsensus(DiscoId.Create(), index 0, term, changes, None) + let jointConsensus term changes = + JointConsensus(DiscoId.Create(), 0, term, changes, None) + + // ** calculateChanges let calculateChanges oldmems newmems = let changes = @@ -980,18 +945,22 @@ module LogEntry = (fun lst (newmem: RaftMember) -> match Array.tryFind (Member.id >> (=) newmem.Id) oldmems with | Some _ -> lst - | _ -> MemberAdded(newmem) :: lst) [] newmems + | _ -> MemberAdded(newmem) :: lst) + List.empty + newmems Array.fold (fun lst (oldmem: RaftMember) -> match Array.tryFind (Member.id >> (=) oldmem.Id) newmems with | Some _ -> lst - | _ -> MemberRemoved(oldmem) :: lst) additions oldmems + | _ -> MemberRemoved(oldmem) :: lst) + additions + oldmems |> List.toArray changes - // ** LogEntry.pop + // ** pop /// _ __ ___ _ __ /// | '_ \ / _ \| '_ \ @@ -1010,7 +979,7 @@ module LogEntry = | LogEntry(_,_,_,_,prev) -> prev | Snapshot _ -> None - // ** LogEntry.snapshot + // ** snapshot /// _ _ /// ___ _ __ __ _ _ __ ___| |__ ___ | |_ @@ -1028,10 +997,9 @@ module LogEntry = | Configuration(_,idx,term,_,_) -> idx,term | JointConsensus(_,idx,term,_,_) -> idx,term | Snapshot(_,idx,term,_,_,_,_) -> idx,term - in - Snapshot(DiscoId.Create(),idx + 1,term,idx,term,mems,data) + in Snapshot(DiscoId.Create(),idx + 1,term,idx,term,mems,data) - // ** LogEntry.map + // ** map /// _ __ ___ __ _ _ __ /// | '_ ` _ \ / _` | '_ \ @@ -1041,7 +1009,7 @@ module LogEntry = /// /// Map over a Logs<'a,'n> and return a list of results - let rec map (f : RaftLogEntry -> 'b) entry = + let rec map (f : LogEntry -> 'b) entry = let _map curr prev = match prev with | Some previous -> f curr :: map f previous @@ -1053,7 +1021,7 @@ module LogEntry = | LogEntry(_,_,_,_,prev) as curr -> _map curr prev | Snapshot _ as curr -> _map curr None - // ** LogEntry.foldl + // ** foldl /// __ _ _ _ /// / _| ___ | | __| | | @@ -1063,7 +1031,7 @@ module LogEntry = /// /// Fold over a Log and return an aggregate value - let rec foldl (f : 'm -> RaftLogEntry -> 'm) (m : 'm) log = + let rec foldl (f : 'm -> LogEntry -> 'm) (m : 'm) log = let _fold m curr prev = let _m = f m curr match prev with @@ -1076,7 +1044,7 @@ module LogEntry = | LogEntry(_,_,_,_,prev) as curr -> _fold m curr prev | Snapshot _ as curr -> f m curr - // ** LogEntry.foldr + // ** foldr /// __ _ _ /// / _| ___ | | __| |_ __ @@ -1086,7 +1054,7 @@ module LogEntry = /// /// Fold over a Log and return an aggregate value - let rec foldr (f : 'm -> RaftLogEntry -> 'm) (m : 'm) = function + let rec foldr (f : 'm -> LogEntry -> 'm) (m : 'm) = function | Configuration(_,_,_,_,Some prev) as curr -> f (foldr f m prev) curr | Configuration(_,_,_,_,None) as curr -> f m curr | JointConsensus(_,_,_,_,Some prev) as curr -> f (foldr f m prev) curr @@ -1095,7 +1063,7 @@ module LogEntry = | LogEntry(_,_,_,_,None) as curr -> f m curr | Snapshot _ as curr -> f m curr - // ** LogEntry.iter + // ** iter /// _ _ /// (_) |_ ___ _ __ @@ -1104,10 +1072,10 @@ module LogEntry = /// |_|\__\___|_| /// /// Iterate over a log from the newest entry to the oldest. - let iter (f : int -> RaftLogEntry -> unit) (log : RaftLogEntry) = + let iter (f : int -> LogEntry -> unit) (log: LogEntry) = log.Iter f - // ** LogEntry.aggregate + // ** aggregate /// _ _ /// / \ __ _ __ _ _ __ ___ __ _ __ _| |_ ___ @@ -1119,7 +1087,7 @@ module LogEntry = /// Version of left-fold that implements short-circuiting by requiring the /// return value to be wrapped in `Continue<'a>`. - let inline aggregate< ^m > (f : ^m -> RaftLogEntry -> Continue< ^m >) (m : ^m) log = + let inline aggregate< ^m > (f : ^m -> LogEntry -> Continue< ^m >) (m : ^m) log = // wrap the supplied function such that it takes a value lifted to // Continue to proactively stop calculating (what about passing a // closure instead?) @@ -1129,7 +1097,7 @@ module LogEntry = | v -> v // short-circuiting inner function - let rec _resFold (m : Continue< ^m >) (_log : RaftLogEntry) : Continue< ^m > = + let rec _resFold (m : Continue< ^m >) (_log: LogEntry) : Continue< ^m > = let _do curr prev = match m with | Cont _ -> @@ -1151,17 +1119,17 @@ module LogEntry = | Cont v -> v | Ret v -> v - // ** LogEntry.next + // ** next let inline next< ^m > (m: ^m) : Continue< ^m > = Continue.next m - // ** LogEntry.finish + // ** finish let inline finish< ^m > (m: ^m) : Continue< ^m > = Continue.finish m - // ** LogEntry.last + // ** last /// _ _ /// | | __ _ ___| |_ @@ -1180,7 +1148,7 @@ module LogEntry = | JointConsensus(_,_,_,_,Some prev) -> last prev | Snapshot _ as curr -> curr - // ** LogEntry.head + // ** head // _ _ // | |__ ___ __ _ __| | @@ -1200,7 +1168,7 @@ module LogEntry = | curr -> curr - // ** LogEntry.rewrite + // ** rewrite // _ _ // _ __ _____ ___ __(_) |_ ___ @@ -1211,30 +1179,30 @@ module LogEntry = let rec rewrite entry = match entry with | Configuration(id, _, _, mems, None) -> - Configuration(id, index 1, term 1, mems, None) + Configuration(id, 1, 1, mems, None) | Configuration(id, _, term, mems, Some prev) -> let previous = rewrite prev - Configuration(id, getIndex previous + index 1, term, mems, Some previous) + Configuration(id, index previous + 1, term, mems, Some previous) | JointConsensus(id, _, term, changes, None) -> - JointConsensus(id, index 1, term, changes, None) + JointConsensus(id, 1, term, changes, None) | JointConsensus(id, _, term, changes, Some prev) -> let previous = rewrite prev - JointConsensus(id, getIndex previous + index 1, term, changes, Some previous) + JointConsensus(id, index previous + 1, term, changes, Some previous) | LogEntry(id, _, term, data, None) -> - LogEntry(id, index 1, term, data, None) + LogEntry(id, 1, term, data, None) | LogEntry(id, _, term, data, Some prev) -> let previous = rewrite prev - LogEntry(id, getIndex previous + index 1, term, data, Some previous) + LogEntry(id, index previous + 1, term, data, Some previous) | Snapshot(id, _, term, _, pterm, mems, data) -> - Snapshot(id, index 2, term, index 1, pterm, mems, data) + Snapshot(id, 2, term, 1, pterm, mems, data) - // ** LogEntry.append + // ** append /// _ /// __ _ _ __ _ __ ___ _ __ __| | @@ -1245,12 +1213,12 @@ module LogEntry = /// /// Append newer entries to older entries - let append (newer : RaftLogEntry) (older : RaftLogEntry) = - let _aggregator (_log : RaftLogEntry) (_entry : RaftLogEntry) = - if getId _log = getId _entry then - _log + let append (newer: LogEntry) (older: LogEntry) = + let _aggregator (_log: LogEntry) (_entry: LogEntry) = + if id _log = id _entry + then _log else - let nextIdx = getIndex _log + index 1 + let nextIdx = index _log + 1 match _entry with | Configuration(id, _, term, mems, _) -> Configuration(id, nextIdx, term, mems, Some _log) @@ -1266,7 +1234,7 @@ module LogEntry = // find the last shared ancestor let last = last newer - let lcd = find (getId last) older + let lcd = find (id last) older match lcd with | Some ancestor -> @@ -1279,7 +1247,7 @@ module LogEntry = // no overlap found foldr _aggregator older newer - // ** LogEntry.lastIndex + // ** lastIndex // _ _ ___ _ // | | __ _ ___| |_|_ _|_ __ __| | _____ __ @@ -1291,7 +1259,7 @@ module LogEntry = | Snapshot(_,_,_,idx,_,_,_) -> Some idx | _ -> None - // ** LogEntry.lastTerm + // ** lastTerm // _ _ _____ // | | __ _ ___| ||_ _|__ _ __ _ __ ___ @@ -1303,7 +1271,7 @@ module LogEntry = | Snapshot(_,_,_,_,term,_,_) -> Some term | _ -> None - // ** LogEntry.firstIndex + // ** firstIndex // __ _ _ ___ _ // / _(_)_ __ ___| |_|_ _|_ __ __| | _____ __ @@ -1311,7 +1279,7 @@ module LogEntry = // | _| | | \__ \ |_ | || | | | (_| | __/> < // |_| |_|_| |___/\__|___|_| |_|\__,_|\___/_/\_\ - let rec firstIndex (t: Term) (entry: RaftLogEntry) = + let rec firstIndex (t: Term) (entry: LogEntry) = let getIdx idx term prev = match prev with | Some log -> @@ -1342,7 +1310,7 @@ module LogEntry = else None - // ** LogEntry.getn + // ** getn // _ // __ _ ___| |_ _ __ @@ -1373,7 +1341,7 @@ module LogEntry = LogEntry(id,idx,term,data, getn newcnt prev) |> Some - // ** LogEntry.contains + // ** contains // _ _ // ___ ___ _ __ | |_ __ _(_)_ __ ___ @@ -1381,7 +1349,7 @@ module LogEntry = // | (_| (_) | | | | || (_| | | | | \__ \ // \___\___/|_| |_|\__\__,_|_|_| |_|___/ - let rec contains (f: RaftLogEntry -> bool) = function + let rec contains (f: LogEntry -> bool) = function | LogEntry(_,_,_,_,Some prev) as this -> if f this then true else contains f prev @@ -1399,7 +1367,7 @@ module LogEntry = | Snapshot _ as this -> f this - // ** LogEntry.sanitize + // ** sanitize // ____ _ _ _ // / ___| __ _ _ __ (_) |_(_)_______ @@ -1409,7 +1377,7 @@ module LogEntry = /// Make sure the current log entry is a singleton (followed by no entries). let sanitize term = function - | Configuration(id,_,term,mems,_) -> Configuration(id, index 0,term,mems,None) - | JointConsensus(id,_,term,changes,_) -> JointConsensus(id, index 0,term,changes,None) - | LogEntry(id,_,_,data,_) -> LogEntry(id, index 0,term,data,None) + | Configuration(id,_,term,mems,_) -> Configuration(id, 0,term,mems,None) + | JointConsensus(id,_,term,changes,_) -> JointConsensus(id, 0,term,changes,None) + | LogEntry(id,_,_,data,_) -> LogEntry(id, 0,term,data,None) | Snapshot _ as snapshot -> snapshot diff --git a/src/Disco/Disco/Raft/Member.fs b/src/Disco/Disco/Raft/Member.fs index ed2b50e1..9d38f92d 100644 --- a/src/Disco/Disco/Raft/Member.fs +++ b/src/Disco/Disco/Raft/Member.fs @@ -53,12 +53,12 @@ type MemberStatus = static member TryParse (str: string) = try - str |> MemberStatus.Parse |> Either.succeed + str |> MemberStatus.Parse |> Result.succeed with | exn -> sprintf "Could not parse MemberStatus: %s" exn.Message |> Error.asParseError "MemberStatus.TryParse" - |> Either.fail + |> Result.fail // ** ToOffset @@ -73,22 +73,22 @@ type MemberStatus = static member FromFB (fb: MemberStatusFB) = #if FABLE_COMPILER match fb with - | x when x = MemberStatusFB.JoiningFB -> Right Joining - | x when x = MemberStatusFB.RunningFB -> Right Running - | x when x = MemberStatusFB.FailedFB -> Right Failed + | x when x = MemberStatusFB.JoiningFB -> Ok Joining + | x when x = MemberStatusFB.RunningFB -> Ok Running + | x when x = MemberStatusFB.FailedFB -> Ok Failed | x -> sprintf "Could not parse MemberStatus: %A" x |> Error.asParseError "MemberStatus.FromFB" - |> Either.fail + |> Result.fail #else match fb with - | MemberStatusFB.JoiningFB -> Right Joining - | MemberStatusFB.RunningFB -> Right Running - | MemberStatusFB.FailedFB -> Right Failed + | MemberStatusFB.JoiningFB -> Ok Joining + | MemberStatusFB.RunningFB -> Ok Running + | MemberStatusFB.FailedFB -> Ok Failed | x -> sprintf "Could not parse MemberStatus: %A" x |> Error.asParseError "MemberStatus.FromFB" - |> Either.fail + |> Result.fail #endif // * RaftMemberYaml @@ -150,11 +150,11 @@ type MemberState = static member TryParse str = try MemberState.Parse str - |> Either.succeed + |> Result.succeed with exn -> exn.Message |> Error.asParseError "RaftState.TryParse" - |> Either.fail + |> Result.fail // ** ToOffset @@ -169,33 +169,26 @@ type MemberState = static member FromFB(fb: MemberStateFB) = match fb with #if FABLE_COMPILER - | x when x = MemberStateFB.FollowerFB -> Right Follower - | x when x = MemberStateFB.LeaderFB -> Right Leader - | x when x = MemberStateFB.CandidateFB -> Right Candidate + | x when x = MemberStateFB.FollowerFB -> Ok Follower + | x when x = MemberStateFB.LeaderFB -> Ok Leader + | x when x = MemberStateFB.CandidateFB -> Ok Candidate #else - | MemberStateFB.FollowerFB -> Right Follower - | MemberStateFB.LeaderFB -> Right Leader - | MemberStateFB.CandidateFB -> Right Candidate + | MemberStateFB.FollowerFB -> Ok Follower + | MemberStateFB.LeaderFB -> Ok Leader + | MemberStateFB.CandidateFB -> Ok Candidate #endif | other -> other |> String.format "unknown raft state: {0}" |> Error.asParseError "RaftState.FromFB" - |> Either.fail + |> Result.fail // * RaftMember type RaftMember = { Id: MemberId - HostName: Name IpAddress: IpAddress - MulticastAddress: IpAddress - MulticastPort: Port - HttpPort: Port RaftPort: Port - WsPort: Port - GitPort: Port - ApiPort: Port Voting: bool VotedForMe: bool State: MemberState @@ -209,42 +202,14 @@ type RaftMember = (fun (mem:RaftMember) -> mem.Id), (fun id (mem:RaftMember) -> { mem with Id = id }) - static member HostName_ = - (fun (mem:RaftMember) -> mem.HostName), - (fun hostName (mem:RaftMember) -> { mem with HostName = hostName }) - static member IpAddress_ = (fun (mem:RaftMember) -> mem.IpAddress), (fun ipAddress (mem:RaftMember) -> { mem with IpAddress = ipAddress }) - static member MulticastAddress_ = - (fun (mem:RaftMember) -> mem.MulticastAddress), - (fun multicastAddress (mem:RaftMember) -> { mem with MulticastAddress = multicastAddress }) - - static member MulticastPort_ = - (fun (mem:RaftMember) -> mem.MulticastPort), - (fun multicastPort (mem:RaftMember) -> { mem with MulticastPort = multicastPort }) - static member RaftPort_ = (fun (mem:RaftMember) -> mem.RaftPort), (fun raftPort (mem:RaftMember) -> { mem with RaftPort = raftPort }) - static member HttpPort_ = - (fun (mem:RaftMember) -> mem.HttpPort), - (fun httpPort (mem:RaftMember) -> { mem with HttpPort = httpPort }) - - static member WsPort_ = - (fun (mem:RaftMember) -> mem.WsPort), - (fun wsPort (mem:RaftMember) -> { mem with WsPort = wsPort }) - - static member GitPort_ = - (fun (mem:RaftMember) -> mem.GitPort), - (fun gitPort (mem:RaftMember) -> { mem with GitPort = gitPort }) - - static member ApiPort_ = - (fun (mem:RaftMember) -> mem.ApiPort), - (fun apiPort (mem:RaftMember) -> { mem with ApiPort = apiPort }) - static member Voting_ = (fun (mem:RaftMember) -> mem.Voting), (fun voting (mem:RaftMember) -> { mem with Voting = voting }) @@ -272,15 +237,12 @@ type RaftMember = // ** ToString override self.ToString() = - sprintf "%O (%O, %O) on %A (%O:%d) (group:%O:%d) (NextIdx: %A) (MatchId: %d)" + sprintf "%O (%O) on %A (%O:%d) (NextIdx: %A) (MatchId: %d)" self.Id - self.HostName self.State self.Status self.IpAddress self.RaftPort - self.MulticastAddress - self.MulticastPort self.NextIndex self.MatchIndex @@ -297,15 +259,8 @@ type RaftMember = member self.ToYaml () = let yaml = RaftMemberYaml() yaml.Id <- string self.Id - yaml.HostName <- unwrap self.HostName yaml.IpAddress <- string self.IpAddress - yaml.MulticastAddress <- string self.MulticastAddress - yaml.MulticastPort <- unwrap self.MulticastPort - yaml.HttpPort <- unwrap self.HttpPort yaml.RaftPort <- unwrap self.RaftPort - yaml.WsPort <- unwrap self.WsPort - yaml.GitPort <- unwrap self.GitPort - yaml.ApiPort <- unwrap self.ApiPort yaml.State <- string self.State yaml.Status <- string self.Status yaml.NextIndex <- self.NextIndex @@ -316,8 +271,8 @@ type RaftMember = // ** FromYaml - static member FromYaml (yaml: RaftMemberYaml) : Either = - either { + static member FromYaml (yaml: RaftMemberYaml): DiscoResult = + result { let! id = DiscoId.TryParse yaml.Id let! ip = IpAddress.TryParse yaml.IpAddress let! mcastip = IpAddress.TryParse yaml.MulticastAddress @@ -325,15 +280,8 @@ type RaftMember = let! status = MemberStatus.TryParse yaml.Status return { Id = id - HostName = name yaml.HostName - MulticastAddress = mcastip - MulticastPort = port yaml.MulticastPort IpAddress = ip - HttpPort = port yaml.HttpPort RaftPort = port yaml.RaftPort - WsPort = port yaml.WsPort - GitPort = port yaml.GitPort - ApiPort = port yaml.ApiPort Voting = yaml.Voting VotedForMe = yaml.VotedForMe NextIndex = yaml.NextIndex @@ -350,14 +298,6 @@ type RaftMember = member mem.ToOffset (builder: FlatBufferBuilder) = let id = RaftMemberFB.CreateIdVector(builder,mem.Id.ToByteArray()) let ip = string mem.IpAddress |> builder.CreateString - let mcastip = string mem.MulticastAddress |> builder.CreateString - - let hostname = - let unwrapped = unwrap mem.HostName - if isNull unwrapped then - None - else - unwrapped |> builder.CreateString |> Some let state = mem.State.ToOffset(builder) let status = mem.Status.ToOffset() @@ -365,18 +305,8 @@ type RaftMember = RaftMemberFB.StartRaftMemberFB(builder) RaftMemberFB.AddId(builder, id) - match hostname with - | Some hostname -> RaftMemberFB.AddHostName(builder, hostname) - | None -> () - - RaftMemberFB.AddMulticastAddress(builder, mcastip) - RaftMemberFB.AddMulticastPort(builder, unwrap mem.MulticastPort) RaftMemberFB.AddIpAddress(builder, ip) RaftMemberFB.AddRaftPort(builder, unwrap mem.RaftPort) - RaftMemberFB.AddHttpPort(builder, unwrap mem.HttpPort) - RaftMemberFB.AddWsPort(builder, unwrap mem.WsPort) - RaftMemberFB.AddGitPort(builder, unwrap mem.GitPort) - RaftMemberFB.AddApiPort(builder, unwrap mem.ApiPort) RaftMemberFB.AddVoting(builder, mem.Voting) RaftMemberFB.AddVotedForMe(builder, mem.VotedForMe) RaftMemberFB.AddState(builder, state) @@ -387,30 +317,22 @@ type RaftMember = // ** FromFB - static member FromFB (fb: RaftMemberFB) : Either = - either { + static member FromFB (fb: RaftMemberFB): DiscoResult = + result { let! id = Id.decodeId fb let! state = MemberState.FromFB fb.State let! status = MemberStatus.FromFB fb.Status let! ip = IpAddress.TryParse fb.IpAddress - let! mcastip = IpAddress.TryParse fb.MulticastAddress return { Id = id State = state Status = status - HostName = name fb.HostName IpAddress = ip - MulticastAddress = mcastip - MulticastPort = port fb.MulticastPort - HttpPort = port fb.HttpPort RaftPort = port fb.RaftPort - WsPort = port fb.WsPort - GitPort = port fb.GitPort - ApiPort = port fb.ApiPort Voting = fb.Voting VotedForMe = fb.VotedForMe - NextIndex = index fb.NextIndex - MatchIndex = index fb.MatchIndex + NextIndex = 1 * fb.NextIndex + MatchIndex = 1 * fb.MatchIndex } } @@ -483,8 +405,8 @@ type ConfigChange = // ** FromFB - static member FromFB (fb: ConfigChangeFB) : Either = - either { + static member FromFB (fb: ConfigChangeFB): DiscoResult = + result { #if FABLE_COMPILER let! mem = fb.Member |> RaftMember.FromFB match fb.Type with @@ -494,7 +416,7 @@ type ConfigChange = return! sprintf "Could not parse ConfigChangeTypeFB %A" x |> Error.asParseError "ConfigChange.FromFB" - |> Either.fail + |> Result.fail #else let nullable = fb.Member if nullable.HasValue then @@ -506,12 +428,12 @@ type ConfigChange = return! sprintf "Could not parse ConfigChangeTypeFB %A" x |> Error.asParseError "ConfigChange.FromFB" - |> Either.fail + |> Result.fail else return! "Could not parse empty ConfigChangeFB payload" |> Error.asParseError "ConfigChange.FromFB" - |> Either.fail + |> Result.fail #endif } @@ -539,18 +461,18 @@ type ConfigChange = static member FromYaml (yml: ConfigChangeYaml) = match yml.ChangeType with - | "MemberAdded" -> either { + | "MemberAdded" -> result { let! mem = Yaml.fromYaml yml.Member return MemberAdded(mem) } - | "MemberRemoved" -> either { + | "MemberRemoved" -> result { let! mem = Yaml.fromYaml yml.Member return MemberRemoved(mem) } | x -> sprintf "Could not parse %s as ConfigChange" x |> Error.asParseError "ConfigChange.FromYaml" - |> Either.fail + |> Result.fail #endif @@ -564,15 +486,8 @@ module Member = // ** getters let id = Optic.get RaftMember.Id_ - let hostName = Optic.get RaftMember.HostName_ let ipAddress = Optic.get RaftMember.IpAddress_ - let multicastAddress = Optic.get RaftMember.MulticastAddress_ - let multicastPort = Optic.get RaftMember.MulticastPort_ let raftPort = Optic.get RaftMember.RaftPort_ - let httpPort = Optic.get RaftMember.HttpPort_ - let wsPort = Optic.get RaftMember.WsPort_ - let gitPort = Optic.get RaftMember.GitPort_ - let apiPort = Optic.get RaftMember.ApiPort_ let voting = Optic.get RaftMember.Voting_ let votedForMe = Optic.get RaftMember.VotedForMe_ let status = Optic.get RaftMember.Status_ @@ -583,15 +498,8 @@ module Member = // ** setters let setId = Optic.set RaftMember.Id_ - let setHostName = Optic.set RaftMember.HostName_ let setIpAddress = Optic.set RaftMember.IpAddress_ - let setMulticastAddress = Optic.set RaftMember.MulticastAddress_ - let setMulticastPort = Optic.set RaftMember.MulticastPort_ let setRaftPort = Optic.set RaftMember.RaftPort_ - let setHttpPort = Optic.set RaftMember.HttpPort_ - let setWsPort = Optic.set RaftMember.WsPort_ - let setGitPort = Optic.set RaftMember.GitPort_ - let setApiPort = Optic.set RaftMember.ApiPort_ let setVoting = Optic.set RaftMember.Voting_ let setVotedForMe = Optic.set RaftMember.VotedForMe_ let setStatus = Optic.set RaftMember.Status_ @@ -602,27 +510,15 @@ module Member = // ** create let create id = - #if FABLE_COMPILER - let hostname = Fable.Import.Browser.window.location.host - #else - let hostname = Network.getHostName () - #endif - { Id = id - HostName = name hostname - IpAddress = IPv4Address "127.0.0.1" - MulticastAddress = IpAddress.Parse Constants.DEFAULT_MCAST_ADDRESS - MulticastPort = Measure.port Constants.DEFAULT_MCAST_PORT - HttpPort = Measure.port Constants.DEFAULT_HTTP_PORT - RaftPort = Measure.port Constants.DEFAULT_RAFT_PORT - WsPort = Measure.port Constants.DEFAULT_WEB_SOCKET_PORT - GitPort = Measure.port Constants.DEFAULT_GIT_PORT - ApiPort = Measure.port Constants.DEFAULT_API_PORT - Status = Running - State = Follower - Voting = true - VotedForMe = false - NextIndex = index 1 - MatchIndex = index 0 } + { Id = id + IpAddress = IPv4Address "127.0.0.1" + RaftPort = Measure.port Constants.DEFAULT_RAFT_PORT + Status = Running + State = Follower + Voting = true + VotedForMe = false + NextIndex = 1 + MatchIndex = 0 } // ** isVoting diff --git a/src/Disco/Disco/Raft/Raft.fs b/src/Disco/Disco/Raft/Raft.fs index 412877d6..550e9f4e 100644 --- a/src/Disco/Disco/Raft/Raft.fs +++ b/src/Disco/Disco/Raft/Raft.fs @@ -12,159 +12,6 @@ namespace Disco.Raft open System open Disco.Core -// * RaftMonad - -[] -module RaftMonad = - - // ** warn - - let warn str = printfn "[RAFT WARNING] %s" str - - // ** get - - /// get current Raft state - let get = MkRM (fun _ s -> Right (s, s)) - - // ** put - - /// update Raft/State to supplied value - let put s = MkRM (fun _ _ -> Right ((), s)) - - // ** read - - /// get the read-only environment value - let read : RaftM<_,_> = MkRM (fun l s -> Right (l, s)) - - // ** apply - - /// unwrap the closure and apply it to the supplied state/env - let apply (env: 'e) (state: 's) (m: RaftMonad<'e,'s,_,_>) = - match m with | MkRM func -> func env state - - // ** runRaft - - /// run the monadic action against state and environment values - let runRaft (s: 's) (l: 'e) (m: RaftMonad<'e,'s,'a,'err>) = - apply l s m - - // ** evalRaft - - /// run monadic action against supplied state and evironment and return new state - let evalRaft (s: 's) (l: 'e) (m: RaftMonad<'e,'s,'a,'err>) = - match runRaft s l m with - | Right (_,state) | Left (_,state) -> state - - // ** returnM - - /// Lift a regular value into a RaftMonad by wrapping it in a closure. - /// This variant wraps it in a `Right` value. This means the computation will, - /// if possible, continue to the next step. - let returnM value : RaftMonad<'e,'s,'t,'err> = - MkRM (fun _ state -> Right(value, state)) - - // ** ignoreM - - let ignoreM _ : RaftMonad<'e,'s,unit,'err> = - MkRM (fun _ state -> Right((), state)) - - // ** failM - - /// Lift a regular value into a RaftMonad by wrapping it in a closure. - /// This variant wraps it in a `Left` value. This means the computation will - /// not continue past this step and no regular value will be returned. - let failM l = - MkRM (fun _ s -> Left (l, s)) - - // ** returnFromM - - /// pass through the given action - let returnFromM func : RaftMonad<'e,'s,'t,'err> = - func - - // ** zeroM - - let zeroM () = - MkRM (fun _ state -> Right((), state)) - - // ** delayM - - let delayM (f: unit -> RaftMonad<'e,'s,'t,'err>) = - MkRM (fun env state -> f () |> apply env state) - - // ** bindM - - /// Chain up effectful actions. - let bindM (m: RaftMonad<'env,'state,'a,'err>) - (f: 'a -> RaftMonad<'env,'state,'b,'err>) : - RaftMonad<'env,'state,'b,'err> = - MkRM (fun env state -> - match apply env state m with - | Right (value,state') -> f value |> apply env state' - | Left err -> Left err) - - // ** (>>=) - - let (>>=) = bindM - - // ** combineM - - let combineM (m1: RaftMonad<_,_,_,_>) (m2: RaftMonad<_,_,_,_>) = - bindM m1 (fun _ -> m2) - - // ** tryWithM - - let tryWithM (body: RaftMonad<_,_,_,_>) (handler: exn -> RaftMonad<_,_,_,_>) = - MkRM (fun env state -> - try apply env state body - with ex -> apply env state (handler ex)) - - // ** tryFinallyM - - let tryFinallyM (body: RaftMonad<_,_,_,_>) handler : RaftMonad<_,_,_,_> = - MkRM (fun env state -> - try apply env state body - finally handler ()) - - // ** usingM - - let usingM (resource: ('a :> System.IDisposable)) (body: 'a -> RaftMonad<_,_,_,_>) = - tryFinallyM (body resource) - (fun _ -> if not <| isNull (box resource) - then resource.Dispose()) - - // ** whileM - - let rec whileM (guard: unit -> bool) (body: RaftMonad<_,_,_,_>) = - match guard () with - | true -> bindM body (fun _ -> whileM guard body) - | _ -> zeroM () - - // ** forM - - let rec forM (sequence: seq<_>) (body: 'a -> RaftMonad<_,_,_,_>) : RaftMonad<_,_,_,_> = - usingM (sequence.GetEnumerator()) - (fun enum -> whileM enum.MoveNext (delayM (fun _ -> body enum.Current))) - - // ** RaftBuilder - - type RaftBuilder() = - member __.Return(v) = returnM v - member __.ReturnFrom(v) = returnFromM v - member __.Bind(m, f) = bindM m f - member __.Zero() = zeroM () - member __.Delay(f) = delayM f - member __.Combine(a,b) = combineM a b - member __.TryWith(body, handler) = tryWithM body handler - member __.TryFinally(body, handler) = tryFinallyM body handler - member __.Using(res, body) = usingM res body - member __.While(guard, body) = whileM guard body - member __.For(seq, body) = forM seq body - - // ** raft - - let raft = new RaftBuilder() - // * Raft [] @@ -174,1102 +21,21 @@ module rec Raft = let private tag (str: string) = String.Format("Raft.{0}",str) - // ** log - - let log site level message = - message - |> Logger.log level (tag site) - |> returnM - - // ** debug - - let debug site str = log site Debug str - - // ** info - - let info site str = log site Info str - - // ** warn - - let warn site str = log site Warn str - - // ** error - - let error site str = log site Err str - - // ** sendAppendEntriesM - - let sendAppendEntriesM (mem: RaftMember) (request: AppendEntries) = - raft { - let! state = get - let! cbs = read - - let msg = - sprintf "to: %s ci: %d term: %d leader-commit: %d prv-log-idx: %d prev-log-term: %d" - (string mem.Id) - (currentIndex state) - request.Term - request.LeaderCommit - request.PrevLogIdx - request.PrevLogTerm - - do! debug "sendAppendEntriesM" msg - - cbs.SendAppendEntries mem request - } - - // ** persistVote - - let persistVote mem = - read >>= fun cbs -> - cbs.PersistVote mem - |> returnM - - // ** persistTerm - - let persistTerm term = - read >>= fun cbs -> - cbs.PersistTerm term - |> returnM - - // ** persistLog - - let persistLog log = - read >>= fun cbs -> - cbs.PersistLog log - |> returnM - - // ** modify - - let modify (f: RaftState -> RaftState) = - get >>= (f >> put) - - // ** zoomM - - let zoomM (f: RaftState -> 'a) = - get >>= (f >> returnM) - // ** rand - let private rand = new System.Random() - - // ** create - - let create (self : RaftMember) : RaftState = - { Member = self - State = Follower - CurrentTerm = term 0 - CurrentLeader = None - Peers = Map.ofList [(self.Id, self)] - OldPeers = None - NumMembers = 1 - VotedFor = None - Log = Log.empty - CommitIndex = 0 - LastAppliedIdx = 0 - TimeoutElapsed = 0 - ElectionTimeout = Constants.RAFT_ELECTION_TIMEOUT * 1 - RequestTimeout = Constants.RAFT_REQUEST_TIMEOUT * 1 - MaxLogDepth = Constants.RAFT_MAX_LOGDEPTH - ConfigChangeEntry = None } - - // ** isFollower - - /// Is the Raft value in Follower state. - let isFollower (state: RaftState) = - state.State = Follower - - // ** isFollowerM - - let isFollowerM = fun _ -> zoomM isFollower - - // ** isCandidate - - /// Is the Raft value in Candate state. - let isCandidate (state: RaftState) = - state.State = Candidate - - // ** isCandidateM - - let isCandidateM _ = zoomM isCandidate - - // ** isLeader - - /// Is the Raft value in Leader state - let isLeader (state: RaftState) = - state.State = Leader - - // ** isLeaderM - - let isLeaderM _ = zoomM isLeader - - // ** inJointConsensus - - let inJointConsensus (state: RaftState) = - match state.ConfigChangeEntry with - | Some (JointConsensus _) -> true - | _ -> false - - // ** inJointConsensusM - - let inJointConsensusM _ = zoomM inJointConsensus - - // ** hasNonVotingMembers - - let hasNonVotingMembers (state: RaftState) = - Map.fold - (fun b _ n -> - if b then - b - else - not (Member.hasSufficientLogs n && Member.isVoting n)) - false - state.Peers - - // ** hasNonVotingMembersM - - let hasNonVotingMembersM _ = zoomM hasNonVotingMembers - - // ** getChanges - - let getChanges (state: RaftState) = - match state.ConfigChangeEntry with - | Some (JointConsensus(_,_,_,changes,_)) -> Some changes - | _ -> None - - // ** logicalPeers - - let logicalPeers (state: RaftState) = - // when setting the NumMembers counter we have to include the old config - if inJointConsensus state then - // take the old peers as seed and apply the new peers on top - match state.OldPeers with - | Some peers -> Map.fold (fun m k n -> Map.add k n m) peers state.Peers - | _ -> state.Peers - else - state.Peers - - // ** logicalPeersM - - let logicalPeersM _ = zoomM logicalPeers - - // ** countMembers - - let countMembers peers = Map.fold (fun m _ _ -> m + 1) 0 peers - - // ** numLogicalPeers - - let numLogicalPeers (state: RaftState) = - logicalPeers state |> countMembers - - // ** setNumPeers - - let setNumPeers (state: RaftState) = - { state with NumMembers = countMembers state.Peers } - - // ** recountPeers - - let recountPeers () = - get >>= (setNumPeers >> put) - - // ** setPeers - - /// Set States Members to supplied Map of Mems. Also cache count of mems. - let setPeers (peers : Map) (state: RaftState) = - { state with Peers = Map.add state.Member.Id state.Member peers } - |> setNumPeers - - // ** addMember - - /// Adds a mem to the list of known Members and increments NumMembers counter - let addMember (mem : RaftMember) (state: RaftState) : RaftState = - let exists = Map.containsKey mem.Id state.Peers - { state with - Peers = Map.add mem.Id mem state.Peers - NumMembers = - if exists - then state.NumMembers - else state.NumMembers + 1 } - - // ** addMemberM - - let addMemberM (mem: RaftMember) = - get >>= (addMember mem >> put) - - // ** addPeer - - /// Alias for `addMember` - let addPeer = addMember - - // ** addPeerM - - let addPeerM = addMemberM - - // ** addNonVotingMember - - /// Add a Non-voting Peer to the list of known Members - let addNonVotingMember (mem : RaftMember) (state: RaftState) = - addMember { mem with Voting = false; Status = Joining } state - - // ** removeMember - - /// Remove a Peer from the list of known Members and decrement NumMembers counter - let removeMember (mem : RaftMember) (state: RaftState) = - let numMembers = - if Map.containsKey mem.Id state.Peers - then state.NumMembers - 1 - else state.NumMembers - - { state with - Peers = Map.remove mem.Id state.Peers - NumMembers = numMembers } - - // ** applyChanges - - let applyChanges changes state = - let folder _state = function - | MemberAdded mem -> addNonVotingMember mem _state - | MemberRemoved mem -> removeMember mem _state - Array.fold folder state changes - - // ** updateMember - - let private updateMember (mem : RaftMember) (cbs: IRaftCallbacks) (state: RaftState) = - // if we are in joint consensus, we must update the mem value in either the - // new or the old configuration, or both. - let old = Map.tryFind mem.Id state.Peers - if inJointConsensus state then - // if the mems has structurally changed fire the callback - match old with - | Some oldMember -> if oldMember <> mem then cbs.MemberUpdated mem - | _ -> () - // update the state - { state with - Peers = - if Option.isSome old then - Map.add mem.Id mem state.Peers - else state.Peers - OldPeers = - match state.OldPeers with - | Some peers -> - if Map.containsKey mem.Id peers then - if Option.isNone old then cbs.MemberUpdated mem - Map.add mem.Id mem peers |> Some - else Some peers - | None -> // apply all required changes again - let folder m = function // but this is an edge case - | MemberAdded peer -> Map.add peer.Id peer m - | MemberRemoved peer -> Map.filter (fun k _ -> k <> peer.Id) m - let changes = getChanges state |> Option.get - let peers = Array.fold folder state.Peers changes - if Map.containsKey mem.Id peers then - Map.add mem.Id mem peers |> Some - else Some peers } - |> setNumPeers - else // base case - // if the mems has structurally changed fire the callback - match old with - | Some oldMember -> if oldMember <> mem then cbs.MemberUpdated mem - | _ -> () - { state with - Peers = - if Map.containsKey mem.Id state.Peers - then Map.add mem.Id mem state.Peers - else state.Peers } - - // ** updateMemberM - - let updateMemberM (mem: RaftMember) = - read >>= fun env -> - get >>= (updateMember mem env >> put) - - // ** addMembers - - let addMembers (mems : Map) (state: RaftState) = - Map.fold (fun m _ n -> addMember n m) state mems - - // ** addMembersM - - let addMembersM (mems: Map) = - get >>= (addMembers mems >> put) - - // ** addPeers - - let addPeers = addMembers - - // ** addPeersM - - let addPeersM = addMembersM - - // ** addNonVotingMemberM - - let addNonVotingMemberM (mem: RaftMember) = - get >>= (addNonVotingMember mem >> put) - - // ** removeMemberM - - let removeMemberM (mem: RaftMember) = - get >>= (removeMember mem >> put) - - // ** hasMember - - let hasMember (nid : MemberId) (state: RaftState) = - Map.containsKey nid state.Peers - - // ** hasMemberM - - let hasMemberM _ = hasMember >> zoomM - - // ** getMember - - let getMember (nid : MemberId) (state: RaftState) = - if inJointConsensus state then - logicalPeers state |> Map.tryFind nid - else - Map.tryFind nid state.Peers - - // ** getMemberM - - /// Find a peer by its Id. Return None if not found. - let getMemberM nid = getMember nid |> zoomM - - // ** setMemberStateM - - let setMemberStateM (nid: MemberId) state = - getMemberM nid >>= function - | Some mem -> updateMemberM { mem with Status = state } - | None -> returnM () - - // ** getMembers - - let getMembers (state: RaftState) = state.Peers - - // ** getMembersM - - let getMembersM _ = zoomM getMembers - - // ** getSelf - - let getSelf (state: RaftState) = state.Member - - // ** getSelfM - - let getSelfM _ = zoomM getSelf - - // ** setSelf - - let setSelf (mem: RaftMember) (state: RaftState) = - { state with Member = mem } - - // ** setSelfM - - let setSelfM mem = - setSelf mem |> modify - - // ** lastConfigChange - - let lastConfigChange (state: RaftState) = - state.ConfigChangeEntry - - // ** lastConfigChangeM - - let lastConfigChangeM _ = - lastConfigChange |> zoomM - - // ** setTerm - - /// Set CurrentTerm on Raft to supplied term. - let setTerm (term : Term) (state: RaftState) = - { state with CurrentTerm = term } - - // ** setTermM - - /// Set CurrentTerm to supplied value. Monadic action. - let setTermM (term : Term) = - raft { - do! setTerm term |> modify - do! persistTerm term - } - - // ** setState - - /// Set current RaftState to supplied state. - let setState (newstate: MemberState) (env: IRaftCallbacks) (state: RaftState) = - if newstate <> state.State then - env.StateChanged state.State newstate - { state with State = newstate } - else state - - // ** setStateM - - /// Set current RaftState to supplied state. Monadic action. - let setStateM (state : MemberState) = - read >>= (setState state >> modify) - - // ** getState - - /// Get current RaftState: Leader, Candidate or Follower - let getState (state: RaftState) = - state.State - - // ** getStateM - - /// Get current RaftState. Monadic action. - let getStateM _ = zoomM getState - - // ** getMaxLogDepth - - let getMaxLogDepth (state: RaftState) = - state.MaxLogDepth - - // ** getMaxLogDepthM - - let getMaxLogDepthM _ = zoomM getMaxLogDepth - - // ** setMaxLogDepth - - let setMaxLogDepth (depth: int) (state: RaftState) = - { state with MaxLogDepth = depth } - - // ** setMaxLogDepthM - - let setMaxLogDepthM (depth: int) = - setMaxLogDepth depth |> modify - - // ** self - - /// Get Member associated with supplied raft value. - let self (state: RaftState) = - state.Member - - // ** selfM - - /// Get Member associated with supplied raft value. Monadic action. - let selfM _ = zoomM self - - // ** setOldPeers - - let setOldPeers (peers : Map option) (state: RaftState) = - { state with OldPeers = peers } |> setNumPeers - - // ** setPeersM - - /// Set States Members to supplied Map of Members. Monadic action. - let setPeersM (peers: Map<_,_>) = - setPeers peers |> modify - - // ** setOldPeersM - - /// Set States Members to supplied Map of Members. Monadic action. - let setOldPeersM (peers: Map<_,_> option) = - setOldPeers peers |> modify - - // ** updatePeers - - /// Map over States Members with supplied mapping function - let updatePeers (f: RaftMember -> RaftMember) (state: RaftState) = - { state with Peers = Map.map (fun _ v -> f v) state.Peers } - - // ** updatePeersM - - /// Map over States Members with supplied mapping function. Monadic action - let updatePeersM (f: RaftMember -> RaftMember) = - updatePeers f |> modify - - // ** setLeader - - /// Set States CurrentLeader field to supplied MemberId. - let setLeader (leader : MemberId option) (cbs: IRaftCallbacks) (state: RaftState) = - if leader <> state.CurrentLeader then - let peers = - Map.map - (fun id peer -> - if Some id = leader then - let peer = Member.setState Leader peer - cbs.MemberUpdated peer - peer - else - let peer = Member.setState Follower peer - cbs.MemberUpdated peer - peer) - state.Peers - cbs.LeaderChanged leader - { state with - CurrentLeader = leader - Peers = peers } - else state - - // ** setLeaderM - - /// Set States CurrentLeader field to supplied MemberId. Monadic action. - let setLeaderM (leader : MemberId option) = - read >>= fun cbs -> setLeader leader cbs |> modify - - // ** setNextIndex - - /// Set the nextIndex field on Member corresponding to supplied Id (should it - /// exist, that is). - let setNextIndex (nid : MemberId) idx cbs (state: RaftState) = - let mem = getMember nid state - let nextidx = if idx < index 1 then index 1 else idx - match mem with - | Some mem -> updateMember { mem with NextIndex = nextidx } cbs state - | _ -> state - - // ** setNextIndexM - - /// Set the nextIndex field on Member corresponding to supplied Id (should it - /// exist, that is) and supplied index. Monadic action. - let setNextIndexM (nid : MemberId) idx = - read >>= (setNextIndex nid idx >> modify) - - // ** setAllNextIndex - - /// Set the nextIndex field on all Members to supplied index. - let setAllNextIndex idx (state: RaftState) = - let updater _ p = { p with NextIndex = idx } - if inJointConsensus state then - { state with - Peers = Map.map updater state.Peers - OldPeers = - match state.OldPeers with - | Some peers -> Map.map updater peers |> Some - | _ -> None } - else - { state with Peers = Map.map updater state.Peers } - - // ** setAllNextIndexM - - let setAllNextIndexM idx = - setAllNextIndex idx |> modify - - // ** setMatchIndex - - /// Set the matchIndex field on Member to supplied index. - let setMatchIndex nid idx env (state: RaftState) = - let mem = getMember nid state - match mem with - | Some peer -> updateMember { peer with MatchIndex = idx } env state - | _ -> state - - // ** setMatchIndexM - - let setMatchIndexM nid idx = - read >>= (setMatchIndex nid idx >> modify) - - // ** setAllMatchIndex - - /// Set the matchIndex field on all Members to supplied index. - let setAllMatchIndex idx (state: RaftState) = - let updater _ p = { p with MatchIndex = idx } - if inJointConsensus state then - { state with - Peers = Map.map updater state.Peers - OldPeers = - match state.OldPeers with - | Some peers -> Map.map updater peers |> Some - | _ -> None } - else - { state with Peers = Map.map updater state.Peers } - - // ** setAllMatchIndexM - - let setAllMatchIndexM idx = - setAllMatchIndex idx |> modify - - // ** voteFor - - /// Remeber who we have voted for in current election. - let voteFor (mem : RaftMember option) = - let doVoteFor state = - { state with VotedFor = Option.map (fun (n : RaftMember) -> n.Id) mem } - - raft { - let! state = get - do! persistVote mem - do! doVoteFor state |> put - } - - // ** voteForId - - /// Remeber who we have voted for in current election - let voteForId (nid : MemberId) = - raft { - let! mem = getMemberM nid - do! voteFor mem - } - - // ** resetVotes - - let resetVotes (state: RaftState) = - let resetter _ peer = Member.setVotedForMe false peer - { state with - Peers = Map.map resetter state.Peers - OldPeers = - match state.OldPeers with - | Some peers -> Map.map resetter peers |> Some - | _ -> None } - - // ** resetVotesM - - let resetVotesM _ = - resetVotes |> modify - - // ** voteForMyself - - let voteForMyself _ = - get >>= fun state -> voteFor (Some state.Member) - - // ** votedForMyself - - let votedForMyself (state: RaftState) = - match state.VotedFor with - | Some(nid) -> nid = state.Member.Id - | _ -> false - - // ** votedFor - - let votedFor (state: RaftState) = - state.VotedFor - - // ** votedForM - - let votedForM _ = zoomM votedFor - - // ** setVoting - - let setVoting (mem : RaftMember) (vote : bool) (state: RaftState) = - let updated = Member.setVotedForMe vote mem - if inJointConsensus state then - { state with - Peers = - if Map.containsKey updated.Id state.Peers then - Map.add updated.Id updated state.Peers - else state.Peers - OldPeers = - match state.OldPeers with - | Some peers -> - if Map.containsKey updated.Id peers then - Map.add updated.Id updated peers |> Some - else Some peers - | _ -> None } - else - { state with Peers = Map.add updated.Id updated state.Peers } - - // ** setVotingM - - let setVotingM (mem: RaftMember) (vote: bool) = - raft { - let msg = sprintf "setting mem %s voting to %b" (string mem.Id) vote - do! debug "setVotingM" msg - do! setVoting mem vote |> modify - } - - // ** currentIndex - - let currentIndex (state: RaftState) = - Log.getIndex state.Log - - // ** currentIndexM - - let currentIndexM _ = zoomM currentIndex - - // ** numMembers - - let numMembers (state: RaftState) = - state.NumMembers - - // ** numMembersM - - let numMembersM _ = zoomM numMembers - - // ** numPeers - - let numPeers = numMembers - - // ** numPeersM - - let numPeersM = numMembersM - - // ** numOldPeers - - let numOldPeers (state: RaftState) = - match state.OldPeers with - | Some peers -> Map.fold (fun m _ _ -> m + 1) 0 peers - | _ -> 0 - - // ** numOldPeersM - - let numOldPeersM _ = zoomM numOldPeers - - // ** votingMembers - - let votingMembers (state: RaftState) = - votingMembersForConfig state.Peers + let private rand = System.Random() - // ** votingMembersM - - let votingMembersM _ = zoomM votingMembers - - // ** votingMembersForConfig - - let votingMembersForConfig peers = - let counter r _ n = - if Member.isVoting n then r + 1 else r - Map.fold counter 0 peers - - // ** votingMembersForOldConfig - - let votingMembersForOldConfig (state: RaftState) = - match state.OldPeers with - | Some peers -> votingMembersForConfig peers - | _ -> 0 - - // ** votingMembersForOldConfigM - - let votingMembersForOldConfigM _ = zoomM votingMembersForOldConfig - - // ** numLogs - - let numLogs (state: RaftState) = - Log.length state.Log - - // ** numLogsM - - let numLogsM _ = zoomM numLogs - - // ** currentTerm - - let currentTerm (state: RaftState) = - state.CurrentTerm - - // ** currentTermM - - let currentTermM _ = zoomM currentTerm - - // ** firstIndex - - let firstIndex (term: Term) (state: RaftState) = - Log.firstIndex term state.Log - - // ** firstIndexM - - let firstIndexM (term: Term) = - firstIndex term |> zoomM - - // ** currentLeader - - let currentLeader (state: RaftState) = - state.CurrentLeader - - // ** currentLeaderM - - let currentLeaderM _ = zoomM currentLeader - - // ** getLeader - - let getLeader (state: RaftState) = - currentLeader state |> Option.bind (flip getMember state) - - // ** commitIndex - - let commitIndex (state: RaftState) = - state.CommitIndex - - // ** commitIndexM - - let commitIndexM () = zoomM commitIndex - - // ** setCommitIndex - - let setCommitIndex (idx : Index) (state: RaftState) = - { state with CommitIndex = idx } - - // ** setCommitIndexM - - let setCommitIndexM (idx : Index) = - setCommitIndex idx |> modify - - // ** requestTimedout - - let requestTimedOut (state: RaftState) : bool = - state.RequestTimeout <= state.TimeoutElapsed - - // ** requestTimedoutM - - let requestTimedOutM _ = zoomM requestTimedOut - - // ** electionTimedout - - let electionTimedOut (state: RaftState) : bool = - state.ElectionTimeout <= state.TimeoutElapsed - - // ** electionTimedoutM - - let electionTimedOutM _ = zoomM electionTimedOut - - // ** electionTimeout - - let electionTimeout (state: RaftState) = - state.ElectionTimeout - - // ** electionTimeoutM - - let electionTimeoutM _ = zoomM electionTimeout - - // ** timeoutElapsed - - let timeoutElapsed (state: RaftState) = - state.TimeoutElapsed - - // ** timeoutElapsedM - - let timeoutElapsedM _ = zoomM timeoutElapsed - - // ** setTimeoutElapsed - - let private setTimeoutElapsed (elapsed: Timeout) (state: RaftState) = - { state with TimeoutElapsed = elapsed } - - // ** setTimeoutElapsedM - - let setTimeoutElapsedM (elapsed: Timeout) = - setTimeoutElapsed elapsed |> modify - - // ** requestTimeout - - let requestTimeout (state: RaftState) = - state.RequestTimeout - - // ** requestTimeoutM - - let requestTimeoutM _ = zoomM requestTimeout - - // ** setRequestTimeout - - let setRequestTimeout (timeout : Timeout) (state: RaftState) = - { state with RequestTimeout = timeout } - - // ** setRequestTimeoutM - - let setRequestTimeoutM (timeout: Timeout) = - setRequestTimeout timeout |> modify - - // ** setElectionTimeout - - let setElectionTimeout (timeout : Timeout) (state: RaftState) = - { state with ElectionTimeout = timeout } - - // ** setElectionTimeoutM - - let setElectionTimeoutM (timeout: Timeout) = - setElectionTimeout timeout |> modify - - // ** _lastAppliedIdx - - let private _lastAppliedIdx (state: RaftState) = - state.LastAppliedIdx - - // ** lastAppliedIdx - - let lastAppliedIdx () = zoomM _lastAppliedIdx - - // ** setLastAppliedIdx - - let private setLastAppliedIdx (idx : Index) (state: RaftState) = - { state with LastAppliedIdx = idx } - - // ** setLastAppliedIdxM - - let setLastAppliedIdxM (idx: Index) = - setLastAppliedIdx idx |> modify - - // ** maxLogDepth - - let private maxLogDepth (state: RaftState) = state.MaxLogDepth - - // ** maxLogDepthM - - let maxLogDepthM _ = zoomM maxLogDepth - - // ** lastLogTerm - - let private lastLogTerm (state: RaftState) = - Log.getTerm state.Log - - // ** lastLogTermM - - let lastLogTermM _ = zoomM lastLogTerm - - // ** getEntryAt - - let getEntryAt (idx : Index) (state: RaftState) : RaftLogEntry option = - Log.at idx state.Log - - // ** getEntryAtM - - let getEntryAtM (idx: Index) = zoomM (getEntryAt idx) - - // ** getEntriesUntil - - let private getEntriesUntil (idx : Index) (state: RaftState) : RaftLogEntry option = - Log.until idx state.Log - - // ** getEntriesUntilM - - let getEntriesUntilM (idx: Index) = zoomM (getEntriesUntil idx) - - // ** entriesUntilExcluding - - let private entriesUntilExcluding (idx: Index) (state: RaftState) = - Log.untilExcluding idx state.Log - - // ** entriesUntilExcludingM - - let entriesUntilExcludingM (idx: Index) = - entriesUntilExcluding idx |> zoomM - - // ** handleConfigChange - - let private handleConfigChange (log: RaftLogEntry) (state: RaftState) = - match log with - | Configuration(_,_,_,mems,_) -> - let parting = - mems - |> Array.map (fun (mem: RaftMember) -> mem.Id) - |> Array.contains state.Member.Id - |> not - - let peers = - if parting then // we have been kicked out of the configuration - [| (state.Member.Id, state.Member) |] - |> Map.ofArray - else // we are still part of the new cluster configuration - Array.map toPair mems - |> Map.ofArray - - state - |> setPeers peers - |> setOldPeers None - | JointConsensus(_,_,_,changes,_) -> - let old = state.Peers - state - |> applyChanges changes - |> setOldPeers (Some old) - | _ -> state - - // ** appendEntry - - // _ _____ _ - // __ _ _ __ _ __ ___ _ __ __| | ____|_ __ | |_ _ __ _ _ - // / _` | '_ \| '_ \ / _ \ '_ \ / _` | _| | '_ \| __| '__| | | | - // | (_| | |_) | |_) | __/ | | | (_| | |___| | | | |_| | | |_| | - // \__,_| .__/| .__/ \___|_| |_|\__,_|_____|_| |_|\__|_| \__, | - // |_| |_| |___/ - - let private appendEntry (log: RaftLogEntry) = - raft { - let! state = get - - // create the new log by appending - let newlog = Log.append log state.Log - do! put { state with Log = newlog } - - // get back the entries just added - // (with correct monotonic idx's) - return Log.getn (LogEntry.depth log) newlog - } - - // ** appendEntryM - - let appendEntryM (log: RaftLogEntry) = - raft { - let! result = appendEntry log - match result with - | Some entries -> do! persistLog entries - | _ -> () - return result - } - - // ** createEntryM - - // _ _____ _ - // ___ _ __ ___ __ _| |_ ___| ____|_ __ | |_ _ __ _ _ - // / __| '__/ _ \/ _` | __/ _ \ _| | '_ \| __| '__| | | | - // | (__| | | __/ (_| | || __/ |___| | | | |_| | | |_| | - // \___|_| \___|\__,_|\__\___|_____|_| |_|\__|_| \__, | - // |___/ - - let createEntryM (entry: StateMachine) = - raft { - let! state = get - let log = LogEntry(DiscoId.Create(),index 0,state.CurrentTerm,entry,None) - return! appendEntryM log - } - - // ** updateLog - - let updateLog (log: RaftLog) (state: RaftState) = - { state with Log = log } - - // ** updateLogEntries - - let updateLogEntries (entries: RaftLogEntry) (state: RaftState) = - { state with - Log = { Index = LogEntry.getIndex entries - Depth = LogEntry.depth entries - Data = Some entries } } - - // ** removeEntry - - /// Delete a log entry at the index specified. Returns the original value if - /// the record is not found. - let private removeEntry idx (cbs: IRaftCallbacks) state = - match Log.at idx state.Log with - | Some log -> - match LogEntry.pop log with - | Some newlog -> - match Log.until idx state.Log with - | Some items -> LogEntry.iter (fun _ entry -> cbs.DeleteLog entry) items - | _ -> () - updateLogEntries newlog state - | _ -> - cbs.DeleteLog log - updateLog Log.empty state - | _ -> state - - // ** removeEntryM - - let removeEntryM idx = - raft { - let! env = read - do! removeEntry idx env |> modify - } - - // ** makeResponse - - ///////////////////////////////////////////////////////////////////////////// - // _ Receive _ _____ _ _ // - // / \ _ __ _ __ ___ _ __ __| | ____|_ __ | |_ _ __(_) ___ ___ // - // / _ \ | '_ \| '_ \ / _ \ '_ \ / _` | _| | '_ \| __| '__| |/ _ \/ __| // - // / ___ \| |_) | |_) | __/ | | | (_| | |___| | | | |_| | | | __/\__ \ // - // /_/ \_\ .__/| .__/ \___|_| |_|\__,_|_____|_| |_|\__|_| |_|\___||___/ // - // |_| |_| // - ///////////////////////////////////////////////////////////////////////////// + // ** createAppendResponse /// Preliminary Checks on the AppendEntry value - let private makeResponse (nid: MemberId option) (msg: AppendEntries) = - raft { - let! state = get - let term = currentTerm state - let current = currentIndex state - let first = - match firstIndex term state with - | Some idx -> idx - | _ -> index 0 + let private createAppendResponse (nid: MemberId option) (msg: AppendEntries) = + raft { + let! term = currentTerm () + let! current = currentIndex () + let! first = firstIndex term >>= (Option.defaultValue 0 >> returnM) - let resp = + let resp: AppendResponse = { Term = term Success = false CurrentIndex = current @@ -1277,26 +43,35 @@ module rec Raft = // 1) If this mem is currently candidate and both its and the requests // term are equal, we become follower and reset VotedFor. - let candidate = isCandidate state - let newLeader = isLeader state && numMembers state = 1 - if (candidate || newLeader) && currentTerm state = msg.Term then + let! candidate = isCandidate () + let! currentlyLeader = isLeader () + let! num = numMembers () + let newLeader = currentlyLeader && num = 1 + if (candidate || newLeader) && term = msg.Term then do! voteFor None - do! setLeaderM nid + do! setLeader nid do! becomeFollower () - return Right resp + return Ok resp // 2) Else, if the current mem's term value is lower than the requests // term, we take become follower and set our own term to higher value. - elif currentTerm state < msg.Term then - do! setTermM msg.Term - do! setLeaderM nid + elif term < msg.Term then + do! setCurrentTerm msg.Term + do! setLeader nid do! becomeFollower () - return Right { resp with Term = msg.Term } + return + resp + |> AppendResponse.setTerm msg.Term + |> Result.succeed // 3) Else, finally, if the msg's Term is lower than our own we reject the // the request entirely. - elif msg.Term < currentTerm state then - return Left { resp with CurrentIndex = currentIndex state } + elif msg.Term < term then + let! idx = currentIndex() + return + resp + |> AppendResponse.setCurrentIndex idx + |> Result.fail else - return Right resp + return Result.succeed resp } // ** handleConflicts @@ -1304,10 +79,11 @@ module rec Raft = // If an existing entry conflicts with a new one (same index // but different terms), delete the existing entry and all that // follow it (§5.3) + let private handleConflicts (request: AppendEntries) = raft { - let idx = request.PrevLogIdx + index 1 - let! local = getEntryAtM idx + let idx = request.PrevLogIdx + 1 + let! local = entryAt idx match request.Entries with | Some entries -> @@ -1316,13 +92,13 @@ module rec Raft = // then log in the request and compare their terms match local with | Some entry -> - if LogEntry.getTerm entry <> LogEntry.getTerm remote then + if LogEntry.term entry <> LogEntry.term remote then // removes entry at idx (and all following entries) - do! removeEntryM idx + do! removeEntry idx | _ -> () | _ -> if Option.isSome local then - do! removeEntryM idx + do! removeEntry idx } // ** applyRemainder @@ -1331,34 +107,36 @@ module rec Raft = raft { match msg.Entries with | Some entries -> - let! result = appendEntryM entries + let! result = appendEntry entries match result with | Some log -> - let! fst = currentTermM () >>= firstIndexM + let! fst = currentTerm () >>= firstIndex let fidx = match fst with | Some fidx -> fidx - | _ -> msg.PrevLogIdx + (log |> LogEntry.depth |> int |> index) - return { resp with - CurrentIndex = LogEntry.getIndex log - FirstIndex = fidx } + | _ -> msg.PrevLogIdx + ((log |> LogEntry.depth |> int) * 1) + return + resp + |> AppendResponse.setCurrentIndex (LogEntry.index log) + |> AppendResponse.setFirstIndex fidx | _ -> return resp | _ -> return resp } - // ** maybeSetCommitIdx + // ** requestSetCommitIndex /// If leaderCommit > commitIndex, set commitIndex = /// min(leaderCommit, index of most recent entry) - let private maybeSetCommitIdx (msg : AppendEntries) = + let private requestSetCommitIndex (msg : AppendEntries) = raft { let! state = get - let cmmtidx = commitIndex state + let! cmmtidx = commitIndex () let ldridx = msg.LeaderCommit if cmmtidx < ldridx then - let lastLogIdx = max (currentIndex state) (index 1) + let! current = currentIndex () + let lastLogIdx = max current 1 let newIndex = min lastLogIdx msg.LeaderCommit - do! setCommitIndexM newIndex + do! setCommitIndex newIndex } // ** processEntry @@ -1367,225 +145,211 @@ module rec Raft = raft { do! handleConflicts msg let! response = applyRemainder msg resp - do! maybeSetCommitIdx msg - do! setLeaderM nid - return { response with Success = true } + do! requestSetCommitIndex msg + do! setLeader nid + return AppendResponse.setSuccess true response } // ** checkAndProcess /// 2. Reply false if log doesn't contain an entry at prevLogIndex whose /// term matches prevLogTerm (§5.3) + let private checkAndProcess entry nid msg resp = raft { - let! current = currentIndexM () + let! current = currentIndex () if current < msg.PrevLogIdx then - do! msg.PrevLogIdx - |> sprintf "Failed (ci: %d) < (prev log idx: %d)" current - |> error "receiveAppendEntries" + do! logMap Err "receiveAppendEntries" "current index < previous log index" [ + "previous log term", string msg.PrevLogTerm + "current index", string current + "prevous log index", string msg.PrevLogIdx + ] return resp else - let term = LogEntry.getTerm entry + let term = LogEntry.term entry if term <> msg.PrevLogTerm then - do! sprintf "Failed (term %d) != (prev log term %d) (ci: %d) (prev log idx: %d)" - term - msg.PrevLogTerm - current - msg.PrevLogIdx - |> error "receiveAppendEntries" - let response = { resp with CurrentIndex = msg.PrevLogIdx - index 1 } - do! removeEntryM msg.PrevLogIdx - return response + do! logMap Err "receiveAppendEntries" "term mismatch" [ + "term", string term + "previous log term", string msg.PrevLogTerm + "current index", string current + "prevous log index", string msg.PrevLogIdx + ] + do! removeEntry msg.PrevLogIdx + return AppendResponse.setCurrentIndex (msg.PrevLogIdx - 1) resp else return! processEntry nid msg resp } // ** updateMemberIndices - ///////////////////////////////////////////////////////////////////////////// - // _ _ _____ _ _ // - // / \ _ __ _ __ ___ _ __ __| | ____|_ __ | |_ _ __(_) ___ ___ // - // / _ \ | '_ \| '_ \ / _ \ '_ \ / _` | _| | '_ \| __| '__| |/ _ \/ __| // - // / ___ \| |_) | |_) | __/ | | | (_| | |___| | | | |_| | | | __/\__ \ // - // /_/ \_\ .__/| .__/ \___|_| |_|\__,_|_____|_| |_|\__|_| |_|\___||___/ // - // |_| |_| // - ///////////////////////////////////////////////////////////////////////////// - let private updateMemberIndices (resp : AppendResponse) (mem : RaftMember) = raft { let peer = - { mem with - NextIndex = resp.CurrentIndex + index 1 - MatchIndex = resp.CurrentIndex } + mem + |> Member.setNextIndex (resp.CurrentIndex + 1) + |> Member.setMatchIndex resp.CurrentIndex - let! current = currentIndexM () + let! current = currentIndex () let notVoting = not (Member.isVoting peer) let notLogs = not (Member.hasSufficientLogs peer) - let idxOk = current <= resp.CurrentIndex + index 1 + let idxOk = current <= resp.CurrentIndex + 1 if notVoting && idxOk && notLogs then let updated = Member.setHasSufficientLogs peer - do! updateMemberM updated + do! updateMember updated else - do! updateMemberM peer + do! updateMember peer } // ** shouldCommit let private shouldCommit peers state resp = - let folder (votes : int) nid (mem : RaftMember) = - if nid = state.Member.Id || not (Member.isVoting mem) then - votes + let folder (votes: int) nid (mem: RaftMember) = + if nid = state.MemberId || not (Member.isVoting mem) + then votes elif mem.MatchIndex > 0 then - match getEntryAt mem.MatchIndex state with - | Some entry -> - if LogEntry.getTerm entry = state.CurrentTerm && resp.CurrentIndex <= mem.MatchIndex - then votes + 1 - else votes - | _ -> votes + match RaftState.entryAt mem.MatchIndex state with + | Some entry -> + if LogEntry.term entry = state.CurrentTerm && resp.CurrentIndex <= mem.MatchIndex + then votes + 1 + else votes + | _ -> votes else votes - let commit = commitIndex state - let num = countMembers peers + let commit = RaftState.commitIndex state + let num = RaftState.countMembers peers let votes = Map.fold folder 1 peers (num / 2) < votes && commit < resp.CurrentIndex - // ** updateCommitIndex + // ** responseSetCommitIndex - let private updateCommitIndex (resp : AppendResponse) = + let private responseSetCommitIndex (resp: AppendResponse) = raft { let! state = get - + let! inConsensus = inJointConsensus () let commitOk = - if inJointConsensus state then + if inConsensus then // handle the joint consensus case match state.OldPeers with - | Some peers -> - let older = shouldCommit peers state resp - let newer = shouldCommit state.Peers state resp - older || newer - | _ -> - shouldCommit state.Peers state resp + | Some peers -> + let older = shouldCommit peers state resp + let newer = shouldCommit state.Peers state resp + older || newer + | _ -> shouldCommit state.Peers state resp else // the base case, not in joint consensus shouldCommit state.Peers state resp - if commitOk then - do! setCommitIndexM resp.CurrentIndex + do! setCommitIndex resp.CurrentIndex } // ** receiveAppendEntries let receiveAppendEntries (nid: MemberId option) (msg: AppendEntries) = raft { - do! setTimeoutElapsedM 0 // reset timer, so we don't start an election + do! setTimeoutElapsed 0 // reset timer, so we don't start an election // log this if any entries are to be processed if Option.isSome msg.Entries then - let! current = currentIndexM () - let str = - sprintf "from: %A term: %d (ci: %d) (lc-idx: %d) (pli: %d) (plt: %d) (entries: %d)" - nid - msg.Term - current - msg.LeaderCommit - msg.PrevLogIdx - msg.PrevLogTerm - (Option.get msg.Entries |> LogEntry.depth) // let the world know - do! debug "receiveAppendEntries" str - - let! result = makeResponse nid msg // check terms et al match, fail otherwise + let! current = currentIndex () + do! logMap Debug "receiveAppendEntries" ("from: " + string nid) [ + "term", string msg.Term + "current index", string current + "leader commit", string msg.LeaderCommit + "previous log term", string msg.PrevLogTerm + "prevous log index", string msg.PrevLogIdx + "num entries", string (Option.map LogEntry.depth msg.Entries) + ] + let! result = createAppendResponse nid msg // check terms et al match, fail otherwise match result with - | Right resp -> + | Ok resp -> // this is not the first AppendEntry we're receiving - if msg.PrevLogIdx > index 0 then - let! entry = getEntryAtM msg.PrevLogIdx + if msg.PrevLogIdx > 0 then + let! entry = entryAt msg.PrevLogIdx match entry with | Some log -> return! checkAndProcess log nid msg resp | _ -> do! msg.PrevLogIdx |> String.format "Failed. No log at (prev-log-idx: {0})" - |> error "receiveAppendEntries" + |> logError "receiveAppendEntries" return resp else return! processEntry nid msg resp - | Left err -> return err + | Error err -> return err } // ** receiveAppendEntriesResponse let rec receiveAppendEntriesResponse (nid : MemberId) resp = raft { - let! mem = getMemberM nid + let! mem = getMember nid match mem with | None -> - do! string nid - |> sprintf "Failed: NoMember %s" - |> error "receiveAppendEntriesResponse" - + do! logError + "receiveAppendEntriesResponse" + ("Failed: NoMember " + string nid) return! string nid |> sprintf "Node not found: %s" |> Error.asRaftError (tag "receiveAppendEntriesResponse") |> failM | Some peer -> - if resp.CurrentIndex <> index 0 && resp.CurrentIndex < peer.MatchIndex then - let str = sprintf "Failed: peer not up to date yet (ci: %d) (match idx: %d)" - resp.CurrentIndex - peer.MatchIndex - do! error "receiveAppendEntriesResponse" str + if resp.CurrentIndex <> 0 && resp.CurrentIndex < peer.MatchIndex then + do! sprintf "Failed: peer not up to date yet (ci: %d) (match idx: %d)" + resp.CurrentIndex + peer.MatchIndex + |> logError "receiveAppendEntriesResponse" // set to current index at follower and try again - do! updateMemberM { peer with - NextIndex = resp.CurrentIndex + 1 - MatchIndex = resp.CurrentIndex } - return () + do! peer + |> Member.setNextIndex (resp.CurrentIndex + 1) + |> Member.setMatchIndex resp.CurrentIndex + |> updateMember else - let! state = get - + let! leader = isLeader () // we only process this if we are indeed the leader of the pack - if isLeader state then - let term = currentTerm state + if leader then + let! term = currentTerm () // If response contains term T > currentTerm: set currentTerm = T // and convert to follower (§5.3) if term < resp.Term then let str = sprintf "Failed: (term: %d) < (resp.Term: %d)" term resp.Term - do! error "receiveAppendEntriesResponse" str - do! setTermM resp.Term - do! setLeaderM (Some nid) + do! logError "receiveAppendEntriesResponse" str + do! setCurrentTerm resp.Term + do! setLeader (Some nid) do! becomeFollower () elif term <> resp.Term then let str = sprintf "Failed: (term: %d) != (resp.Term: %d)" term resp.Term - do! error "receiveAppendEntriesResponse" str + do! logError "receiveAppendEntriesResponse" str elif not resp.Success then // If AppendEntries fails because of log inconsistency: // decrement nextIndex and retry (§5.3) if resp.CurrentIndex < peer.NextIndex - 1 then - let! idx = currentIndexM () + let! idx = currentIndex () let nextIndex = min (resp.CurrentIndex + 1) idx do! nextIndex |> sprintf "Failed: cidx < nxtidx. setting nextIndex for %O to %d" peer.Id - |> error "receiveAppendEntriesResponse" + |> logError "receiveAppendEntriesResponse" - do! setNextIndexM peer.Id nextIndex - do! setMatchIndexM peer.Id (nextIndex - 1) + do! setNextIndex peer.Id nextIndex + do! setMatchIndex peer.Id (nextIndex - 1) else - let nextIndex = peer.NextIndex - index 1 + let nextIndex = peer.NextIndex - 1 do! nextIndex |> sprintf "Failed: cidx >= nxtidx. setting nextIndex for %O to %d" peer.Id - |> error "receiveAppendEntriesResponse" + |> logError "receiveAppendEntriesResponse" - do! setNextIndexM peer.Id nextIndex - do! setMatchIndexM peer.Id (nextIndex - index 1) + do! setNextIndex peer.Id nextIndex + do! setMatchIndex peer.Id (nextIndex - 1) else do! updateMemberIndices resp peer - do! updateCommitIndex resp + do! responseSetCommitIndex resp else return! "Not Leader" @@ -1598,145 +362,123 @@ module rec Raft = let sendAppendEntry (peer: RaftMember) = raft { let! state = get - let entries = getEntriesUntil peer.NextIndex state - let request = { Term = state.CurrentTerm - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 0 - ; LeaderCommit = state.CommitIndex - ; Entries = entries } - - if peer.NextIndex > index 1 then - let! result = getEntryAtM (peer.NextIndex - 1) - let request = { request with - PrevLogIdx = peer.NextIndex - 1 - PrevLogTerm = - match result with - | Some(entry) -> LogEntry.getTerm entry - | _ -> request.Term } - do! sendAppendEntriesM peer request + let! entries = entriesUntil peer.NextIndex + + let request: AppendEntries = + { Term = state.CurrentTerm + PrevLogIdx = 0 + PrevLogTerm = 0 + LeaderCommit = state.CommitIndex + Entries = entries } + + if peer.NextIndex > 1 then + let! result = entryAt (peer.NextIndex - 1) + let request = + { request with + PrevLogIdx = peer.NextIndex - 1 + PrevLogTerm = + match result with + | Some(entry) -> LogEntry.term entry + | _ -> request.Term } + do! sendAppendEntries peer request else - do! sendAppendEntriesM peer request + do! sendAppendEntries peer request } // ** sendRemainingEntries let private sendRemainingEntries peerid = raft { - let! peer = getMemberM peerid + let! peer = getMember peerid match peer with | Some mem -> - let! entry = getEntryAtM (Member.nextIndex mem) + let! entry = entryAt (Member.nextIndex mem) if Option.isSome entry then do! sendAppendEntry mem | _ -> return () } - // ** sendAllAppendEntriesM + // ** sendAllAppendEntries - let sendAllAppendEntriesM () = + let sendAllAppendEntries () = raft { - let! self = getSelfM () - let! peers = logicalPeersM () - + let! self = self () + let! peers = logicalPeers () for KeyValue(id,peer) in peers do if id <> self.Id then do! sendAppendEntry peer - - do! setTimeoutElapsedM 0 + do! setTimeoutElapsed 0 } // ** createSnapshot - /////////////////////////////////////////////////// - // ____ _ _ // - // / ___| _ __ __ _ _ __ ___| |__ ___ | |_ // - // \___ \| '_ \ / _` | '_ \/ __| '_ \ / _ \| __| // - // ___) | | | | (_| | |_) \__ \ | | | (_) | |_ // - // |____/|_| |_|\__,_| .__/|___/_| |_|\___/ \__| // - // |_| // - /////////////////////////////////////////////////// - /// utiltity to create a snapshot for the current application and raft state + let createSnapshot (state: RaftState) (data: StateMachine) = let peers = Map.toArray state.Peers |> Array.map snd Log.snapshot peers data state.Log // ** sendInstallSnapshot - let sendInstallSnapshot mem = + let sendInstallSnapshot mem snapshot = raft { - let! state = get - let! cbs = read - - match cbs.RetrieveSnapshot () with + let! env = read + let! term = currentTerm() + let! leader = self () >>= (Member.id >> returnM) + match snapshot with | Some (Snapshot(_,idx,term,_,_,_,_) as snapshot) -> - let is = - { Term = state.CurrentTerm - ; LeaderId = state.Member.Id - ; LastIndex = idx - ; LastTerm = term - ; Data = snapshot - } - cbs.SendInstallSnapshot mem is - | _ -> () + env.SendInstallSnapshot mem { + Term = term + LeaderId = leader + LastIndex = idx + LastTerm = term + Data = snapshot + } + | other -> + "Snapshot malformatted: " + string other + |> Logger.err (tag "sendInstallSnapshot") } // ** responseCommitted - /////////////////////////////////////////////////////////////////// - // ____ _ _____ _ // - // | _ \ ___ ___ ___(_)_ _____ | ____|_ __ | |_ _ __ _ _ // - // | |_) / _ \/ __/ _ \ \ \ / / _ \ | _| | '_ \| __| '__| | | | // - // | _ < __/ (_| __/ |\ V / __/ | |___| | | | |_| | | |_| | // - // |_| \_\___|\___\___|_| \_/ \___| |_____|_| |_|\__|_| \__, | // - // |___/ // - /////////////////////////////////////////////////////////////////// - /// Check if an entry corresponding to a receiveEntry result has actually been /// committed to the state machine. + let responseCommitted (resp : EntryResponse) = raft { - let! entry = getEntryAtM resp.Index + let! entry = entryAt resp.Index match entry with - | None -> return false - | Some entry -> - if resp.Term <> LogEntry.getTerm entry then - return! - "Entry Invalidated" - |> Error.asRaftError (tag "responseCommitted") - |> failM - else - let! cidx = commitIndexM () - return resp.Index <= cidx + | None -> return false + | Some entry -> + if resp.Term <> LogEntry.term entry + then + return! + "Entry Invalidated" + |> Error.asRaftError (tag "responseCommitted") + |> failM + else + let! cidx = commitIndex () + return resp.Index <= cidx } - // ** updateCommitIdx - - let private updateCommitIdx (state: RaftState) = - let idx = - if state.NumMembers = 1 then - currentIndex state - else - state.CommitIndex - { state with CommitIndex = idx } - // ** handleLog let private handleLog entry resp = raft { - let! result = appendEntryM entry + let! result = appendEntry entry match result with | Some appended -> - let! state = get - let! peers = logicalPeersM () + let! selfId = self () >>= (Member.id >> returnM) + let! maxDepth = maxLogDepth () + let! peers = logicalPeers () // iterate through all peers and call sendAppendEntries to each for peer in peers do let mem = peer.Value - if mem.Id <> state.Member.Id then + if mem.Id <> selfId then let nxtidx = Member.nextIndex mem - let! cidx = currentIndexM () + let! cidx = currentIndex () // calculate whether we need to send a snapshot or not // uint's wrap around, so normalize to int first (might cause trouble with big numbers) @@ -1744,22 +486,23 @@ module rec Raft = let d = cidx - nxtidx if d < 0 then 0 else d - if difference <= (index (int state.MaxLogDepth) + 1) then + if difference <= (1 * (int maxDepth) + 1) then // Only send new entries. Don't send the entry to peers who are // behind, to prevent them from becoming congested. do! sendAppendEntry mem else // because this mem is way behind in the cluster, get it up to speed // with a snapshot - do! sendInstallSnapshot mem - - do! updateCommitIdx |> modify - - return! currentTermM () >>= fun term -> - returnM { resp with - Id = LogEntry.getId appended - Term = term - Index = LogEntry.getIndex appended } + let! snapshot = generateSnapshot () + do! sendInstallSnapshot mem snapshot + + do! updateCommitIndex () + let! term = currentTerm () + return + { resp with + Id = LogEntry.id appended + Term = term + Index = LogEntry.index appended } | _ -> return! "Append Entry failed" @@ -1769,45 +512,41 @@ module rec Raft = // ** receiveEntry - /// _ _____ _ - /// _ __ ___ ___ ___(_)_ _____| ____|_ __ | |_ _ __ _ _ - /// | '__/ _ \/ __/ _ \ \ \ / / _ \ _| | '_ \| __| '__| | | | - /// | | | __/ (_| __/ |\ V / __/ |___| | | | |_| | | |_| | - /// |_| \___|\___\___|_| \_/ \___|_____|_| |_|\__|_| \__, | - /// |___/ - - let receiveEntry (entry : RaftLogEntry) = + let receiveEntry (entry: LogEntry) = raft { - let! state = get - let resp = { Id = DiscoId.Create(); Term = term 0; Index = index 0 } + let! leader = isLeader () + let! configChange = configChangeEntry() - if LogEntry.isConfigChange entry && Option.isSome state.ConfigChangeEntry then - do! debug "receiveEntry" "Error: UnexpectedVotingChange" + if LogEntry.isConfigChange entry && Option.isSome configChange then + do! logDebug "receiveEntry" "Error: UnexpectedVotingChange" return! "Unexpected Voting Change" |> Error.asRaftError (tag "receiveEntry") |> failM - elif isLeader state then - do! state.CurrentTerm - |> sprintf "(id: %A) (idx: %d) (term: %d)" - (LogEntry.getId entry) - (Log.getIndex state.Log + 1) - |> debug "receiveEntry" + elif leader then + let! term = currentTerm() + let! idx = log () >>= (Log.index >> returnM) - let! term = currentTermM () + do! logMap Debug "receiveEntry" "" [ + "id", string (LogEntry.id entry) + "index", string (idx + 1) + "term", string term + ] + + let response = EntryResponse.create 0 0 match entry with | LogEntry(id,_,_,data,_) -> - let log = LogEntry(id, index 0, term, data, None) - return! handleLog log resp + let log = LogEntry(id, 0, term, data, None) + return! handleLog log response | Configuration(id,_,_,mems,_) -> - let log = Configuration(id, index 0, term, mems, None) - return! handleLog log resp + let log = Configuration(id, 0, term, mems, None) + return! handleLog log response | JointConsensus(id,_,_,changes,_) -> - let log = JointConsensus(id, index 0, term, changes, None) - return! handleLog log resp + let log = JointConsensus(id, 0, term, changes, None) + return! handleLog log response | _ -> return! @@ -1821,63 +560,61 @@ module rec Raft = |> failM } - // ** calculateChanges - - //////////////////////////////////////////////////////////////// - // _ _ _____ _ // - // / \ _ __ _ __ | |_ _ | ____|_ __ | |_ _ __ _ _ // - // / _ \ | '_ \| '_ \| | | | | | _| | '_ \| __| '__| | | | // - // / ___ \| |_) | |_) | | |_| | | |___| | | | |_| | | |_| | // - // /_/ \_\ .__/| .__/|_|\__, | |_____|_| |_|\__|_| \__, | // - // |_| |_| |___/ |___/ // - //////////////////////////////////////////////////////////////// - let calculateChanges (oldPeers: Map) (newPeers: Map) = - let oldmems = Map.toArray oldPeers |> Array.map snd - let newmems = Map.toArray newPeers |> Array.map snd - - let additions = - Array.fold - (fun lst (newmem: RaftMember) -> - match Array.tryFind (Member.id >> (=) newmem.Id) oldmems with - | Some _ -> lst - | _ -> MemberAdded(newmem) :: lst) [] newmems - - Array.fold - (fun lst (oldmem: RaftMember) -> - match Array.tryFind (Member.id >> (=) oldmem.Id) newmems with - | Some _ -> lst - | _ -> MemberRemoved(oldmem) :: lst) additions oldmems - |> List.toArray - - // ** notifyChange - - let notifyChange (cbs: IRaftCallbacks) change = - match change with - | MemberAdded(mem) -> cbs.MemberAdded mem - | MemberRemoved(mem) -> cbs.MemberRemoved mem - // ** applyEntry let applyEntry (cbs: IRaftCallbacks) = function | JointConsensus(_,_,_,changes,_) -> Array.iter (notifyChange cbs) changes cbs.JointConsensus changes - | Configuration(_,_,_,mems,_) -> cbs.Configured mems + | Configuration(_,_,_,mems,_) -> + cbs.Configured mems | LogEntry(_,_,_,data,_) -> cbs.ApplyLog data | Snapshot(_,_,_,_,_,_,data) as snapshot -> cbs.PersistSnapshot snapshot cbs.ApplyLog data + // ** applyLogs + + let applyLogs entries = + raft { + let! env = read + let! state = get + // Apply log chain in the order it arrived + let state, change = + LogEntry.foldr + (fun (state, current) -> function + | Configuration(_,_,_,mems,_) as config -> + // set the peers map + let newstate = RaftState.handleConfiguration mems state + // when a new configuration is added, under certain circumstances a mem change + // might not have been applied yet, so calculate those dangling changes + let changes = RaftState.calculateChanges state.Peers newstate.Peers + // apply the entry by calling the callback + do applyEntry env config + (newstate, None) + | JointConsensus(_,_,_,changes,_) as config -> + let state = RaftState.handleJointConsensus changes state + do applyEntry env config + (state, Some (LogEntry.head config)) + | entry -> + do applyEntry env entry + (state, current)) + (state, state.ConfigChangeEntry) + entries + do! put state + do! setConfigChangeEntry change + } + // ** applyEntries let applyEntries () = raft { let! state = get - let lai = state.LastAppliedIdx - let coi = state.CommitIndex + let! lai = lastAppliedIndex() + let! coi = commitIndex () if lai <> coi then let logIdx = lai + 1 - let! result = getEntriesUntilM logIdx + let! result = entriesUntil logIdx match result with | Some entries -> let! cbs = read @@ -1886,122 +623,87 @@ module rec Raft = LogEntry.depth entries |> sprintf "applying %d entries to state machine" - do! info "applyEntries" str + do! logInfo "applyEntries" str // Apply log chain in the order it arrived - let state, change = - LogEntry.foldr - (fun (state, current) lg -> - match lg with - | Configuration _ as config -> - // set the peers map - let newstate = handleConfigChange config state - // when a new configuration is added, under certain circumstances a mem change - // might not have been applied yet, so calculate those dangling changes - let changes = calculateChanges state.Peers newstate.Peers - // apply dangling changes - Array.iter (notifyChange cbs) changes - // apply the entry by calling the callback - applyEntry cbs config - (newstate, None) - | JointConsensus _ as config -> - let state = handleConfigChange config state - applyEntry cbs config - (state, Some (LogEntry.head config)) - | entry -> - applyEntry cbs entry - (state, current)) - (state, state.ConfigChangeEntry) - entries - - do! match change with - | Some _ -> "setting ConfigChangeEntry to JointConsensus" - | None -> "resetting ConfigChangeEntry" - |> debug "applyEntries" - - do! put { state with ConfigChangeEntry = change } + do! applyLogs entries + + /// The cluster was just re-configured, and if any of (possibly) just removed members were + /// to be added again, the replay log they would receive when joining would cause them to + /// be automatically being removed again. This is why, after the configuration changes are + /// done we need to create a snapshot of the raft log, which won't contain those commands. if LogEntry.contains LogEntry.isConfiguration entries then - let selfIncluded (state: RaftState) = - Map.containsKey state.Member.Id state.Peers - let! included = selfIncluded |> zoomM + /// If self was removed from the cluster, reset node to Follower state. + let! included = selfIncluded () if not included then - let str = - string state.Member.Id - |> sprintf "self (%s) not included in new configuration" - do! debug "applyEntries" str - do! setLeaderM None + do! logDebug "applyEntries" $ + String.format + "self ({0}) not included in new configuration" + state.Member.Id + do! setLeader None do! becomeFollower () - /// snapshot now: - /// - /// the cluster was just re-configured, and if any of (possibly) just removed members were - /// to be added again, the replay log they would receive when joining would cause them to - /// be automatically being removed again. this is why, after the configuration changes are - /// done we need to create a snapshot of the raft log, which won't contain those commands. - do! doSnapshot() - - let! state = get - if not (isLeader state) && LogEntry.contains LogEntry.isConfiguration entries then - do! debug "applyEntries" "not leader and new configuration is applied. Updating mems." - for kv in state.Peers do - if kv.Value.Status <> Running then - do! updateMemberM { kv.Value with Status = Running; Voting = true } - - let idx = LogEntry.getIndex entries - do! debug "applyEntries" <| sprintf "setting LastAppliedIndex to %d" idx - do! setLastAppliedIdxM idx - | _ -> - do! debug "applyEntries" (sprintf "no log entries found for index %d" logIdx) + + let! self = self() + let! currentlyLeader = isLeader() + + /// Install the snapshot on all followers to ensure consistency. + if currentlyLeader then + let! snapshot = generateSnapshot() + /// Do Snapshot Now! + let! peers = peers() + for KeyValue(peerId,peer) in peers do + if peerId <> self.Id then + do! sendInstallSnapshot peer snapshot + + let! peers = peers() + if not (RaftState.isLeader state) && LogEntry.contains LogEntry.isConfiguration entries + then + for KeyValue(_, peer) in peers do + if peer.Status <> Running then + do! updateMember { peer with Status = Running; Voting = true } + + let idx = LogEntry.index entries + do! logDebug "applyEntries" <| sprintf "setting LastAppliedIndex to %d" idx + do! setLastAppliedIndex idx + | None -> + do! logDebug "applyEntries" (sprintf "no log entries found for index %d" logIdx) } // ** receiveInstallSnapshot (* - * ____ _ - * | _ \ ___ ___ ___(_)_ _____ - * | |_) / _ \/ __/ _ \ \ \ / / _ \ - * | _ < __/ (_| __/ |\ V / __/ - * |_| \_\___|\___\___|_| \_/ \___| - * - * ___ _ _ _ ____ _ _ - * |_ _|_ __ ___| |_ __ _| | / ___| _ __ __ _ _ __ ___| |__ ___ | |_ - * | || '_ \/ __| __/ _` | | \___ \| '_ \ / _` | '_ \/ __| '_ \ / _ \| __| - * | || | | \__ \ || (_| | | |___) | | | | (_| | |_) \__ \ | | | (_) | |_ - * |___|_| |_|___/\__\__,_|_|_|____/|_| |_|\__,_| .__/|___/_| |_|\___/ \__| - * |_| - * +-------------------------------------------------------------------------------------------------------------------------------+ - * | 1. Reply immediately if term < currentTerm | - * | 2. Create new snapshot file if first chunk (offset is 0) | - * | 3. Write data into snapshot file at given offset | - * | 4. Reply and wait for more data chunks if done is false | - * | 5. Save snapshot file, discard any existing or partial snapshot with a smaller index | - * | 6. If existing log entry has same index and term as snapshot’s last included entry, retain log entries following it and reply | - * | 7. Discard the entire log | - * | 8. Reset state machine using snapshot contents (and load snapshot’s cluster configuration) | - * +-------------------------------------------------------------------------------------------------------------------------------+ + * 1. Reply immediately if term < currentTerm + * 2. Create new snapshot file if first chunk (offset is 0) + * 3. Write data into snapshot file at given offset + * 4. Reply and wait for more data chunks if done is false + * 5. Save snapshot file, discard any existing or partial snapshot with a smaller index + * 6. If existing log entry has same index and term as snapshot’s last included entry, retain log entries following it and reply + * 7. Discard the entire log + * 8. Reset state machine using snapshot contents (and load snapshot’s cluster configuration) *) let receiveInstallSnapshot (is: InstallSnapshot) = raft { let! cbs = read - let! currentTerm = currentTermM () + let! term = currentTerm () - if is.Term < currentTerm then + if is.Term < term then return! "Invalid Term" |> Error.asRaftError (tag "receiveInstallSnapshot") |> failM - do! setTimeoutElapsedM 0 + do! setTimeoutElapsed 0 match is.Data with - | Snapshot(_,idx,_,_,_,mems, _) as snapshot -> + | Snapshot(_,idx,_,_,_,mems, DataSnapshot data) as snapshot -> // IMPROVEMENT: implementent chunked transmission as per paper - cbs.PersistSnapshot snapshot + do cbs.PersistSnapshot snapshot let! state = get - let! remaining = entriesUntilExcludingM idx + let! remaining = entriesUntilExcluding idx // update the cluster configuration let peers = @@ -2009,46 +711,41 @@ module rec Raft = |> Map.ofArray |> Map.add state.Member.Id state.Member - do! setPeersM peers + do! setPeers peers // update log with snapshot and possibly merge existing entries match remaining with - | Some entries -> - do! updateLog (Log.empty - |> Log.append is.Data - |> Log.append entries) - |> modify - | _ -> - do! updateLogEntries is.Data |> modify + | Some entries -> + do! Log.empty + |> Log.append is.Data + |> Log.append entries + |> setLog + | _ -> + do! updateLogEntries is.Data |> modify // set the current leader to mem which sent snapshot - do! setLeaderM (Some is.LeaderId) + do! setLeader (Some is.LeaderId) // apply all entries in the new log - let! state = get - match state.Log.Data with - | Some data -> - LogEntry.foldr (fun _ entry -> applyEntry cbs entry) () data - | _ -> failwith "Fatal. Snapshot applied, but log is empty. Aborting." + let! log = log() + + do Option.iter (LogEntry.foldr (fun _ entry -> applyEntry cbs entry) ()) log.Data // reset the counters,to apply all entries in the log - do! setLastAppliedIdxM (Log.getIndex state.Log) - do! setCommitIndexM (Log.getIndex state.Log) - - // cosntruct reply - let! term = currentTermM () - let! ci = currentIndexM () - let! fi = firstIndexM term - - let ar : AppendResponse = - { Term = term - ; Success = true - ; CurrentIndex = ci - ; FirstIndex = match fi with - | Some i -> i - | _ -> index 0 } - - return ar + do! setLastAppliedIndex (Log.index log) + do! setCommitIndex (Log.index log) + + // construct reply + let! term = currentTerm () + let! ci = currentIndex () + let! fi = firstIndex term >>= (Option.defaultValue 0 >> returnM) + + return { + Term = term + Success = true + CurrentIndex = ci + FirstIndex = fi + } | _ -> return! "Snapshot Format Error" @@ -2056,19 +753,25 @@ module rec Raft = |> failM } - // ** doSnapshot + // ** generateSnapshot - let doSnapshot () = + let generateSnapshot () = raft { let! cbs = read let! state = get match cbs.PrepareSnapshot state with | Some snapshot -> - do! updateLog snapshot |> modify + do! setLog snapshot match snapshot.Data with - | Some snapshot -> cbs.PersistSnapshot snapshot - | _ -> () - | _ -> () + | Some snapshot -> + do cbs.PersistSnapshot snapshot + return (Some snapshot) + | None -> + do! logError "generateSnapshot" "generated snapshot has not data" + return None + | None -> + do! logError "generateSnapshot" "no snapshot was generated" + return None } // ** maybeSnapshot @@ -2077,126 +780,39 @@ module rec Raft = raft { let! state = get if Log.length state.Log >= int state.MaxLogDepth then - do! doSnapshot () + do! generateSnapshot () >>= ignoreM } - // ** majority - - /////////////////////////////////////////////// - // _____ _ _ _ // - // | ____| | ___ ___| |_(_) ___ _ __ ___ // - // | _| | |/ _ \/ __| __| |/ _ \| '_ \/ __| // - // | |___| | __/ (__| |_| | (_) | | | \__ \ // - // |_____|_|\___|\___|\__|_|\___/|_| |_|___/ // - /////////////////////////////////////////////// - - /// ## majority - /// - /// Determine the majority from a total number of eligible voters and their respective votes. This - /// function is generic and should expect any numeric types. - /// - /// Turning off the warning about the cast due to sufficiently constrained requirements on the - /// input type (op_Explicit, comparison and division). - /// - /// ### Signature: - /// - total: the total number of votes cast - /// - yays: the number of yays in this election - /// - /// Returns: boolean - let majority total yays = - if total = 0 || yays = 0 then - false - elif yays > total then - false - else - yays > (total / 2) - - // ** regularMajorityM - - /// Determine whether a vote count constitutes a majority in the *regular* - /// configuration (does not cover the joint consensus state). - let regularMajorityM votes = - votingMembersM () >>= fun num -> - majority num votes |> returnM - - // ** oldConfigMajorityM - - let oldConfigMajorityM votes = - votingMembersForOldConfigM () >>= fun num -> - majority num votes |> returnM - - // ** numVotesForConfig - - let numVotesForConfig (self: RaftMember) (votedFor: MemberId option) peers = - let counter m _ (peer : RaftMember) = - if (peer.Id <> self.Id) && Member.canVote peer - then m + 1 - else m - - let start = - match votedFor with - | Some(nid) -> if nid = self.Id then 1 else 0 - | _ -> 0 - - Map.fold counter start peers - - // ** numVotesForMe - - let numVotesForMe (state: RaftState) = - numVotesForConfig state.Member state.VotedFor state.Peers - - // ** numVotesForMeM - - let numVotesForMeM _ = zoomM numVotesForMe - - // ** numVotesForMeOldConfig - - let numVotesForMeOldConfig (state: RaftState) = - match state.OldPeers with - | Some peers -> numVotesForConfig state.Member state.VotedFor peers - | _ -> 0 - - // ** numVotesForMeOldConfigM - - let numVotesForMeOldConfigM _ = zoomM numVotesForMeOldConfig - // ** maybeSetIndex - ///////////////////////////////////////////////////////////////////////////// - // ____ _ _ // - // | __ ) ___ ___ ___ _ __ ___ ___ | | ___ __ _ __| | ___ _ __ // - // | _ \ / _ \/ __/ _ \| '_ ` _ \ / _ \ | | / _ \/ _` |/ _` |/ _ \ '__| // - // | |_) | __/ (_| (_) | | | | | | __/ | |__| __/ (_| | (_| | __/ | // - // |____/ \___|\___\___/|_| |_| |_|\___| |_____\___|\__,_|\__,_|\___|_| // - ///////////////////////////////////////////////////////////////////////////// - let private maybeSetIndex nid nextIdx matchIdx = - let mapper peer = - if Member.isVoting peer && peer.Id <> nid - then { peer with NextIndex = nextIdx; MatchIndex = matchIdx } + updateMembers $ fun peer -> + if Member.isVoting peer && peer.Id <> nid then + peer + |> Member.setNextIndex nextIdx + |> Member.setMatchIndex matchIdx else peer - updatePeersM mapper // ** becomeLeader /// Become leader afer a successful election let becomeLeader _ = raft { - let! state = get - do! info "becomeLeader" "becoming leader" - let nextidx = currentIndex state + 1 - do! setStateM Leader - do! setLeaderM (Some state.Member.Id) - do! maybeSetIndex state.Member.Id nextidx (index 0) - do! sendAllAppendEntriesM () + let! self = self() + do! logInfo "becomeLeader" "becoming leader" + let! current = currentIndex () + do! setState Leader + do! setLeader (Some self.Id) + do! maybeSetIndex self.Id (current + 1) 0 + do! sendAllAppendEntries () } // ** becomeFollower let becomeFollower _ = raft { - do! info "becomeFollower" "becoming follower" - do! setStateM Follower + do! logInfo "becomeFollower" "becoming follower" + do! setState Follower } // ** becomeCandidate @@ -2215,19 +831,19 @@ module rec Raft = /// After timeout a Member must become Candidate let becomeCandidate () = raft { - do! info "becomeCandidate" "becoming candidate" + do! logInfo "becomeCandidate" "becoming candidate" let! state = get let term = state.CurrentTerm + 1 - do! debug "becomeCandidate" <| sprintf "setting term to %d" term - do! setTermM term - do! resetVotesM () + do! logDebug "becomeCandidate" <| sprintf "setting term to %d" term + do! setCurrentTerm term + do! resetVotes () do! voteForMyself () - do! setLeaderM None - do! setStateM Candidate + do! setLeader None + do! setState Candidate // 150–300ms see page 6 in https://raft.github.io/raft.pdf let elapsed = 1 * rand.Next(10, int state.ElectionTimeout) - do! debug "becomeCandidate" <| sprintf "setting timeoutElapsed to %d" elapsed - do! setTimeoutElapsedM elapsed + do! logDebug "becomeCandidate" <| sprintf "setting timeoutElapsed to %d" elapsed + do! setTimeoutElapsed elapsed do! requestAllVotes () } @@ -2244,105 +860,101 @@ module rec Raft = let receiveVoteResponse (nid : MemberId) (vote : VoteResponse) = raft { - let! state = get + let! state = get + + do! (if vote.Granted then "granted" else "not granted") + |> sprintf "%O responded to vote request with: %s" nid + |> logDebug "receiveVoteResponse" + + /// The term must not be bigger than current raft term, + /// otherwise set term to vote term become follower. + if vote.Term > state.CurrentTerm then + do! sprintf "(vote term: %d) > (current term: %d). Setting to %d." + vote.Term + state.CurrentTerm + state.CurrentTerm + |> logDebug "receiveVoteResponse" + do! setCurrentTerm vote.Term + do! setLeader (Some nid) + do! becomeFollower () + + /// If the vote term is smaller than current term it is considered an + /// error and the client will be notified. + elif vote.Term < state.CurrentTerm then + do! sprintf "Failed: (vote term: %d) < (current term: %d). VoteTermMismatch." + vote.Term + state.CurrentTerm + |> logDebug "receiveVoteResponse" + return! + "Vote Term Mismatch" + |> Error.asRaftError (tag "receiveVoteResponse") + |> failM - do! (if vote.Granted then "granted" else "not granted") - |> sprintf "%O responded to vote request with: %s" nid - |> debug "receiveVoteResponse" - - /// The term must not be bigger than current raft term, - /// otherwise set term to vote term become follower. - if vote.Term > state.CurrentTerm then - do! sprintf "(vote term: %d) > (current term: %d). Setting to %d." - vote.Term - state.CurrentTerm - state.CurrentTerm - |> debug "receiveVoteResponse" - do! setTermM vote.Term - do! setLeaderM (Some nid) - do! becomeFollower () - - /// If the vote term is smaller than current term it is considered an - /// error and the client will be notified. - elif vote.Term < state.CurrentTerm then - do! sprintf "Failed: (vote term: %d) < (current term: %d). VoteTermMismatch." - vote.Term - state.CurrentTerm - |> debug "receiveVoteResponse" + /// Process the vote if current state of our Raft must be candidate.. + else + match state.Member.State with + | Leader -> return () + | Follower -> + /// ...otherwise we respond with the respective RaftError. + do! logDebug "receiveVoteResponse" "Failed: NotCandidate" return! - "Vote Term Mismatch" + "Not Candidate" |> Error.asRaftError (tag "receiveVoteResponse") |> failM - - /// Process the vote if current state of our Raft must be candidate.. - else - match state.State with - | Leader -> return () - | Follower -> - /// ...otherwise we respond with the respective RaftError. - do! debug "receiveVoteResponse" "Failed: NotCandidate" - return! - "Not Candidate" - |> Error.asRaftError (tag "receiveVoteResponse") - |> failM - | Candidate -> - if vote.Granted then - let! mem = getMemberM nid - match mem with - // Could not find the mem in current configuration(s) - | None -> - do! debug "receiveVoteResponse" "Failed: vote granted but NoMember" - return! - "No Node" - |> Error.asRaftError (tag "receiveVoteResponse") - |> failM - // found the mem - | Some mem -> - do! setVotingM mem true - - let! transitioning = inJointConsensusM () - - // in joint consensus - if transitioning then - // _ _ _ - // | | ___ (_)_ __ | |_ - // _ | |/ _ \| | '_ \| __| - // | |_| | (_) | | | | | |_ - // \___/ \___/|_|_| |_|\__| consensus. - // - // we probe for a majority in both configurations - let! newConfig = - numVotesForMeM () >>= regularMajorityM - - let! oldConfig = - numVotesForMeOldConfigM () >>= oldConfigMajorityM - - do! sprintf "In JointConsensus (majority new config: %b) (majority old config: %b)" - newConfig - oldConfig - |> debug "receiveVoteResponse" - - // and finally, become leader if we have a majority in either - // configuration - if newConfig || oldConfig then - do! becomeLeader () - else - // ____ _ - // | _ \ ___ __ _ _ _| | __ _ _ __ - // | |_) / _ \/ _` | | | | |/ _` | '__| - // | _ < __/ (_| | |_| | | (_| | | - // |_| \_\___|\__, |\__,_|_|\__,_|_| configuration. - // |___/ - // the base case: we are not in joint consensus so we just use - // regular configuration functions - let! majority = - numVotesForMeM () >>= regularMajorityM - - do! sprintf "(majority for config: %b)" majority - |> debug "receiveVoteResponse" - - if majority then - do! becomeLeader () + | Candidate -> + if vote.Granted then + let! mem = getMember nid + match mem with + // Could not find the mem in current configuration(s) + | None -> + do! logDebug "receiveVoteResponse" "Failed: vote granted but NoMember" + return! + "No Node" + |> Error.asRaftError (tag "receiveVoteResponse") + |> failM + // found the mem + | Some mem -> + do! setVoting mem true + + let! transitioning = inJointConsensus () + + // in joint consensus + if transitioning then + // _ _ _ + // | | ___ (_)_ __ | |_ + // _ | |/ _ \| | '_ \| __| + // | |_| | (_) | | | | | |_ + // \___/ \___/|_|_| |_|\__| consensus. + // + // we probe for a majority in both configurations + let! newConfig = numVotesForMe () >>= regularMajority + let! oldConfig = numVotesForMeOldConfig () >>= oldConfigMajority + + do! sprintf "In JointConsensus (majority new config: %b) (majority old config: %b)" + newConfig + oldConfig + |> logDebug "receiveVoteResponse" + + // and finally, become leader if we have a majority in either + // configuration + if newConfig || oldConfig then + do! becomeLeader () + else + // ____ _ + // | _ \ ___ __ _ _ _| | __ _ _ __ + // | |_) / _ \/ _` | | | | |/ _` | '__| + // | _ < __/ (_| | |_| | | (_| | | + // |_| \_\___|\__, |\__,_|_|\__,_|_| configuration. + // |___/ + // the base case: we are not in joint consensus so we just use + // regular configuration functions + let! majority = numVotesForMe () >>= regularMajority + + do! sprintf "(majority for config: %b)" majority + |> logDebug "receiveVoteResponse" + + if majority then + do! becomeLeader () } // ** sendVoteRequest @@ -2350,29 +962,28 @@ module rec Raft = /// Request a from a given peer let sendVoteRequest (mem : RaftMember) = raft { - let! state = get + let! term = currentTerm() + let! self = self() + let! log = log() let! cbs = read - - let vote = - { Term = state.CurrentTerm - Candidate = state.Member - LastLogIndex = Log.getIndex state.Log - LastLogTerm = Log.getTerm state.Log } - do! mem.Status |> sprintf "(to: %s) (state: %A)" (string mem.Id) - |> debug "sendVoteRequest" - - cbs.SendRequestVote mem vote + |> logDebug "sendVoteRequest" + do cbs.SendRequestVote mem { + Term = term + Candidate = self + LastLogIndex = Log.index log + LastLogTerm = Log.term log + } } // ** requestAllVotes let requestAllVotes () = raft { - let! self = getSelfM () - let! peers = logicalPeersM () - do! info "requestAllVotes" "requesting all votes" + let! self = self () + let! peers = logicalPeers () + do! logInfo "requestAllVotes" "requesting all votes" for peer in peers do if self.Id <> peer.Value.Id then do! sendVoteRequest peer.Value @@ -2405,27 +1016,27 @@ module rec Raft = let private validateLastLog vote state = let err = RaftError (tag "shouldGrantVote","Invalid Last Log") let result = - vote.LastLogTerm = lastLogTerm state && - currentIndex state <= vote.LastLogIndex + vote.LastLogTerm = RaftState.lastLogTerm state && + RaftState.currentIndex state <= vote.LastLogIndex (result,err) // ** validateLastLogTerm let private validateLastLogTerm vote state = let err = RaftError (tag "shouldGrantVote","Invalid LastLogTerm") - (lastLogTerm state < vote.LastLogTerm, err) + (RaftState.lastLogTerm state < vote.LastLogTerm, err) // ** validateCurrentIdx let private validateCurrentIdx state = let err = RaftError (tag "shouldGrantVote","Invalid Current Index") - (currentIndex state = index 0, err) + (RaftState.currentIndex state = 0, err) // ** validateCandiate let private validateCandidate (vote: VoteRequest) state = let err = RaftError (tag "shouldGrantVote","Candidate Unknown") - (getMember vote.Candidate.Id state |> Option.isNone, err) + (RaftState.getMember vote.Candidate.Id state |> Option.isNone, err) // ** shouldGrantVote @@ -2448,11 +1059,11 @@ module rec Raft = if fst result then do! vote.Candidate.Id |> sprintf "granted vote to %O" - |> debug "shouldGrantVote" + |> logDebug "shouldGrantVote" else do! snd result |> sprintf "did not grant vote to %O. reason: %A" vote.Candidate.Id - |> debug "shouldGrantVote" + |> logDebug "shouldGrantVote" return result } @@ -2469,11 +1080,11 @@ module rec Raft = let private maybeResetFollower (nid: MemberId) (vote : VoteRequest) = raft { - let! term = currentTermM () + let! term = currentTerm () if term < vote.Term then - do! debug "maybeResetFollower" "current term < vote Term, resetting to follower state" - do! setTermM vote.Term - do! setLeaderM (Some nid) + do! logDebug "maybeResetFollower" "current term < vote Term, resetting to follower state" + do! setCurrentTerm vote.Term + do! setLeader (Some nid) do! becomeFollower () do! voteFor None } @@ -2484,34 +1095,38 @@ module rec Raft = raft { let! result = shouldGrantVote vote match result with - | (true,_) -> - let! leader = isLeaderM () - let! candidate = isCandidateM () - if not leader && not candidate then - do! voteForId vote.Candidate.Id - do! setTimeoutElapsedM 0 - let! term = currentTermM () - return { Term = term - Granted = true - Reason = None } - else - do! debug "processVoteRequest" "vote request denied: NotVotingState" - return! - "Not Voting State" - |> Error.asRaftError (tag "processVoteRequest") - |> failM - | (false, err) -> - let! term = currentTermM () - return { Term = term - Granted = false - Reason = Some err } + | (true,_) -> + let! leader = isLeader () + let! candidate = isCandidate () + if not leader && not candidate then + do! voteForId vote.Candidate.Id + do! setTimeoutElapsed 0 + let! term = currentTerm () + return { + Term = term + Granted = true + Reason = None + } + else + do! logDebug "processVoteRequest" "vote request denied: NotVotingState" + return! + "Not Voting State" + |> Error.asRaftError (tag "processVoteRequest") + |> failM + | (false, err) -> + let! term = currentTerm () + return { + Term = term + Granted = false + Reason = Some err + } } // ** receiveVoteRequest let receiveVoteRequest (nid : MemberId) (vote : VoteRequest) = raft { - let! mem = getMemberM nid + let! mem = getMember nid match mem with | Some _ -> do! maybeResetFollower nid vote @@ -2520,17 +1135,18 @@ module rec Raft = let str = sprintf "mem %s requested vote. granted: %b" (string nid) result.Granted - do! info "receiveVoteRequest" str - + do! logInfo "receiveVoteRequest" str return result | _ -> - do! info "receiveVoteRequest" <| sprintf "requested denied. NoMember %s" (string nid) + do! logInfo "receiveVoteRequest" <| sprintf "requested denied. NoMember %s" (string nid) - let! trm = currentTermM () + let! trm = currentTerm () let err = RaftError (tag "processVoteRequest", "Not Voting State") - return { Term = trm - Granted = false - Reason = Some err } + return { + Term = trm + Granted = false + Reason = Some err + } } // ** startElection @@ -2544,13 +1160,18 @@ module rec Raft = /// start an election by becoming candidate let startElection () = raft { - let! state = get - let str = sprintf "(elapsed: %d) (elec-timeout: %d) (term: %d) (ci: %d)" - state.TimeoutElapsed - state.ElectionTimeout - state.CurrentTerm - (currentIndex state) - do! debug "startElection" str + let! currentIndex = currentIndex () + let! elapsed = timeoutElapsed () + let! electionTimeout = electionTimeout () + let! term = currentTerm () + let str = + String.Format( + "(elapsed: {0}) (elec-timeout: {1}) (term: {2}) (ci: {3})", + elapsed, + electionTimeout, + currentTerm, + currentIndex) + do! logDebug "startElection" str do! becomeCandidate () } @@ -2564,47 +1185,44 @@ module rec Raft = let periodic (elapsed : Timeout) = raft { - let! state = get - do! setTimeoutElapsedM (state.TimeoutElapsed + elapsed) + let! state = state() + let! currentlyElapsed = timeoutElapsed () + do! setTimeoutElapsed (currentlyElapsed + elapsed) - match state.State with + match state with | Leader -> // if in JointConsensus - let! consensus = inJointConsensusM () - let! timedout = requestTimedOutM () + let! consensus = inJointConsensus () + let! timedout = requestTimedOut () if consensus then - let! waiting = hasNonVotingMembersM () // check if any mems are still marked non-voting/Joining - if not waiting then // are mems are voting and have caught up - let! term = currentTermM () - let resp = { Id = DiscoId.Create(); Term = term; Index = index 0 } - let! mems = getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) - let log = Configuration(resp.Id, index 0, term, mems, None) - do! handleLog log resp >>= ignoreM + // check if any mems are still marked non-voting/Joining + // are mems are voting and have caught up + let! waiting = hasNonVotingMembers () + if not waiting then + let! term = currentTerm () + let response = EntryResponse.create term 0 + let! mems = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) + let log = Configuration(response.Id, 0, term, mems, None) + do! handleLog log response >>= ignoreM else - do! sendAllAppendEntriesM () + do! sendAllAppendEntries () // the regular case is we need to ping our followers so as to not provoke an election elif timedout then - do! sendAllAppendEntriesM () - + do! sendAllAppendEntries () | _ -> // have to double check the code here to ensure new elections are really only called when // not enough votes could be garnered - let! num = numMembersM () - let! timedout = electionTimedOutM () - + let! num = numMembers () + let! timedout = electionTimedOut () if timedout && num > 1 then do! startElection () elif timedout && num = 1 then do! becomeLeader () - else - do! recountPeers () - - let! coi = commitIndexM () - let! lai = lastAppliedIdx () + let! coi = commitIndex () + let! lai = lastAppliedIndex () if lai < coi then do! applyEntries () - do! maybeSnapshot () } diff --git a/src/Disco/Disco/Raft/RaftMonad.fs b/src/Disco/Disco/Raft/RaftMonad.fs new file mode 100644 index 00000000..7548bf31 --- /dev/null +++ b/src/Disco/Disco/Raft/RaftMonad.fs @@ -0,0 +1,794 @@ +(* + * This file is part of Distributed Show Control + * + * Copyright 2015, 2018 by it's authors. + * Some rights reserved. See COPYING, AUTHORS. + *) + +namespace rec Disco.Raft + +// * Imports + +open System +open System.Net +open Disco.Core +open Disco.Serialization +open Aether +open Aether.Operators +open FlatBuffers + +// * RaftMonad + +/// The RaftMonad is a custom Reader/State monad with a specific constructor to provide more type +/// safety. +/// +/// State monads are functions that close over a state value. This state monad is extended by an +/// additional parameter 'Env, the reader monad part. +/// +/// This module should be used when composing Raft code, as it wraps the pure RaftState manipulation +/// code with the callbacks environment needed to provide functionality for Raft. + +[] +type RaftMonad<'Env,'State,'T,'Error> = + MkRM of ('Env -> 'State -> Result<'T * 'State,'Error * 'State>) + +// * RaftM + +type RaftM<'t,'err> = RaftMonad + +// * RaftMonad module + +[] +module RaftMonad = + + // ** get + + /// get current Raft state + let get = MkRM (fun _ s -> Ok (s, s)) + + // ** put + + /// update Raft/State to supplied value + let put s = MkRM (fun _ _ -> Ok ((), s)) + + // ** read + + /// get the read-only environment value + let read: RaftM<_,_> = MkRM (fun l s -> Ok (l, s)) + + // ** apply + + /// unwrap the closure and apply it to the supplied state/env + let apply (env: 'e) (state: 's) (m: RaftMonad<'e,'s,_,_>) = + match m with | MkRM func -> func env state + + // ** runRaft + + /// run the monadic action against state and environment values + let runRaft (s: 's) (l: 'e) (m: RaftMonad<'e,'s,'a,'err>) = + apply l s m + + // ** evalRaft + + /// run monadic action against supplied state and evironment and return new state + let evalRaft (s: 's) (l: 'e) (m: RaftMonad<'e,'s,'a,'err>) = + match runRaft s l m with + | Ok (_,state) | Error (_,state) -> state + + // ** returnM + + /// Lift a regular value into a RaftMonad by wrapping it in a closure. + /// This variant wraps it in a `Ok` value. This means the computation will, + /// if possible, continue to the next step. + let returnM value : RaftMonad<'e,'s,'t,'err> = + MkRM (fun _ state -> Ok(value, state)) + + // ** ignoreM + + let ignoreM _ : RaftMonad<'e,'s,unit,'err> = + MkRM (fun _ state -> Ok((), state)) + + // ** failM + + /// Lift a regular value into a RaftMonad by wrapping it in a closure. + /// This variant wraps it in a `Error` value. This means the computation will + /// not continue past this step and no regular value will be returned. + let failM l = + MkRM (fun _ s -> Error (l, s)) + + // ** returnFromM + + /// pass through the given action + let returnFromM func : RaftMonad<'e,'s,'t,'err> = + func + + // ** zeroM + + let zeroM () = + MkRM (fun _ state -> Ok((), state)) + + // ** delayM + + let delayM (f: unit -> RaftMonad<'e,'s,'t,'err>) = + MkRM (fun env state -> f () |> apply env state) + + // ** bindM + + /// Chain up effectful actions. + let bindM (m: RaftMonad<'env,'state,'a,'err>) + (f: 'a -> RaftMonad<'env,'state,'b,'err>) : + RaftMonad<'env,'state,'b,'err> = + MkRM (fun env state -> + match apply env state m with + | Ok (value,state') -> f value |> apply env state' + | Error err -> Error err) + + // ** (>>=) + + let (>>=) = bindM + + // ** combineM + + let combineM (m1: RaftMonad<_,_,_,_>) (m2: RaftMonad<_,_,_,_>) = + bindM m1 (fun _ -> m2) + + // ** tryWithM + + let tryWithM (body: RaftMonad<_,_,_,_>) (handler: exn -> RaftMonad<_,_,_,_>) = + MkRM (fun env state -> + try apply env state body + with ex -> apply env state (handler ex)) + + // ** tryFinallyM + + let tryFinallyM (body: RaftMonad<_,_,_,_>) handler : RaftMonad<_,_,_,_> = + MkRM (fun env state -> + try apply env state body + finally handler ()) + + // ** usingM + + let usingM (resource: ('a :> System.IDisposable)) (body: 'a -> RaftMonad<_,_,_,_>) = + tryFinallyM (body resource) + (fun _ -> if not <| isNull (box resource) + then resource.Dispose()) + + // ** whileM + + let rec whileM (guard: unit -> bool) (body: RaftMonad<_,_,_,_>) = + match guard () with + | true -> bindM body (fun _ -> whileM guard body) + | _ -> zeroM () + + // ** forM + + let rec forM (sequence: seq<_>) (body: 'a -> RaftMonad<_,_,_,_>) : RaftMonad<_,_,_,_> = + usingM (sequence.GetEnumerator()) + (fun enum -> whileM enum.MoveNext (delayM (fun _ -> body enum.Current))) + + // ** RaftBuilder + + type RaftBuilder() = + member __.Return(v) = returnM v + member __.ReturnFrom(v) = returnFromM v + member __.Bind(m, f) = bindM m f + member __.Zero() = zeroM () + member __.Delay(f) = delayM f + member __.Combine(a,b) = combineM a b + member __.TryWith(body, handler) = tryWithM body handler + member __.TryFinally(body, handler) = tryFinallyM body handler + member __.Using(res, body) = usingM res body + member __.While(guard, body) = whileM guard body + member __.For(seq, body) = forM seq body + + // ** raft + + let raft = new RaftBuilder() + + // ** modify + + let modify (f: RaftState -> RaftState) = + get >>= (f >> put) + + // ** zoom + + let zoom (f: RaftState -> 'a) = + get >>= (f >> returnM) + + // ** tag + + let private tag (str: string) = String.Format("Raft.{0}",str) + + // ** logMsg + + let logMsg site level message = + message + |> Logger.log level (tag site) + |> returnM + + // ** logMap + + let logMap level location reason items = + let prefix = + match level with + | Err -> "Failed: (" + reason + ") " + | _ -> reason + items + |> List.fold (fun m (item,value) -> m + "[" + item + "=" + value + "] ") prefix + |> Logger.log level (tag location) + |> returnM + + // ** logDebug + + let logDebug site str = logMsg site Debug str + + // ** logInfo + + let logInfo site str = logMsg site Info str + + // ** logWarn + + let logWarn site str = logMsg site Warn str + + // ** logError + + let logError site str = logMsg site Err str + + // ** currentIndex + + let currentIndex () = zoom RaftState.currentIndex + + // ** currentTerm + + let currentTerm () = zoom RaftState.currentTerm + + // ** isFollower + + let isFollower () = zoom RaftState.isFollower + + // ** isCandidate + + let isCandidate () = zoom RaftState.isCandidate + + // ** isLeader + + let isLeader () = zoom RaftState.isLeader + + // ** inJointConsensus + + let inJointConsensus () = zoom RaftState.inJointConsensus + + // ** hasNonVotingMembers + + let hasNonVotingMembers () = zoom RaftState.hasNonVotingMembers + + // ** configurationChanges + + let configurationChanges () = zoom RaftState.configurationChanges + + // ** logicalPeers + + let logicalPeers () = zoom RaftState.logicalPeers + + // ** countMembers + + let countMembers () = zoom (RaftState.logicalPeers >> RaftState.countMembers) + + // ** numLogicalPeers + + let numLogicalPeers () = zoom RaftState.numLogicalPeers + + // ** hasMember + + let hasMember nid = zoom (RaftState.hasMember nid) + + // ** getMember + + let getMember nid = zoom (RaftState.getMember nid) + + // ** getMembers + + let getMembers () = zoom RaftState.peers + + // ** self + + let self () = zoom RaftState.self + + // ** setSelf + + let setSelf self = modify (RaftState.setSelf self) + + // ** configChangeEntry + + let configChangeEntry () = zoom RaftState.configChangeEntry + + // ** setConfigChangeEntry + + let setConfigChangeEntry change = + raft { + let! current = configChangeEntry() + do! modify (RaftState.setConfigChangeEntry change) + match current, change with + | None, Some _ -> + do! logDebug "setConfigChangeEntry" "setting ConfigChangeEntry to JointConsensus" + | Some _, None -> + do! logDebug "setConfigChangeEntry" "resetting ConfigChangeEntry" + | _ -> return () + } + + // ** persistVote + + let persistVote mem = + read >>= fun cbs -> cbs.PersistVote mem |> returnM + + // ** persistTerm + + let persistTerm term = + read >>= fun cbs -> cbs.PersistTerm term |> returnM + + // ** persistLog + + let persistLog log = + read >>= fun cbs -> cbs.PersistLog log |> returnM + + // ** setCurrentTerm + + let setCurrentTerm term = + raft { + do! modify (RaftState.setCurrentTerm term) + do! persistTerm term + } + + // ** state + + let state () = zoom RaftState.state + + // ** maxLogDepth + + let maxLogDepth () = zoom RaftState.maxLogDepth + + // ** setMaxLogDepth + + let setMaxLogDepth depth = modify (RaftState.setMaxLogDepth depth) + + // ** setPeers + + let setPeers peers = modify (RaftState.setPeers peers) + + // ** setOldPeers + + let setOldPeers peers = modify (RaftState.setOldPeers peers) + + // ** peers + + let peers () = zoom RaftState.peers + + // ** updateMember + + let updateMember (mem: RaftMember) = + raft { + let! state = get + let updated, state = RaftState.updateMember mem state + do! put state + if updated then + let! cbs = read + // if the mems has structurally changed fire the callback + do cbs.MemberUpdated mem + } + + // ** setNextIndex + + /// Set the nextIndex field on Member corresponding to supplied Id (should it exist, that is) and + /// supplied index. Monadic action. + + let setNextIndex (nid : MemberId) idx = + raft { + let! state = get + let update, state = RaftState.setNextIndex nid idx state + do! put state + if update then + let! env = read + do! getMember nid >>= (Option.iter env.MemberUpdated >> returnM) + } + + // ** setMatchIndex + + let setMatchIndex nid idx = + raft { + let! state = get + let update, state = RaftState.setMatchIndex nid idx state + do! put state + if update then + let! env = read + do! getMember nid >>= (Option.iter env.MemberUpdated >> returnM) + } + + // ** setLeader + + /// Set States CurrentLeader field to supplied MemberId. Monadic action. + + let setLeader (leader : MemberId option) = + raft { + let! state = get + let update, state = RaftState.setLeader leader state + do! put state + if update then + let! env = read + let! peers = logicalPeers () + for KeyValue(_,peer) in peers do + do env.MemberUpdated peer + do env.LeaderChanged leader + } + + // ** voteFor + + /// Remeber who we have voted for in current election. + let voteFor (mem: RaftMember option) = + raft { + do! modify (RaftState.voteFor mem) + do! persistVote mem + } + + // ** voteForId + + /// Remeber who we have voted for in current election + let voteForId (nid : MemberId) = + raft { + let! mem = getMember nid + do! voteFor mem + } + + // ** votedFor + + let votedFor () = zoom RaftState.votedFor + + // ** setVoting + + let setVoting (mem: RaftMember) (vote: bool) = + raft { + let msg = String.Format("setting mem {0} voting to {1}", mem.Id, vote) + do! logDebug "setVoting" msg + let! state = get + let update, state = RaftState.setVoting mem vote state + do! put state + if update then + let! env = read + do env.MemberUpdated mem + } + + // ** numMembers + + let numMembers () = zoom RaftState.numMembers + + // ** numOldPeers + + let numOldMembers () = zoom RaftState.numOldMembers + + // ** sendAppendEntries + + let sendAppendEntries (mem: RaftMember) (request: AppendEntries) = + raft { + let! idx = currentIndex () + let! cbs = read + let msg = + sprintf "to: %s ci: %d term: %d leader-commit: %d prv-log-idx: %d prev-log-term: %d" + (string mem.Id) + idx + request.Term + request.LeaderCommit + request.PrevLogIdx + request.PrevLogTerm + do! logDebug "sendAppendEntries" msg + do cbs.SendAppendEntries mem request + } + + // ** addMember + + let addMember (mem: RaftMember) = + raft { + do! modify (RaftState.addMember mem) + let! env = read + do env.MemberAdded mem + } + + // ** addNonVotingMember + + let addNonVotingMember mem = modify (RaftState.addNonVotingMember mem) + + // ** removeMember + + let removeMember mem = + raft { + do! modify (RaftState.removeMember mem) + let! env = read + do env.MemberRemoved mem + } + + // ** notifyChange + + let notifyChange (env: IRaftCallbacks) = function + | MemberAdded mem -> do env.MemberAdded mem + | MemberRemoved mem -> do env.MemberRemoved mem + + // ** applyChanges + + let applyChanges changes = + raft { + do! modify (RaftState.applyChanges changes) + let! env = read + for change in changes do + do notifyChange env change + } + + // ** addMembers + + let addMembers mems = + raft { + do! modify (RaftState.addMembers mems) + let! env = read + for KeyValue(_,mem) in mems do + do env.MemberAdded mem + } + + // ** setMemberState + + let setMemberState mem memstate = + raft { + let! state = get + let updated, state = RaftState.setMemberState mem memstate state + do! put state + if updated then + let! env = read + let! mem = getMember mem + do Option.iter env.MemberUpdated mem + } + + // ** setState + + /// Set current RaftState to supplied state. + + let setState (newstate: MemberState) = + raft { + let! current = zoom RaftState.state + if newstate <> current then + let! env = read + do! modify (RaftState.setState newstate) + do env.StateChanged current newstate + } + + // ** resetVotes + + let resetVotes () = modify RaftState.resetVotes + + // ** voteForMyself + + let voteForMyself () = + get >>= fun state -> voteFor (Some state.Member) + + // ** votedForMyself + + let votedForMyself () = zoom RaftState.votedForMyself + + // ** votingMembers + + let votingMembers () = zoom RaftState.votingMembers + + // ** votingMembersForOldConfg + + let votingMembersForOldConfig () = zoom RaftState.votingMembersForOldConfig + + // ** numLogs + + let numLogs () = zoom RaftState.numLogs + + // ** firstIndex + + let firstIndex term = zoom (RaftState.firstIndex term) + + // ** currentLeader + + let currentLeader () = zoom RaftState.currentLeader + + // ** getLeader + + let getLeader () = zoom RaftState.getLeader + + // ** commitIndex + + let commitIndex () = zoom RaftState.commitIndex + + // ** setCommitIndex + + let setCommitIndex idx = modify (RaftState.setCommitIndex idx) + + // ** requestTimedOut + + let requestTimedOut () = zoom RaftState.requestTimedOut + + // ** electionTimedOut + + let electionTimedOut () = zoom RaftState.electionTimedOut + + // ** electionTimeout + + let electionTimeout () = zoom RaftState.electionTimeout + + // ** timeoutElapsed + + let timeoutElapsed () = zoom RaftState.timeoutElapsed + + // ** setTimeoutElapsed + + let setTimeoutElapsed elapsed = modify (RaftState.setTimeoutElapsed elapsed) + + // ** requestTimeout + + let requestTimeout () = zoom RaftState.requestTimeout + + // ** setRequestTimeout + + let setRequestTimeout timeout = modify (RaftState.setRequestTimeout timeout) + + // ** setElectionTimeout + + let setElectionTimeout timeout = modify (RaftState.setElectionTimeout timeout) + + // ** lastAppliedIndex + + let lastAppliedIndex () = zoom RaftState.lastAppliedIndex + + // ** setLastAppliedIndex + + let setLastAppliedIndex index = modify (RaftState.setLastAppliedIndex index) + + // ** lastLogTerm + + let lastLogTerm () = zoom RaftState.lastLogTerm + + // ** entryAt + + let entryAt idx = zoom (RaftState.entryAt idx) + + // ** entriesUntil + + let entriesUntil idx = zoom (RaftState.entriesUntil idx) + + // ** entriesUntilExcluding + + let entriesUntilExcluding idx = zoom (RaftState.entriesUntilExcluding idx) + + // ** log + + let log () = zoom RaftState.log + + // ** setLog + + let setLog log = modify (RaftState.setLog log) + + // ** updateMembers + + let updateMembers f = + raft { + let! state = get + let updated, state = RaftState.updateMembers f state + do! put state + if updated then + let! env = read + let! peers = logicalPeers() + for KeyValue(_,peer) in peers do + do env.MemberUpdated peer + } + + // ** appendEntry + + let appendEntry (entry: LogEntry) = + raft { + let! current = log () + + // create the new log by appending + let newlog = Log.append entry current + do! setLog newlog + + // get back the entries just added + // (with correct monotonic idx's) + let result = Log.getn (LogEntry.depth entry) newlog + + match result with + | Some entries -> do! persistLog entries + | _ -> () + + return result + } + + // ** createEntry + + let createEntry (entry: StateMachine) = + raft { + let! term = currentTerm () + let log = LogEntry.create 0 term entry + return! appendEntry log + } + + // ** removeEntry + + /// Delete a log entry at the index specified. Returns the original value if + /// the record is not found. + + let removeEntry idx = + raft { + let! env = read + let! current = log () + match Log.at idx current with + | Some log -> + match LogEntry.pop log with + | Some newlog -> + // fire delete log callback for all removed items + match Log.until idx current with + | Some items -> LogEntry.iter (fun _ entry -> do env.DeleteLog entry) items + | _ -> () + // save the modified log to state + do! modify (updateLogEntries newlog) + | _ -> + do env.DeleteLog log + do! modify (RaftState.setLog Log.empty) + | _ -> () + } + + // ** updateLogEntries + + let updateLogEntries (entries: LogEntry) (state: RaftState) = + { state with + Log = { Index = LogEntry.index entries + Depth = LogEntry.depth entries + Data = Some entries } } + + // ** updateCommitIndex + + let updateCommitIndex () = modify RaftState.updateCommitIndex + + // ** regularMajority + + /// Determine whether a vote count constitutes a majority in the *regular* + /// configuration (does not cover the joint consensus state). + + let regularMajority votes = + raft { + let! num = votingMembers () + return RaftState.majority num votes + } + + // ** oldConfigMajority + + let oldConfigMajority votes = + raft { + let! num = votingMembersForOldConfig () + return RaftState.majority num votes + } + + // ** numVotesForMe + + let numVotesForMe () = zoom RaftState.numVotesForMe + + // ** numVotesForMeOldConfig + + let numVotesForMeOldConfig () = zoom RaftState.numVotesForMeOldConfig + + // ** handleConfiguration + + let handleConfiguration mems = modify (RaftState.handleConfiguration mems) + + // ** handleJointConsensus + + let handleJointConsensus changes = modify (RaftState.handleJointConsensus changes) + + // ** calculateChanges + + let calculateChanges oldPeers = + raft { + let! currentPeers = peers() + return RaftState.calculateChanges oldPeers currentPeers + } + + // ** selfIncluded + + let selfIncluded () = zoom RaftState.selfIncluded diff --git a/src/Disco/Disco/Raft/RaftState.fs b/src/Disco/Disco/Raft/RaftState.fs new file mode 100644 index 00000000..b7494728 --- /dev/null +++ b/src/Disco/Disco/Raft/RaftState.fs @@ -0,0 +1,830 @@ +(* + * This file is part of Distributed Show Control + * + * Copyright 2015, 2018 by it's authors. + * Some rights reserved. See COPYING, AUTHORS. + *) + +namespace rec Disco.Raft + +// * Imports + +open System +open System.Net +open Disco.Core +open Disco.Serialization +open Aether +open Aether.Operators +open FlatBuffers + +#if !FABLE_COMPILER && !DISCO_NODES + +open SharpYaml.Serialization + +#endif + +// * Callback Interface + +/// IRaftCallbacks are an abstraction layer to allow for separation of pure code and side effects +/// which occur in the RaftMonad, and to be able to modularize and test the monadic code without +/// actual IO. +/// +/// A free monad might have also been a good choice, providing the possibility to swap out +/// interpreters in different contexts. + +type IRaftCallbacks = + + /// Request a vote from given Raft server + abstract member SendRequestVote: peer:RaftMember -> request:VoteRequest -> unit + + /// Send AppendEntries message to given server + abstract member SendAppendEntries: peer:RaftMember -> request:AppendEntries -> unit + + /// Send InstallSnapshot command to given serve + abstract member SendInstallSnapshot: peer:RaftMember -> request:InstallSnapshot -> unit + + /// given the current state of Raft, prepare and return a snapshot value of + /// current application state + abstract member PrepareSnapshot: current:RaftState -> Log option + + /// perist the given Snapshot value to disk. For safety reasons this MUST + /// flush all changes to disk. + abstract member PersistSnapshot: snapshot:LogEntry -> unit + + /// attempt to load a snapshot from disk. return None if no snapshot was found + abstract member RetrieveSnapshot: unit -> LogEntry option + + /// apply the given command to state machine + abstract member ApplyLog: command:StateMachine -> unit + + /// a new server was added to the configuration + abstract member MemberAdded: peer:RaftMember -> unit + + /// a new server was added to the configuration + abstract member MemberUpdated: peer:RaftMember -> unit + + /// a server was removed from the configuration + abstract member MemberRemoved: peer:RaftMember -> unit + + /// a cluster configuration transition was successfully applied + abstract member Configured: members:RaftMember array -> unit + + /// a cluster configuration transition was successfully applied + abstract member JointConsensus: changes:ConfigChange array -> unit + + /// the state of Raft itself has changed from old state to new given state + abstract member StateChanged: oldstate:MemberState -> newstate:MemberState -> unit + + /// the leader node changed + abstract member LeaderChanged: leader:MemberId option -> unit + + /// persist vote data to disk. For safety reasons this callback MUST flush + /// the change to disk. + abstract member PersistVote: peer:RaftMember option -> unit + + /// persist term data to disk. For safety reasons this callback MUST flush + /// the change to disk> + abstract member PersistTerm: term:Term -> unit + + /// persist an entry added to the log to disk. For safety reasons this + /// callback MUST flush the change to disk. + abstract member PersistLog: log:LogEntry -> unit + + /// persist the removal of the passed entry from the log to disk. For safety + /// reasons this callback MUST flush the change to disk. + abstract member DeleteLog: log:LogEntry -> unit + +// * RaftStateYaml + +type RaftStateYaml() = + [] val mutable Member : string + [] val mutable Term : Term + [] val mutable Leader : string + [] val mutable VotedFor : string + [] val mutable ElectionTimeout : int + [] val mutable RequestTimeout : int + [] val mutable MaxLogDepth : int + +// * RaftState + +/// State to hold all Raft-specific fields. Progression of the Raft system is a series of incremental +/// changes to a value of this type. + +type RaftState = + { /// this server's own RaftMember information + MemberId : MemberId + /// the server's current term, a monotonic counter for election cycles + CurrentTerm : Term + /// tracks the current Leader Id, or None if there isn't currently a leader + CurrentLeader : MemberId option + /// map of all known members in the cluster + Peers : Map + /// map of the previous cluster configuration. set if currently in a configuration change + OldPeers : Map option + /// the candidate this server voted for in its current term or None if it hasn't voted for any + /// other member yet + VotedFor : MemberId option + /// the replicated state machine command log + Log : Log + /// index of latest log entry known to be committed + CommitIndex : Index + /// index of latest log entry applied to state machine + LastAppliedIdx : Index + /// amount of time left until a new election will be called + TimeoutElapsed : Timeout + /// amount of time that needs to pass before a new election is called + ElectionTimeout : Timeout + /// amount of time to pass until we consider requests to be failed + RequestTimeout : Timeout + /// maximum log depth to reach before automatic snapshotting triggers + MaxLogDepth : int + /// the log entry which has a voting configuration change, otherwise None + ConfigChangeEntry : LogEntry option } + + // ** optics + + static member MemberId_ = + (fun (rs:RaftState) -> rs.MemberId), + (fun memberId (rs:RaftState) -> { rs with MemberId = memberId }) + + static member CurrentTerm_ = + (fun (rs:RaftState) -> rs.CurrentTerm), + (fun currentTerm (rs:RaftState) -> { rs with CurrentTerm = currentTerm }) + + static member CurrentLeader_ = + (fun (rs:RaftState) -> rs.CurrentLeader), + (fun currentLeader (rs:RaftState) -> { rs with CurrentLeader = currentLeader }) + + static member Peers_ = + (fun (rs:RaftState) -> rs.Peers), + (fun peers (rs:RaftState) -> { rs with Peers = peers }) + + static member OldPeers_ = + (fun (rs:RaftState) -> rs.OldPeers), + (fun oldPeers (rs:RaftState) -> { rs with OldPeers = oldPeers }) + + static member VotedFor_ = + (fun (rs:RaftState) -> rs.VotedFor), + (fun votedFor (rs:RaftState) -> { rs with VotedFor = votedFor }) + + static member Log_ = + (fun (rs:RaftState) -> rs.Log), + (fun log (rs:RaftState) -> { rs with Log = log }) + + static member CommitIndex_ = + (fun (rs:RaftState) -> rs.CommitIndex), + (fun commitIndex (rs:RaftState) -> { rs with CommitIndex = commitIndex }) + + static member LastAppliedIndex_ = + (fun (rs:RaftState) -> rs.LastAppliedIdx), + (fun lastAppliedIdx (rs:RaftState) -> { rs with LastAppliedIdx = lastAppliedIdx }) + + static member TimeoutElapsed_ = + (fun (rs:RaftState) -> rs.TimeoutElapsed), + (fun timeoutElapsed (rs:RaftState) -> { rs with TimeoutElapsed = timeoutElapsed }) + + static member ElectionTimeout_ = + (fun (rs:RaftState) -> rs.ElectionTimeout), + (fun electionTimeout (rs:RaftState) -> { rs with ElectionTimeout = electionTimeout }) + + static member RequestTimeout_ = + (fun (rs:RaftState) -> rs.RequestTimeout), + (fun requestTimeout (rs:RaftState) -> { rs with RequestTimeout = requestTimeout }) + + static member MaxLogDepth_ = + (fun (rs:RaftState) -> rs.MaxLogDepth), + (fun maxLogDepth (rs:RaftState) -> { rs with MaxLogDepth = maxLogDepth }) + + static member ConfigChangeEntry_ = + (fun (rs:RaftState) -> rs.ConfigChangeEntry), + (fun configChangeEntry (rs:RaftState) -> { rs with ConfigChangeEntry = configChangeEntry }) + + static member CurrentIndex_ = RaftState.Log_ >-> Log.Index_ + + // ** ToString + + override self.ToString() = + sprintf "Member = %s +State = %A +CurrentTerm = %A +CurrentLeader = %A +NumMembers = %A +NumOldMembers = %A +VotedFor = %A +MaxLogDepth = %A +CommitIndex = %A +LastAppliedIdx = %A +TimeoutElapsed = %A +ElectionTimeout = %A +RequestTimeout = %A +ConfigChangeEntry = %s +" + (self.Member.ToString()) + self.Member.State + self.CurrentTerm + self.CurrentLeader + (Map.count self.Peers) + (Option.map Map.count self.OldPeers) + self.VotedFor + self.MaxLogDepth + self.CommitIndex + self.LastAppliedIdx + self.TimeoutElapsed + self.ElectionTimeout + self.RequestTimeout + (if Option.isSome self.ConfigChangeEntry then + Option.get self.ConfigChangeEntry |> string + else Constants.EMPTY) + + // ** IsLeader + + member self.IsLeader = + match self.CurrentLeader with + | Some lid -> self.Member.Id = lid + | _ -> false + + // ** Member + + member self.Member: RaftMember = + match Map.tryFind self.MemberId self.Peers with + | Some mem -> mem + | None -> + match Option.bind (Map.tryFind self.MemberId) self.OldPeers with + | Some mem -> mem + | None -> failwith "could not find current member in peers map." + + // ** ToYaml + + #if !FABLE_COMPILER && !DISCO_NODES + + member self.ToYaml() = + let yaml = RaftStateYaml() + yaml.Member <- string self.Member.Id + yaml.Term <- self.CurrentTerm + + Option.map + (fun leader -> yaml.Leader <- string leader) + self.CurrentLeader + |> ignore + + Option.map + (fun voted -> yaml.VotedFor <- string voted) + self.VotedFor + |> ignore + + yaml.ElectionTimeout <- int self.ElectionTimeout + yaml.RequestTimeout <- int self.RequestTimeout + yaml.MaxLogDepth <- self.MaxLogDepth + yaml + + // ** FromYaml + + static member FromYaml (yaml: RaftStateYaml): DiscoResult = + result { + let! id = DiscoId.TryParse yaml.Member + + let! leader = + if isNull yaml.Leader + then Ok None + else DiscoId.TryParse yaml.Leader |> Result.map Some + + let! votedfor = + if isNull yaml.VotedFor + then Ok None + else DiscoId.TryParse yaml.VotedFor |> Result.map Some + + let mem = Member.create id + return { + MemberId = id + CurrentTerm = yaml.Term + CurrentLeader = leader + Peers = Map [ (id, mem) ] + OldPeers = None + VotedFor = votedfor + Log = Log.empty + CommitIndex = 0 + LastAppliedIdx = 0 + TimeoutElapsed = 0 + ElectionTimeout = yaml.ElectionTimeout * 1 + RequestTimeout = yaml.RequestTimeout * 1 + MaxLogDepth = yaml.MaxLogDepth + ConfigChangeEntry = None + } + } + + #endif + +// * RaftState module + +/// Pure functions to manipulate RaftState values. To work with Raft code, please create/use the +/// functions from the RaftMonad module. + +[] +module RaftState = + + // ** getters + + let self (state: RaftState) = state.Member + let state = self >> Member.state + let memberId = Optic.get RaftState.MemberId_ + let currentTerm = Optic.get RaftState.CurrentTerm_ + let currentLeader = Optic.get RaftState.CurrentLeader_ + let peers = Optic.get RaftState.Peers_ + let oldPeers = Optic.get RaftState.OldPeers_ + let votedFor = Optic.get RaftState.VotedFor_ + let log = Optic.get RaftState.Log_ + let commitIndex = Optic.get RaftState.CommitIndex_ + let lastAppliedIndex = Optic.get RaftState.LastAppliedIndex_ + let timeoutElapsed = Optic.get RaftState.TimeoutElapsed_ + let electionTimeout = Optic.get RaftState.ElectionTimeout_ + let requestTimeout = Optic.get RaftState.RequestTimeout_ + let maxLogDepth = Optic.get RaftState.MaxLogDepth_ + let configChangeEntry = Optic.get RaftState.ConfigChangeEntry_ + + // ** setters + + let setMemberId = Optic.set RaftState.MemberId_ + let setCurrentTerm = Optic.set RaftState.CurrentTerm_ + let setCurrentLeader = Optic.set RaftState.CurrentLeader_ + let setPeers = Optic.set RaftState.Peers_ + let setOldPeers = Optic.set RaftState.OldPeers_ + let setVotedFor = Optic.set RaftState.VotedFor_ + let setLog = Optic.set RaftState.Log_ + let setCommitIndex = Optic.set RaftState.CommitIndex_ + let setLastAppliedIndex = Optic.set RaftState.LastAppliedIndex_ + let setTimeoutElapsed = Optic.set RaftState.TimeoutElapsed_ + let setElectionTimeout = Optic.set RaftState.ElectionTimeout_ + let setRequestTimeout = Optic.set RaftState.RequestTimeout_ + let setMaxLogDepth = Optic.set RaftState.MaxLogDepth_ + let setConfigChangeEntry = Optic.set RaftState.ConfigChangeEntry_ + + // ** setSelf + + let setSelf (mem: RaftMember) state = + state + |> peers + |> Map.add mem.Id mem + |> flip setPeers state + |> setMemberId mem.Id + + // ** setState + + let setState memState (state:RaftState) = + state.Member + |> Member.setState memState + |> flip setSelf state + + // ** create + + let create (self: RaftMember) = + { MemberId = self.Id + CurrentTerm = 0 + CurrentLeader = None + Peers = Map.ofList [(self.Id, self)] + OldPeers = None + VotedFor = None + Log = Log.empty + CommitIndex = 0 + LastAppliedIdx = 0 + TimeoutElapsed = 0 + ElectionTimeout = Constants.RAFT_ELECTION_TIMEOUT * 1 + RequestTimeout = Constants.RAFT_REQUEST_TIMEOUT * 1 + MaxLogDepth = Constants.RAFT_MAX_LOGDEPTH + ConfigChangeEntry = None } + + // ** numMembers + + let numMembers = Optic.get RaftState.Peers_ >> Map.count + + // ** numOldMembers + + let numOldMembers = + Optic.get RaftState.OldPeers_ + >> Option.map Map.count + >> Option.defaultValue 0 + + // ** currentIndex + + let currentIndex = Optic.get RaftState.CurrentIndex_ + + // ** isFollower + + let isFollower (state:RaftState) = state.Member.State = Follower + + // ** isCandidate + + let isCandidate (state:RaftState) = state.Member.State = Candidate + + // ** isLeader + + let isLeader (state:RaftState) = state.Member.State = Leader + + // ** inJointConsensus + + let inJointConsensus = configChangeEntry >> function + | Some (JointConsensus _) -> true + | _ -> false + + // ** hasNonVotingMembers + + let hasNonVotingMembers (state: RaftState) = + Map.fold + (fun b _ n -> + if b then + b + else + not (Member.hasSufficientLogs n && Member.isVoting n)) + false + state.Peers + + // ** configurationChanges + + let configurationChanges = configChangeEntry >> function + | Some (JointConsensus(_,_,_,changes,_)) -> Some changes + | _ -> None + + // ** logicalPeers + + let logicalPeers (state: RaftState) = + // when setting the NumMembers counter we have to include the old config + if inJointConsensus state then + // take the old peers as seed and apply the new peers on top + match state.OldPeers with + | Some peers -> Map.fold (fun m k n -> Map.add k n m) peers state.Peers + | _ -> state.Peers + else state.Peers + + // ** countMembers + + let countMembers peers = Map.count peers + + // ** numLogicalPeers + + let numLogicalPeers: RaftState -> int = logicalPeers >> countMembers + + // ** hasMember + + let hasMember nid = peers >> Map.containsKey nid + + // ** getMember + + let getMember (nid : MemberId) (state: RaftState) = + if inJointConsensus state then + state + |> logicalPeers + |> Map.tryFind nid + else + Map.tryFind nid state.Peers + + // ** updateMember + + /// Update a member in the RaftState. If it has structurally changed, the first part of the + /// two-tuple returned indicates that a change occurred. + + let updateMember (mem: RaftMember) (state: RaftState) = + let members = peers state + // if we are in joint consensus, we must update the mem value in either the + // new or the old configuration, or both. + if inJointConsensus state then + // first process the regular members + let peersUpdated, peers = + match Map.tryFind mem.Id members with + | Some old when old <> mem -> true, Map.add mem.Id mem members + | _ -> false, members + // next, look at the old cluster configuration and update if changed + let oldPeersUpdated, oldPeers = + match state.OldPeers with + | Some peers -> + match Map.tryFind mem.Id peers with + | Some old when old <> mem -> true, Some (Map.add mem.Id mem peers) + | _ -> false, Some peers + | _ -> + // if OldPeers is empty, but there is a ConfigChangeEntry re-build the OldPeers + match configurationChanges state with + | Some changes -> + let peers = + Array.fold (fun m -> function + | MemberAdded peer -> Map.remove peer.Id m // we must do the inverse operation here + | MemberRemoved peer -> Map.add peer.Id peer m) /// and here too + members + changes + if Map.containsKey mem.Id peers + then true, Some (Map.add mem.Id mem peers) + else false, Some peers + | _ -> false, None + let state = + state + |> setPeers peers + |> setOldPeers oldPeers + peersUpdated || oldPeersUpdated, state + else + let peersUpdated, peers = + match Map.tryFind mem.Id members with + | Some old when old <> mem -> true, Map.add mem.Id mem members + | _ -> false, members + peersUpdated, setPeers peers state + + // ** updateMembers + + let updateMembers (f: RaftMember -> RaftMember) state = + state + |> logicalPeers + |> Map.fold + (fun (current, state') _ mem -> + let updated, state'' = updateMember (f mem) state' + current || updated, state'') + (false, state) + + // ** setNextIndex + + /// Set the nextIndex field on Member corresponding to supplied Id (should it exist, that is). + + let setNextIndex (nid : MemberId) idx (state: RaftState) = + let mem = getMember nid state + let nextIdx = if idx < 1 then 1 else idx + match mem with + | Some mem -> + mem + |> Member.setNextIndex nextIdx + |> flip updateMember state + | _ -> false, state + + // ** setMatchIndex + + /// Set the matchIndex field on Member to supplied index. + + let setMatchIndex nid idx (state: RaftState) = + let mem = getMember nid state + match mem with + | Some peer -> + peer + |> Member.setMatchIndex idx + |> flip updateMember state + | _ -> false, state + + // ** setLeader + + /// Set States CurrentLeader field to supplied MemberId. + + let setLeader (leader : MemberId option) (state: RaftState) = + if leader <> state.CurrentLeader then + let peers = + Map.map + (fun id peer -> + if Some id = leader + then Member.setState Leader peer + else Member.setState Follower peer) + state.Peers + let state = + state + |> setCurrentLeader leader + |> setPeers peers + true, state + else false, state + + // ** voteFor + + let voteFor (mem: RaftMember option) = + mem + |> Option.map Member.id + |> setVotedFor + + // ** setVoting + + let setVoting (mem: RaftMember) (vote: bool) = + mem + |> Member.setVotedForMe vote + |> updateMember + + // ** addMember + + /// Adds a mem to the list of known Members and increments NumMembers counter + + let addMember (mem: RaftMember) state = + state + |> peers + |> Map.add mem.Id mem + |> flip setPeers state + + // ** addNonVotingMember + + /// Add a Non-voting Peer to the list of known Members + + let addNonVotingMember = + Member.setVoting false >> Member.setStatus Joining >> addMember + + // ** removeMember + + /// Remove a Peer from the list of known Members and decrement NumMembers counter + let removeMember (mem: RaftMember) (state: RaftState) = + state + |> peers + |> Map.remove mem.Id + |> flip setPeers state + + // ** applyChanges + + let applyChanges changes state = + let folder _state = function + | MemberAdded mem -> addNonVotingMember mem _state + | MemberRemoved mem -> removeMember mem _state + Array.fold folder state changes + + // ** addMembers + + let addMembers mems state = + Map.fold (fun m _ n -> addMember n m) state mems + + // ** setMemberState + + let setMemberState mem memstate state = + match getMember mem state with + | Some mem -> + mem + |> Member.setState memstate + |> flip updateMember state + | _ -> false, state + + // ** resetVotes + + let resetVotes state = + let reset = Map.map (fun _ -> Member.setVotedForMe false) + { state with + Peers = reset state.Peers + OldPeers = Option.map reset state.OldPeers } + + // ** votedForMyself + + let votedForMyself (state: RaftState) = + match state.VotedFor with + | Some(nid) -> nid = state.Member.Id + | _ -> false + + // ** votingMembersForConfig + + let votingMembersForConfig peers = + let counter r _ n = + if Member.isVoting n then r + 1 else r + Map.fold counter 0 peers + + // ** votingMembers + + let votingMembers = peers >> votingMembersForConfig + + // ** votingMembersForOldConfig + + let votingMembersForOldConfig = + oldPeers + >> Option.map votingMembersForConfig + >> Option.defaultValue 0 + + // ** numLogs + + let numLogs = log >> Log.length + + // ** firstIndex + + let firstIndex term = log >> Log.firstIndex term + + // ** getLeader + + let getLeader state = + state + |> currentLeader + |> Option.bind (flip getMember state) + + // ** requestTimedOut + + let requestTimedOut (state: RaftState) : bool = + state.RequestTimeout <= state.TimeoutElapsed + + // ** electionTimedOut + + let electionTimedOut (state: RaftState) : bool = + state.ElectionTimeout <= state.TimeoutElapsed + + // ** lastLogTerm + + let lastLogTerm = log >> Log.term + + // ** entryAt + + let entryAt idx = log >> Log.at idx + + // ** entriesUntil + + let entriesUntil idx = log >> Log.until idx + + // ** entriesUntilExcluding + + let entriesUntilExcluding idx = log >> Log.untilExcluding idx + + // ** updateCommitIndex + + let updateCommitIndex (state: RaftState) = + setCommitIndex + $ if numMembers state = 1 + then currentIndex state + else commitIndex state + $ state + + // ** calculateChanges + + let calculateChanges (oldPeers: Map) (newPeers: Map) = + let oldmems = Map.toArray oldPeers |> Array.map snd + let newmems = Map.toArray newPeers |> Array.map snd + + let additions = + Array.fold + (fun lst (newmem: RaftMember) -> + match Array.tryFind (Member.id >> (=) newmem.Id) oldmems with + | Some _ -> lst + | _ -> MemberAdded(newmem) :: lst) [] newmems + + Array.fold + (fun lst (oldmem: RaftMember) -> + match Array.tryFind (Member.id >> (=) oldmem.Id) newmems with + | Some _ -> lst + | _ -> MemberRemoved(oldmem) :: lst) additions oldmems + |> List.toArray + + // ** majority + + /// Determine the majority from a total number of eligible voters and their respective votes. This + /// function is generic and should expect any numeric types. + /// + /// Turning off the warning about the cast due to sufficiently constrained requirements on the + /// input type (op_Explicit, comparison and division). + /// + /// ### Signature: + /// - total: the total number of votes cast + /// - yays: the number of yays in this election + + let majority total yays = + if total = 0 || yays = 0 then + false + elif yays > total then + false + else + yays > (total / 2) + + // ** numVotesForConfig + + let numVotesForConfig (self: RaftMember) (votedFor: MemberId option) peers = + let counter m _ (peer : RaftMember) = + if (peer.Id <> self.Id) && Member.canVote peer + then m + 1 + else m + + let start = + match votedFor with + | Some(nid) -> if nid = self.Id then 1 else 0 + | _ -> 0 + + Map.fold counter start peers + + // ** numVotesForMe + + let numVotesForMe (state: RaftState) = + numVotesForConfig state.Member state.VotedFor state.Peers + + // ** numVotesForMeOldConfig + + let numVotesForMeOldConfig (state: RaftState) = + match state.OldPeers with + | Some peers -> numVotesForConfig state.Member state.VotedFor peers + | _ -> 0 + + // ** handleConfiguration + + let handleConfiguration mems (state: RaftState) = + let parting = + mems + |> Array.map Member.id + |> Array.contains state.Member.Id + |> not + + let peers = + if parting + // we have been kicked out of the configuration + then Map [(state.Member.Id, state.Member)] + // we are still part of the new cluster configuration + else + mems + |> Array.map toPair + |> Map.ofArray + + state + |> RaftState.setPeers peers + |> RaftState.setOldPeers None + + // ** handleJointConsensus + + let handleJointConsensus (changes) (state:RaftState) = + state + |> RaftState.applyChanges changes + |> RaftState.setOldPeers (Some state.Peers) + + // ** selfIncluded + + let selfIncluded state = Map.containsKey state.MemberId state.Peers diff --git a/src/Disco/Disco/Raft/Types.fs b/src/Disco/Disco/Raft/Types.fs index 04cee80e..5cc11976 100644 --- a/src/Disco/Disco/Raft/Types.fs +++ b/src/Disco/Disco/Raft/Types.fs @@ -12,34 +12,29 @@ open System open System.Net open Disco.Core open Disco.Serialization +open Aether +open Aether.Operators open FlatBuffers -#if !FABLE_COMPILER && !DISCO_NODES - -open SharpYaml.Serialization - -#endif - // * EntryResponse /// Response to an AppendEntry request -/// -/// ## Constructor: -/// - `Id` - the generated unique identified for the entry -/// - `Term` - the entry's term -/// - `Index` - the entry's index in the log + type EntryResponse = - { Id : LogId - Term : Term - Index : Index } + { Id: LogId + Term: Term + Index: Index } // ** ToString + override self.ToString() = sprintf "Entry added with Id: %A in term: %d at log index: %d" (string self.Id) self.Term self.Index + // ** ToOffset + member self.ToOffset(builder: FlatBufferBuilder) = let id = EntryResponseFB.CreateIdVector(builder,self.Id.ToByteArray()) EntryResponseFB.StartEntryResponseFB(builder) @@ -48,37 +43,57 @@ type EntryResponse = EntryResponseFB.AddIndex(builder, int self.Index) EntryResponseFB.EndEntryResponseFB(builder) + // ** FromFB + static member FromFB(fb: EntryResponseFB) = - either { + result { let! id = Id.decodeId fb return { Id = id - Term = term fb.Term - Index = index fb.Index + Term = 1 * fb.Term + Index = 1 * fb.Index } } -// * Entry + // ** optics + + static member Id_ = + (fun (er: EntryResponse) -> er.Id), + (fun id (er: EntryResponse) -> { er with Id = id }) + + static member Term_ = + (fun (er: EntryResponse) -> er.Term), + (fun term (er: EntryResponse) -> { er with Term = term }) + + static member Index_ = + (fun (er: EntryResponse) -> er.Index), + (fun index (er: EntryResponse) -> { er with Index = index }) + +// * EntryResponse module [] -module Entry = - // ** id - let inline id (er : EntryResponse) = er.Id +module EntryResponse = - // ** term - let inline term (er : EntryResponse) = er.Term + // ** getting - // ** index - let inline index (er : EntryResponse) = er.Index + let id = Optic.get EntryResponse.Id_ + let term = Optic.get EntryResponse.Term_ + let index = Optic.get EntryResponse.Index_ -// * VoteRequest + // ** setting + + let setId = Optic.set EntryResponse.Id_ + let setTerm = Optic.set EntryResponse.Term_ + let setIndex = Optic.set EntryResponse.Index_ + + // ** create + + let create term index : EntryResponse = + { Id = DiscoId.Create() + Term = term + Index = index } -// __ __ _ ____ _ -// \ \ / /__ | |_ ___| _ \ ___ __ _ _ _ ___ ___| |_ -// \ \ / / _ \| __/ _ \ |_) / _ \/ _` | | | |/ _ \/ __| __| -// \ V / (_) | || __/ _ < __/ (_| | |_| | __/\__ \ |_ -// \_/ \___/ \__\___|_| \_\___|\__, |\__,_|\___||___/\__| -// |_| +// * VoteRequest /// Request to Vote for a new Leader /// @@ -87,6 +102,7 @@ module Entry = /// - `Candidate` - the unique mem id of candidate for leadership /// - `LastLogIndex` - the index of the candidates last log entry /// - `LastLogTerm` - the index of the candidates last log entry + type VoteRequest = { Term : Term Candidate : RaftMember @@ -94,6 +110,7 @@ type VoteRequest = LastLogTerm : Term } // ** ToOffset + member self.ToOffset(builder: FlatBufferBuilder) = let mem = self.Candidate.ToOffset(builder) VoteRequestFB.StartVoteRequestFB(builder) @@ -104,58 +121,92 @@ type VoteRequest = VoteRequestFB.EndVoteRequestFB(builder) // ** FromFB - static member FromFB (fb: VoteRequestFB) : Either = - either { + + static member FromFB (fb: VoteRequestFB): DiscoResult = + result { let candidate = fb.Candidate if candidate.HasValue then let! mem = RaftMember.FromFB candidate.Value - return { Term = term fb.Term + return { Term = 1 * fb.Term Candidate = mem - LastLogIndex = index fb.LastLogIndex - LastLogTerm = term fb.LastLogTerm } + LastLogIndex = 1 * fb.LastLogIndex + LastLogTerm = 1 * fb.LastLogTerm } else return! "Could not parse empty MemberFB" |> Error.asParseError "VoteRequest.FromFB" - |> Either.fail + |> Result.fail } -// * VoteResponse + // ** optics + + static member Term_ = + (fun (vr:VoteRequest) -> vr.Term), + (fun term (vr:VoteRequest) -> { vr with Term = term }) + + static member Candidate_ = + (fun (vr:VoteRequest) -> vr.Candidate), + (fun candidate (vr:VoteRequest) -> { vr with Candidate = candidate }) + + static member LastLogIndex_ = + (fun (vr:VoteRequest) -> vr.LastLogIndex), + (fun lastLogIndex (vr:VoteRequest) -> { vr with LastLogIndex = lastLogIndex }) + + static member LastLogTerm_ = + (fun (vr:VoteRequest) -> vr.LastLogTerm), + (fun lastLogTerm (vr:VoteRequest) -> { vr with LastLogTerm = lastLogTerm }) -// __ __ _ ____ -// \ \ / /__ | |_ ___| _ \ ___ ___ _ __ ___ _ __ ___ ___ -// \ \ / / _ \| __/ _ \ |_) / _ \/ __| '_ \ / _ \| '_ \/ __|/ _ \ -// \ V / (_) | || __/ _ < __/\__ \ |_) | (_) | | | \__ \ __/ -// \_/ \___/ \__\___|_| \_\___||___/ .__/ \___/|_| |_|___/\___| -// |_| +// * VoteRequest module + +module VoteRequest = + + // ** getters + + let term = Optic.get VoteRequest.Term_ + let candidate = Optic.get VoteRequest.Candidate_ + let lastLogIndex = Optic.get VoteRequest.LastLogIndex_ + let lastLogTerm = Optic.get VoteRequest.LastLogTerm_ + + // ** setters + + let setTerm = Optic.set VoteRequest.Term_ + let setCandidate = Optic.set VoteRequest.Candidate_ + let setLastLogIndex = Optic.set VoteRequest.LastLogIndex_ + let setLastLogTerm = Optic.set VoteRequest.LastLogIndex_ + +// * VoteResponse /// Result of a vote /// /// ## Result: /// - `Term` - current term for candidate to apply /// - `Granted` - result of vote + type VoteResponse = { Term : Term Granted : bool Reason : DiscoError option } // ** FromFB - static member FromFB (fb: VoteResponseFB) : Either = - either { + + static member FromFB (fb: VoteResponseFB): DiscoResult = + result { let! reason = let reason = fb.Reason if reason.HasValue then DiscoError.FromFB reason.Value - |> Either.map Some + |> Result.map Some else - Right None - - return { Term = term fb.Term - Granted = fb.Granted - Reason = reason } + Ok None + return { + Term = 1 * fb.Term + Granted = fb.Granted + Reason = reason + } } // ** ToOffset + member self.ToOffset(builder: FlatBufferBuilder) = let err = Option.map (fun (r: DiscoError) -> r.ToOffset(builder)) self.Reason VoteResponseFB.StartVoteResponseFB(builder) @@ -166,39 +217,43 @@ type VoteResponse = VoteResponseFB.AddGranted(builder, self.Granted) VoteResponseFB.EndVoteResponseFB(builder) + // ** optics -// * module Vote -[] -module Vote = + static member Term_ = + (fun (vr:VoteResponse) -> vr.Term), + (fun term (vr:VoteResponse) -> { vr with Term = term }) + + static member Granted_ = + (fun (vr:VoteResponse) -> vr.Granted), + (fun granted (vr:VoteResponse) -> { vr with Granted = granted }) - // ** term - let inline term (vote : VoteRequest) = vote.Term + static member Reason_ = + (fun (vr:VoteResponse) -> vr.Reason), + (fun reason (vr:VoteResponse) -> { vr with Reason = reason }) - // ** candiate - let inline candidate (vote : VoteRequest) = vote.Candidate +// * VoteResponse module - // ** lastLogIndex - let inline lastLogIndex (vote : VoteRequest) = vote.LastLogIndex +[] +module VoteResponse = + + // ** getters - // ** lastLogTerm - let inline lastLogTerm (vote : VoteRequest) = vote.LastLogTerm + let term = Optic.get VoteResponse.Term_ + let granted = Optic.get VoteResponse.Granted_ + let reason = Optic.get VoteResponse.Reason_ - // ** granted - let inline granted (vote : VoteResponse) = vote.Granted + // ** setters + + let setTerm = Optic.set VoteResponse.Term_ + let setGranted = Optic.set VoteResponse.Granted_ + let setReason = Optic.set VoteResponse.Reason_ // ** declined - let inline declined (vote : VoteResponse) = not vote.Granted + let declined = granted >> not // * AppendEntries -// _ _ _____ _ _ -// / \ _ __ _ __ ___ _ __ __| | ____|_ __ | |_ _ __(_) ___ ___ -// / _ \ | '_ \| '_ \ / _ \ '_ \ / _` | _| | '_ \| __| '__| |/ _ \/ __| -// / ___ \| |_) | |_) | __/ | | | (_| | |___| | | | |_| | | | __/\__ \ -// /_/ \_\ .__/| .__/ \___|_| |_|\__,_|_____|_| |_|\__|_| |_|\___||___/ -// |_| |_| - /// AppendEntries message. /// /// This message is used to tell mems if it's safe to apply entries to the @@ -210,12 +265,13 @@ module Vote = /// - `PrevLogIdx` - the index of the log just before the newest entry for the mem who receive this message /// - `PrevLogTerm` - the term of the log just before the newest entry for the mem who receives this message /// - `LeaderCommit`- the index of the entry that has been appended to the majority of the cluster. Entries up to this index will be applied to the FSM + type AppendEntries = { Term : Term PrevLogIdx : Index PrevLogTerm : Term LeaderCommit : Index - Entries : RaftLogEntry option } + Entries : LogEntry option } // ** optics @@ -240,31 +296,33 @@ type AppendEntries = (fun entries (ae:AppendEntries) -> { ae with Entries = entries }) // ** FromFB - static member FromFB (fb: AppendEntriesFB) : Either = - either { + + static member FromFB (fb: AppendEntriesFB): DiscoResult = + result { let! entries = if fb.EntriesLength = 0 then - Either.succeed None + Result.succeed None else let raw = Array.zeroCreate fb.EntriesLength for i in 0 .. (fb.EntriesLength - 1) do let entry = fb.Entries(i) if entry.HasValue then raw.[i] <- entry.Value - RaftLogEntry.FromFB raw + LogEntry.FromFB raw - return { Term = term fb.Term - PrevLogIdx = index fb.PrevLogIdx - PrevLogTerm = term fb.PrevLogTerm - LeaderCommit = index fb.LeaderCommit + return { Term = 1 * fb.Term + PrevLogIdx = 1 * fb.PrevLogIdx + PrevLogTerm = 1 * fb.PrevLogTerm + LeaderCommit = 1 * fb.LeaderCommit Entries = entries } } // ** ToOffset + member self.ToOffset(builder: FlatBufferBuilder) = let entries = Option.map - (fun (entries: RaftLogEntry) -> + (fun (entries: LogEntry) -> let offsets = entries.ToOffset(builder) AppendEntriesFB.CreateEntriesVector(builder, offsets)) self.Entries @@ -280,14 +338,33 @@ type AppendEntries = AppendEntriesFB.EndAppendEntriesFB(builder) -// * AppendResponse +// * AppendRequest module -// _ _ ____ -// / \ _ __ _ __ ___ _ __ __| | _ \ ___ ___ _ __ ___ _ __ ___ ___ -// / _ \ | '_ \| '_ \ / _ \ '_ \ / _` | |_) / _ \/ __| '_ \ / _ \| '_ \/ __|/ _ \ -// / ___ \| |_) | |_) | __/ | | | (_| | _ < __/\__ \ |_) | (_) | | | \__ \ __/ -// /_/ \_\ .__/| .__/ \___|_| |_|\__,_|_| \_\___||___/ .__/ \___/|_| |_|___/\___| -// |_| |_| |_| +module AppendEntries = + + // ** getters + + let term = Optic.get AppendEntries.Term_ + let prevLogIdx = Optic.get AppendEntries.PrevLogIdx_ + let prevLogTerm = Optic.get AppendEntries.PrevLogTerm_ + let leaderCommit = Optic.get AppendEntries.LeaderCommit_ + let entries = Optic.get AppendEntries.Entries_ + + // ** setters + + let setTerm = Optic.set AppendEntries.Term_ + let setPrevLogIdx = Optic.set AppendEntries.PrevLogIdx_ + let setPrevLogTerm = Optic.set AppendEntries.PrevLogTerm_ + let setLeaderCommit = Optic.set AppendEntries.LeaderCommit_ + let setEntries = Optic.set AppendEntries.Entries_ + + // ** numEntries + + let numEntries = entries >> function + | Some entries -> LogEntry.depth entries + | _ -> 0 + +// * AppendResponse /// Appendentries response message. /// @@ -299,6 +376,7 @@ type AppendEntries = /// - `Success` - true if follower contained entry matching prevLogidx and prevLogTerm /// - `CurrentIdx` - This is the highest log IDX we've received and appended to our log /// - `FirstIdx` - The first idx that we received within the appendentries message + type AppendResponse = { Term : Term Success : bool @@ -324,13 +402,17 @@ type AppendResponse = (fun firstIndex (ar:AppendResponse) -> { ar with FirstIndex = firstIndex }) // ** FromFB - static member FromFB (fb: AppendResponseFB) : Either = - Right { Term = term fb.Term - Success = fb.Success - CurrentIndex = index fb.CurrentIndex - FirstIndex = index fb.FirstIndex } + + static member FromFB (fb: AppendResponseFB) = + Result.succeed { + Term = 1 * fb.Term + Success = fb.Success + CurrentIndex = 1 * fb.CurrentIndex + FirstIndex = 1 * fb.FirstIndex + } // ** ToOffset + member self.ToOffset(builder: FlatBufferBuilder) = AppendResponseFB.StartAppendResponseFB(builder) AppendResponseFB.AddTerm(builder, int self.Term) @@ -339,42 +421,10 @@ type AppendResponse = AppendResponseFB.AddCurrentIndex(builder, int self.CurrentIndex) AppendResponseFB.EndAppendResponseFB(builder) -// * module AppendRequest - -[] -module AppendRequest = - - open Aether - - // ** getters - - let term = Optic.get AppendEntries.Term_ - let prevLogIdx = Optic.get AppendEntries.PrevLogIdx_ - let prevLogTerm = Optic.get AppendEntries.PrevLogTerm_ - let leaderCommit = Optic.get AppendEntries.LeaderCommit_ - let entries = Optic.get AppendEntries.Entries_ - - // ** setters - - let setTerm = Optic.set AppendEntries.Term_ - let setPrevLogIdx = Optic.set AppendEntries.PrevLogIdx_ - let setPrevLogTerm = Optic.set AppendEntries.PrevLogTerm_ - let setLeaderCommit = Optic.set AppendEntries.LeaderCommit_ - let setEntries = Optic.set AppendEntries.Entries_ - - // ** numEntries - - let inline numEntries ar = - match ar.Entries with - | Some entries -> LogEntry.depth entries - | _ -> 0 - -// * AppendResponse +// * AppendResponse module module AppendResponse = - open Aether - // ** getters let term = Optic.get AppendResponse.Term_ @@ -411,7 +461,29 @@ type InstallSnapshot = LeaderId: MemberId LastIndex: Index LastTerm: Term - Data: RaftLogEntry } + Data: LogEntry } + + // ** optics + + static member Term_ = + (fun (is:InstallSnapshot) -> is.Term), + (fun term (is:InstallSnapshot) -> { is with Term = term }) + + static member LeaderId_ = + (fun (is:InstallSnapshot) -> is.LeaderId), + (fun leaderId (is:InstallSnapshot) -> { is with LeaderId = leaderId }) + + static member LastIndex_ = + (fun (is:InstallSnapshot) -> is.LastIndex), + (fun lastIndex (is:InstallSnapshot) -> { is with LastIndex = lastIndex }) + + static member LastTerm_ = + (fun (is:InstallSnapshot) -> is.LastTerm), + (fun lastTerm (is:InstallSnapshot) -> { is with LastTerm = lastTerm }) + + static member Data_ = + (fun (is:InstallSnapshot) -> is.Data), + (fun data (is:InstallSnapshot) -> { is with Data = data }) // ** ToOffset @@ -429,7 +501,7 @@ type InstallSnapshot = // ** FromFB static member FromFB (fb: InstallSnapshotFB) = - either { + result { let! decoded = if fb.DataLength > 0 then let raw = Array.zeroCreate fb.DataLength @@ -437,265 +509,45 @@ type InstallSnapshot = let data = fb.Data(i) if data.HasValue then raw.[i] <- data.Value - RaftLogEntry.FromFB raw + LogEntry.FromFB raw else "Invalid InstallSnapshot (no log data)" |> Error.asParseError "InstallSnapshot.FromFB" - |> Either.fail + |> Result.fail match decoded with | Some entries -> let! leaderId = Id.decodeLeaderId fb return { - Term = term fb.Term + Term = 1 * fb.Term LeaderId = leaderId - LastIndex = index fb.LastIndex - LastTerm = term fb.LastTerm + LastIndex = 1 * fb.LastIndex + LastTerm = 1 * fb.LastTerm Data = entries } | _ -> return! "Invalid InstallSnapshot (no log data)" |> Error.asParseError "InstallSnapshot.FromFB" - |> Either.fail + |> Result.fail } -// * Callback Interface - -///////////////////////////////////////////////// -// ____ _ _ _ _ // -// / ___|__ _| | | |__ __ _ ___| | __ // -// | | / _` | | | '_ \ / _` |/ __| |/ / // -// | |__| (_| | | | |_) | (_| | (__| < // -// \____\__,_|_|_|_.__/ \__,_|\___|_|\_\ // -// // -// ___ _ __ // -// |_ _|_ __ | |_ ___ _ __ / _| __ _ ___ ___ // -// | || '_ \| __/ _ \ '__| |_ / _` |/ __/ _ \ // -// | || | | | || __/ | | _| (_| | (_| __/ // -// |___|_| |_|\__\___|_| |_| \__,_|\___\___| // -///////////////////////////////////////////////// - -type IRaftCallbacks = - - /// Request a vote from given Raft server - abstract member SendRequestVote: peer:RaftMember -> request:VoteRequest -> unit - - /// Send AppendEntries message to given server - abstract member SendAppendEntries: peer:RaftMember -> request:AppendEntries -> unit - - /// Send InstallSnapshot command to given serve - abstract member SendInstallSnapshot: peer:RaftMember -> request:InstallSnapshot -> unit - - /// given the current state of Raft, prepare and return a snapshot value of - /// current application state - abstract member PrepareSnapshot: current:RaftState -> RaftLog option - - /// perist the given Snapshot value to disk. For safety reasons this MUST - /// flush all changes to disk. - abstract member PersistSnapshot: snapshot:RaftLogEntry -> unit - - /// attempt to load a snapshot from disk. return None if no snapshot was found - abstract member RetrieveSnapshot: unit -> RaftLogEntry option - - /// apply the given command to state machine - abstract member ApplyLog: command:StateMachine -> unit - - /// a new server was added to the configuration - abstract member MemberAdded: peer:RaftMember -> unit - - /// a new server was added to the configuration - abstract member MemberUpdated: peer:RaftMember -> unit - - /// a server was removed from the configuration - abstract member MemberRemoved: peer:RaftMember -> unit - - /// a cluster configuration transition was successfully applied - abstract member Configured: members:RaftMember array -> unit - - /// a cluster configuration transition was successfully applied - abstract member JointConsensus: changes:ConfigChange array -> unit - - /// the state of Raft itself has changed from old state to new given state - abstract member StateChanged: oldstate:MemberState -> newstate:MemberState -> unit - - /// the leader node changed - abstract member LeaderChanged: leader:MemberId option -> unit - - /// persist vote data to disk. For safety reasons this callback MUST flush - /// the change to disk. - abstract member PersistVote: peer:RaftMember option -> unit - - /// persist term data to disk. For safety reasons this callback MUST flush - /// the change to disk> - abstract member PersistTerm: term:Term -> unit - - /// persist an entry added to the log to disk. For safety reasons this - /// callback MUST flush the change to disk. - abstract member PersistLog: log:RaftLogEntry -> unit - - /// persist the removal of the passed entry from the log to disk. For safety - /// reasons this callback MUST flush the change to disk. - abstract member DeleteLog: log:RaftLogEntry -> unit - -// * RaftStateYaml - -type RaftStateYaml() = - [] val mutable Member : string - [] val mutable Term : Term - [] val mutable Leader : string - [] val mutable VotedFor : string - [] val mutable ElectionTimeout : int - [] val mutable RequestTimeout : int - [] val mutable MaxLogDepth : int - -// * RaftState - -type RaftState = - { /// this server's own RaftMember information - Member : RaftMember - /// this server's current Raft state, i.e. follower, leader or candidate - State : MemberState - /// the server's current term, a monotonic counter for election cycles - CurrentTerm : Term - /// tracks the current Leader Id, or None if there isn't currently a leader - CurrentLeader : MemberId option - /// map of all known members in the cluster - Peers : Map - /// map of the previous cluster configuration. set if currently in a configuration change - OldPeers : Map option - /// count of all members in the cluster - NumMembers : int - /// the candidate this server voted for in its current term or None if it hasn't voted for any - /// other member yet - VotedFor : MemberId option - /// the replicated state machine command log - Log : RaftLog - /// index of latest log entry known to be committed - CommitIndex : Index - /// index of latest log entry applied to state machine - LastAppliedIdx : Index - /// amount of time left until a new election will be called - TimeoutElapsed : Timeout - /// amount of time that needs to pass before a new election is called - ElectionTimeout : Timeout - /// amount of time to pass until we consider requests to be failed - RequestTimeout : Timeout - /// maximum log depth to reach before automatic snapshotting triggers - MaxLogDepth : int - /// the log entry which has a voting configuration change, otherwise None - ConfigChangeEntry : RaftLogEntry option } - - // ** ToString - - override self.ToString() = - sprintf "Member = %s -State = %A -CurrentTerm = %A -CurrentLeader = %A -NumMembers = %A -VotedFor = %A -MaxLogDepth = %A -CommitIndex = %A -LastAppliedIdx = %A -TimeoutElapsed = %A -ElectionTimeout = %A -RequestTimeout = %A -ConfigChangeEntry = %s -" - (self.Member.ToString()) - self.State - self.CurrentTerm - self.CurrentLeader - self.NumMembers - self.VotedFor - self.MaxLogDepth - self.CommitIndex - self.LastAppliedIdx - self.TimeoutElapsed - self.ElectionTimeout - self.RequestTimeout - (if Option.isSome self.ConfigChangeEntry then - Option.get self.ConfigChangeEntry |> string - else Constants.EMPTY) - - // ** IsLeader - - member self.IsLeader - with get () = - match self.CurrentLeader with - | Some lid -> self.Member.Id = lid - | _ -> false - - // ** ToYaml - - #if !FABLE_COMPILER && !DISCO_NODES - - member self.ToYaml() = - let yaml = RaftStateYaml() - yaml.Member <- string self.Member.Id - yaml.Term <- self.CurrentTerm - - Option.map - (fun leader -> yaml.Leader <- string leader) - self.CurrentLeader - |> ignore - - Option.map - (fun voted -> yaml.VotedFor <- string voted) - self.VotedFor - |> ignore - - yaml.ElectionTimeout <- int self.ElectionTimeout - yaml.RequestTimeout <- int self.RequestTimeout - yaml.MaxLogDepth <- self.MaxLogDepth - yaml - - // ** FromYaml - - static member FromYaml (yaml: RaftStateYaml) : Either = - either { - let! id = DiscoId.TryParse yaml.Member - - let! leader = - if isNull yaml.Leader - then Right None - else DiscoId.TryParse yaml.Leader |> Either.map Some +// * InstallSnapshot module - let! votedfor = - if isNull yaml.VotedFor - then Right None - else DiscoId.TryParse yaml.VotedFor |> Either.map Some +module InstallSnapshot = - return { - Member = Member.create id - State = Follower - CurrentTerm = yaml.Term - CurrentLeader = leader - Peers = Map.empty - OldPeers = None - NumMembers = 0 - VotedFor = votedfor - Log = Log.empty - CommitIndex = index 0 - LastAppliedIdx = index 0 - TimeoutElapsed = 0 - ElectionTimeout = yaml.ElectionTimeout * 1 - RequestTimeout = yaml.RequestTimeout * 1 - MaxLogDepth = yaml.MaxLogDepth - ConfigChangeEntry = None - } - } - - #endif - -// * RaftMonad + // ** getters -[] -type RaftMonad<'Env,'State,'T,'Error> = - MkRM of ('Env -> 'State -> Either<'Error * 'State,'T * 'State>) + let term = Optic.get InstallSnapshot.Term_ + let leaderId = Optic.get InstallSnapshot.LeaderId_ + let lastIndex = Optic.get InstallSnapshot.LastIndex_ + let lastTerm = Optic.get InstallSnapshot.LastTerm_ + let data = Optic.get InstallSnapshot.Data_ -// * RaftM + // ** setters -type RaftM<'t,'err> = - RaftMonad + let setTerm = Optic.set InstallSnapshot.Term_ + let setLeaderId = Optic.set InstallSnapshot.LeaderId_ + let setLastIndex = Optic.set InstallSnapshot.LastIndex_ + let setLastTerm = Optic.set InstallSnapshot.LastTerm_ + let setData = Optic.set InstallSnapshot.Data_ diff --git a/src/Disco/Disco/RaspberryPi/Main.fs b/src/Disco/Disco/RaspberryPi/Main.fs index ac9e6150..ab499fc7 100644 --- a/src/Disco/Disco/RaspberryPi/Main.fs +++ b/src/Disco/Disco/RaspberryPi/Main.fs @@ -147,7 +147,7 @@ module Main = let client = ApiClient.create server client match client.Start() with - | Right () -> + | Ok () -> let gpio = startUpdater() let obs = client.Subscribe (handleWith pinid gpio.Update) @@ -194,7 +194,7 @@ module Main = dispose client exit 0 - | Left error -> + | Error error -> Console.Error.WriteLine("Encountered error starting client: {0}", Error.toMessage error) Console.Error.WriteLine("Aborting.") error diff --git a/src/Disco/Disco/Service/ApiServer.fs b/src/Disco/Disco/Service/ApiServer.fs index 1c026cd7..ec0d034f 100644 --- a/src/Disco/Disco/Service/ApiServer.fs +++ b/src/Disco/Disco/Service/ApiServer.fs @@ -113,9 +113,9 @@ module ApiServer = |> state.Server.Request (Guid.ofId client) // match result with - // | Right ApiResponse.OK -> () + // | Ok ApiResponse.OK -> () - // | Right (ApiResponse.NOK error) -> + // | Ok (ApiResponse.NOK error) -> // error // |> string // |> Error.asClientError (tag "requestInstallSnapshot") @@ -124,7 +124,7 @@ module ApiServer = // |> Msg.SetClientStatus // |> agent.Post - // | Right other -> + // | Ok other -> // other // |> sprintf "Unexpected reply from Client %A" // |> Error.asClientError (tag "requestInstallSnapshot") @@ -133,7 +133,7 @@ module ApiServer = // |> Msg.SetClientStatus // |> agent.Post - // | Left error -> + // | Error error -> // error // |> string // |> Error.asClientError (tag "requestInstallSnapshot") @@ -147,7 +147,7 @@ module ApiServer = let private processSubscriptionEvent (mem: PeerId) (agent: ApiAgent) = function | PubSubEvent.Request(id, bytes) -> match Binary.decode bytes with - | Right command -> + | Ok command -> match command with // Special case for tests: // @@ -167,7 +167,7 @@ module ApiServer = | CallCue _ | UpdateSlices _ -> Msg.Update(Origin.Api, command) |> agent.Post | _ -> () - | Left _ -> () // not sure if I should log here.. + | Error _ -> () // not sure if I should log here.. // ** handleStart @@ -324,7 +324,7 @@ module ApiServer = let private handleServerRequest (state: ServerState) (req: Request) (agent: ApiAgent) = match req.Body |> Binary.decode with - | Right (Register client) -> + | Ok (Register client) -> client.Id |> sprintf "%O requested to be registered" |> Logger.info (tag "handleServerRequest") @@ -338,7 +338,7 @@ module ApiServer = |> Response.fromRequest req |> state.Server.Respond - | Right (UnRegister client) -> + | Ok (UnRegister client) -> client.Id |> sprintf "%O requested to be un-registered" |> Logger.info (tag "handleServerRequest") @@ -352,15 +352,15 @@ module ApiServer = |> Response.fromRequest req |> state.Server.Respond - | Right (Update sm) -> + | Ok (Update sm) -> let id = DiscoId.FromGuid req.PeerId (Origin.Client id, sm) |> Msg.Update |> agent.Post - | Right _ -> () // ignore Ping et al + | Ok _ -> () // ignore Ping et al - | Left error -> + | Error error -> error |> String.format "error decoding request: {0}" |> Logger.err (tag "handleServerRequest") @@ -390,7 +390,7 @@ module ApiServer = // | \| | | | | ' / // | |\ | |_| | . \ // |_| \_|\___/|_|\_\ - | Right (ApiResponse.NOK error) -> + | Ok (ApiResponse.NOK error) -> error |> sprintf "NOK in client request. reason: %O" |> Logger.err (tag "handleClientResponse") @@ -400,14 +400,14 @@ module ApiServer = |> Msg.SetClientStatus |> agent.Post - | Right (ApiResponse.Registered _) - | Right (ApiResponse.Unregistered _) -> () + | Ok (ApiResponse.Registered _) + | Ok (ApiResponse.Unregistered _) -> () // ____ _ _____ // | _ \ ___ ___ ___ __| | ___ | ____|_ __ _ __ ___ _ __ // | | | |/ _ \/ __/ _ \ / _` |/ _ \ | _| | '__| '__/ _ \| '__| // | |_| | __/ (_| (_) | (_| | __/ | |___| | | | | (_) | | // |____/ \___|\___\___/ \__,_|\___| |_____|_| |_| \___/|_| - | Left error -> + | Error error -> error |> sprintf "error returned in client request. reason: %O" |> Logger.err (tag "handleClientResponse") @@ -480,10 +480,10 @@ module ApiServer = // ** start - let private start (mem: RaftMember) + let private start (mem: ClusterMember) (store: IAgentStore) (agent: ApiAgent) = - either { + result { let pubsub = PubSub.create mem let server = TcpServer.create { @@ -493,9 +493,9 @@ module ApiServer = } match server.Start() with - | Right () -> + | Ok () -> match pubsub.Start() with - | Right () -> + | Ok () -> let srv = server.Subscribe (Msg.ServerEvent >> agent.Post) let pbsb = pubsub.Subscribe(processSubscriptionEvent mem.Id agent) @@ -510,19 +510,19 @@ module ApiServer = agent.Start() agent.Post Msg.Start - | Left error -> + | Error error -> dispose server dispose pubsub - return! Either.fail error + return! Result.fail error - | Left error -> - return! Either.fail error + | Error error -> + return! Result.fail error } // ** create - let create (mem: RaftMember) callbacks = - either { + let create (mem: ClusterMember) callbacks = + result { let cts = new CancellationTokenSource() let store = AgentStore.create () diff --git a/src/Disco/Disco/Service/AssetService.fs b/src/Disco/Disco/Service/AssetService.fs index 55cf6194..3cd9466e 100644 --- a/src/Disco/Disco/Service/AssetService.fs +++ b/src/Disco/Disco/Service/AssetService.fs @@ -296,8 +296,8 @@ module AssetService = // ** create let create (machine: DiscoMachine) = - either { - do! Directory.createDirectory machine.AssetDirectory |> Either.map ignore + result { + do! Directory.createDirectory machine.AssetDirectory |> Result.map ignore let subscriptions = Subscriptions() let store = AgentStore.create() @@ -321,9 +321,9 @@ module AssetService = flusher <- Periodically.run 2000 (flushClock agent) agent |> startCrawler machine - |> Either.succeed + |> Result.succeed - member self.Stop() = Either.nothing + member self.Stop() = Result.nothing member self.State = store.State.Files @@ -352,7 +352,7 @@ let machine = AssetFilter = ".file" } -let service = AssetService.create machine |> Either.get +let service = AssetService.create machine |> Result.get service.Subscribe (printfn "%O") service.Start() diff --git a/src/Disco/Disco/Service/CommandActions.fs b/src/Disco/Disco/Service/CommandActions.fs index 681c76f1..06a43513 100644 --- a/src/Disco/Disco/Service/CommandActions.fs +++ b/src/Disco/Disco/Service/CommandActions.fs @@ -21,7 +21,7 @@ open System.Collections.Concurrent // * Channel -type private Channel = AsyncReplyChannel> +type private Channel = AsyncReplyChannel> // * tag @@ -44,18 +44,18 @@ let private serializeJson = /// -XPOST \ /// -d '"GetServiceInfo"' \ /// http://localhost:7000/api/command -let getServiceInfo (disco: IDisco): Either = - let notLoaded () = null |> serializeJson |> Either.succeed +let getServiceInfo (disco: IDisco): DiscoResult = + let notLoaded () = null |> serializeJson |> Result.succeed match disco.DiscoService with | Some service -> match Config.findMember service.Config disco.Machine.MachineId with - | Right mem -> + | Ok mem -> { webSocket = sprintf "ws://%O:%i" mem.IpAddress mem.WsPort version = Build.VERSION buildNumber = Build.BUILD_NUMBER } |> serializeJson - |> Either.succeed - | Left _ -> notLoaded() + |> Result.succeed + | Error _ -> notLoaded() | None -> notLoaded() // * listProjects @@ -68,34 +68,34 @@ let getServiceInfo (disco: IDisco): Either = /// -d '"ListProjects"' \ /// http://localhost:7000/api/command /// -let listProjects (cfg: DiscoMachine): Either = +let listProjects (cfg: DiscoMachine): DiscoResult = cfg.WorkSpace |> Directory.getDirectories |> Array.choose (fun dir -> match DiscoProject.Load(dir, cfg) with - | Right project -> + | Ok project -> project.Name |> String.format "Found valid project \"{0}\" in current WorkSpace." |> Logger.info (tag "listProjects") Some { Name = project.Name; Id = project.Id } - | Left _ -> + | Error _ -> dir |> String.format "\"{0}\" does not contain a valid project.yaml" |> Logger.info (tag "listProjects") None) |> serializeJson - |> Either.succeed + |> Result.succeed // * buildProject /// Create a new DiscoProject data structure with given parameters. let buildProject (machine: DiscoMachine) - (name: string) - (path: FilePath) - (raftDir: FilePath) - (mem: RaftMember) = - either { - let! project = Project.create (Project.ofFilePath path) name machine + (name: string) + (path: FilePath) + (raftDir: FilePath) + (mem: ClusterMember) = + result { + let! project = Project.create path name machine let site = let def = ClusterConfig.Default @@ -104,7 +104,7 @@ let buildProject (machine: DiscoMachine) let updated = project |> Project.updateDataDir raftDir - |> fun p -> Project.updateConfig (Config.addSiteAndSetActive site p.Config) p + |> fun p -> Project.setConfig (Config.addSiteAndSetActive site p.Config) p let! _ = DiscoData.saveWithCommit path User.Admin.Signature updated @@ -119,7 +119,7 @@ let buildProject (machine: DiscoMachine) /// Given the user (usually the admin user) and Project value, initialize the Raft intermediate /// state in the data directory and commit the result to git. -let initializeRaft (project: DiscoProject) = either { +let initializeRaft (project: DiscoProject) = result { let! raft = createRaft project.Config let! _ = saveRaft project.Config raft return () @@ -127,7 +127,7 @@ let initializeRaft (project: DiscoProject) = either { // * createProject -let createProject (machine: DiscoMachine) (opts: CreateProjectOptions) = either { +let createProject (machine: DiscoMachine) (opts: CreateProjectOptions) = result { let dir = machine.WorkSpace filepath opts.name let raftDir = dir filepath RAFT_DIRECTORY @@ -135,13 +135,13 @@ let createProject (machine: DiscoMachine) (opts: CreateProjectOptions) = either do! if Directory.exists dir then rmDir dir - else Either.nothing + else Result.nothing do! mkDir dir do! mkDir raftDir let mem = - { Member.create(machine.MachineId) with + { ClusterMember.create(machine.MachineId) with IpAddress = IpAddress.Parse opts.ipAddr GitPort = port opts.gitPort WsPort = port opts.wsPort @@ -157,13 +157,13 @@ let createProject (machine: DiscoMachine) (opts: CreateProjectOptions) = either // * getProjectSites let getProjectSites machine projectName = - either { + result { let! path = Project.checkPath machine projectName let! (state: State) = Asset.loadWithMachine path machine // TODO: Check username and password? return state.Project.Config.Sites - |> Array.map (fun x -> { Name = x.Name; Id = x.Id }) + |> Map.map (fun id x -> { Name = x.Name; Id = id }) |> serializeJson } @@ -182,7 +182,7 @@ let machineStatus (disco: IDisco) = | Some service -> Busy(service.Project.Id, service.Project.Name) | None -> MachineStatus.Idle |> serializeJson - |> Either.succeed + |> Result.succeed // * machineConfig @@ -196,7 +196,7 @@ let machineStatus (disco: IDisco) = let machineConfig () = MachineConfig.get() |> serializeJson - |> Either.succeed + |> Result.succeed // * cloneProject @@ -213,7 +213,7 @@ let cloneProject (name: Name) (uri: Url) = let target = machine.WorkSpace filepath (unwrap name) let success = sprintf "Successfully cloned project from: %A" uri Git.Repo.clone target (unwrap uri) - |> Either.map (konst (serializeJson success)) + |> Result.map (konst (serializeJson success)) // * pullProject @@ -225,7 +225,7 @@ let cloneProject (name: Name) (uri: Url) = /// -XPOST \ /// -d '{"PullProject":["dfb6eff5-e4b8-465d-9ad0-ee58bd508cad","meh","git://192.168.2.106:6000/meh/.git"]}' \ /// http://localhost:7000/api/command -let pullProject (id: string) (name: Name) (uri: Url) = either { +let pullProject (id: string) (name: Name) (uri: Url) = result { let machine = MachineConfig.get() let target = machine.WorkSpace filepath (unwrap name) use! repo = Git.Repo.repository target @@ -246,7 +246,7 @@ let pullProject (id: string) (name: Name) (uri: Url) = either { return! "Clonflict while pulling from " + unwrap uri |> Error.asGitError "pullProject" - |> Either.fail + |> Result.fail | _ -> return sprintf "Successfully pulled changes from: %A" url @@ -272,8 +272,8 @@ let startAgent (cfg: DiscoMachine) (disco: IDisco) = dispose disco exit 0 } - Right "Disposing service..." - | Command.UnloadProject -> disco.UnloadProject() |> Either.map (konst "Project unloaded") + Ok "Disposing service..." + | Command.UnloadProject -> disco.UnloadProject() |> Result.map (konst "Project unloaded") | ListProjects -> listProjects cfg | GetServiceInfo -> getServiceInfo disco | MachineStatus -> machineStatus disco @@ -281,7 +281,7 @@ let startAgent (cfg: DiscoMachine) (disco: IDisco) = | CreateProject opts -> createProject cfg opts | SaveProject -> disco.SaveProject() - |> Either.map (fun _ -> "Successfully saved project") + |> Result.map (fun _ -> "Successfully saved project") | CloneProject (name, gitUri) -> cloneProject name gitUri | PullProject (id, name, gitUri) -> pullProject id name gitUri | LoadProject(projectName, Some { Id = siteId; Name = name }) -> @@ -290,14 +290,14 @@ let startAgent (cfg: DiscoMachine) (disco: IDisco) = Measure.name Constants.ADMIN_USER_NAME, Measure.password Constants.ADMIN_DEFAULT_PASSWORD, Some (name, siteId)) - |> Either.map (fun _ -> "Loaded project " + unwrap projectName) + |> Result.map (fun _ -> "Loaded project " + unwrap projectName) | LoadProject(projectName, _) -> disco.LoadProject( projectName, Measure.name Constants.ADMIN_USER_NAME, Measure.password Constants.ADMIN_DEFAULT_PASSWORD, None) - |> Either.map (fun _ -> "Loaded project " + unwrap projectName) + |> Result.map (fun _ -> "Loaded project " + unwrap projectName) | GetProjectSites projectName -> getProjectSites cfg projectName replyChannel.Reply res @@ -310,7 +310,7 @@ let startAgent (cfg: DiscoMachine) (disco: IDisco) = let postCommand (agent: (MailboxProcessor option) ref) (cmd: Command) = let err msg = - Error.asOther (tag "postCommand") msg |> Either.fail + Error.asOther (tag "postCommand") msg |> Result.fail match !agent with | Some agent -> async { diff --git a/src/Disco/Disco/Service/CommandLine.fs b/src/Disco/Disco/Service/CommandLine.fs index 8a3378a6..5a9f78d0 100644 --- a/src/Disco/Disco/Service/CommandLine.fs +++ b/src/Disco/Disco/Service/CommandLine.fs @@ -148,7 +148,7 @@ module CommandLine = (machine: DiscoMachine) (projectDir: FilePath option) (frontend: FilePath option) = - either { + result { let agentRef = ref None let post = CommandActions.postCommand agentRef let termSupportsColors = Console.isColorTerm() @@ -158,10 +158,11 @@ module CommandLine = Tier = Tier.Service UseColors = termSupportsColors Level = LogLevel.Debug + Fields = LogEventFields.Default } - + do! Metrics.init machine - + use _ = Logger.subscribe Logger.stdout let! discoService = Disco.create post { @@ -183,9 +184,9 @@ module CommandLine = Commands.Command.LoadProject(name, site) |> CommandActions.postCommand agentRef |> Async.RunSynchronously - |> Either.map ignore + |> Result.map ignore | None -> - Either.succeed () + Result.succeed () do vmSetup () @@ -218,6 +219,6 @@ module CommandLine = let help () = parser.PrintUsage(header, "disco.exe", true) |> flip (printfn "%s\n%s") SubCommand.Doc - |> Either.succeed + |> Result.succeed #endif diff --git a/src/Disco/Disco/Service/Disco.fs b/src/Disco/Disco/Service/Disco.fs index 0c6804ae..a3463bf2 100644 --- a/src/Disco/Disco/Service/Disco.fs +++ b/src/Disco/Disco/Service/Disco.fs @@ -54,13 +54,13 @@ module Disco = let ids = Array.map Member.id mems if not (Array.contains disco.Machine.MachineId ids) then match disco.UnloadProject() with - | Right () -> Logger.info "onShutdown" "Unloaded project" - | Left error -> Logger.err "onShutdown" error.Message + | Ok () -> Logger.info "onShutdown" "Unloaded project" + | Error error -> Logger.err "onShutdown" error.Message | _ -> () // ** create - let create post (options: DiscoOptions) = either { + let create post (options: DiscoOptions) = result { let status = ref ServiceStatus.Stopped let disco = ref None let eventSubscription = ref None @@ -71,9 +71,9 @@ module Disco = let! discovery = options.Machine |> DiscoveryService.create - |> fun service -> service.Start() |> Either.map (konst service) - |> Either.map Some - |> Either.orElse None + |> fun service -> service.Start() |> Result.map (konst service) + |> Result.map Some + |> Result.orElse None do! httpServer.Start() return { @@ -90,7 +90,7 @@ module Disco = member self.DiscoService with get () = !disco - member self.LoadProject(name, username, password, site) = either { + member self.LoadProject(name, username, password, site) = result { status := ServiceStatus.Starting Option.iter dispose !disco // in case there was already something loaded Option.iter dispose !eventSubscription // and its subscription as well @@ -103,16 +103,16 @@ module Disco = SiteId = site } match discoService.Start() with - | Right () -> + | Ok () -> eventSubscription := subscribeDiscovery discoService discovery shutdownSubscription := self |> onShutdown |> discoService.Subscribe |> Some let mem = discoService.RaftServer.Raft.Member disco := Some discoService status := ServiceStatus.Running return () - | Left error -> + | Error error -> status := ServiceStatus.Failed error - return! Either.fail error + return! Result.fail error } member self.SaveProject() = @@ -121,13 +121,13 @@ module Disco = AppCommand.Save |> StateMachine.Command |> disco.Append - |> Either.succeed + |> Result.succeed | None -> "No project loaded" |> Error.asOther (tag "Save") - |> Either.fail + |> Result.fail - member self.UnloadProject() = either { + member self.UnloadProject() = result { match !disco, !eventSubscription with | Some discoService, subscription -> Option.iter dispose !shutdownSubscription @@ -140,7 +140,7 @@ module Disco = return! "No project was loaded" |> Error.asOther (tag "UnloadProject") - |> Either.fail + |> Result.fail } member self.Dispose() = diff --git a/src/Disco/Disco/Service/DiscoService.fs b/src/Disco/Disco/Service/DiscoService.fs index aaf6d2da..e6f6e22b 100644 --- a/src/Disco/Disco/Service/DiscoService.fs +++ b/src/Disco/Disco/Service/DiscoService.fs @@ -62,7 +62,7 @@ module DiscoService = [] type private DiscoState = - { Member: RaftMember + { Member: ClusterMember Machine: DiscoMachine Status: ServiceStatus Store: Store @@ -114,11 +114,11 @@ module DiscoService = /// Persiste a state machine command to disk and log results. let private persistWithLogging (store: IAgentStore) sm = match Persistence.persistEntry store.State.Store.State sm with - | Right () -> + | Ok () -> string sm |> String.format "Successfully persisted command {0} to disk" |> Logger.debug (tag "statePersistor") - | Left error -> + | Error error -> error |> String.format "Error persisting command to disk: {0}" |> Logger.err (tag "statePersistor") @@ -137,7 +137,8 @@ module DiscoService = fun _ _ -> function | DiscoEvent.Append(_, Command AppCommand.Undo) -> store.State.Store.Undo() | DiscoEvent.Append(_, Command AppCommand.Redo) -> store.State.Store.Redo() - | DiscoEvent.Append(_, cmd) -> store.State.Store.Dispatch cmd + | DiscoEvent.Append(_, LogMsg _) -> () + | DiscoEvent.Append(_, cmd) -> do store.State.Store.Dispatch cmd | _ -> () // ** statePersistor @@ -150,32 +151,40 @@ module DiscoService = | DiscoEvent.Append(_, sm) when sm.PersistenceStrategy = PersistenceStrategy.Commit -> if isLeader store then do persistWithLogging store sm - let state= store.State + + let state = store.State + // ____ _ _ // / ___|___ _ __ ___ _ __ ___ (_) |_ // | | / _ \| '_ ` _ \| '_ ` _ \| | __| // | |__| (_) | | | | | | | | | | | | |_ // \____\___/|_| |_| |_|_| |_| |_|_|\__| - match Persistence.commitChanges state.Store.State with - | Right (repo, commit) -> - commit.Sha - |> String.format "Successfully committed changes in: {0}" - |> Logger.debug (tag "statePersistor") - repo - |> Persistence.ensureRemotes - state.RaftServer.MemberId - state.Store.State.Project - state.RaftServer.Raft.Peers - |> Persistence.pushChanges - |> Map.iter - (fun name err -> - sprintf "could not push to %s: %O" name err - |> Logger.err (tag "statePersistor")) - dispose repo - | Left error -> - error + match Config.getMembers state.Store.State.Project.Config with + | Error error -> + error.Message |> String.format "Error committing changes to disk: {0}" |> Logger.err (tag "statePersistor") + | Ok members -> + match Persistence.commitChanges state.Store.State with + | Ok (repo, commit) -> + commit.Sha + |> String.format "Successfully committed changes in: {0}" + |> Logger.debug (tag "statePersistor") + repo + |> Persistence.ensureRemotes + state.RaftServer.MemberId + state.Store.State.Project + members + |> Persistence.pushChanges + |> Map.iter + (fun name err -> + sprintf "could not push to %s: %O" name err + |> Logger.err (tag "statePersistor")) + dispose repo + | Error error -> + error + |> String.format "Error committing changes to disk: {0}" + |> Logger.err (tag "statePersistor") | _ -> () // ** mappingResolver @@ -255,8 +264,8 @@ module DiscoService = match cmd with | DiscoEvent.Append(_, LogMsg log) -> match LogFile.write store.State.LogFile log with - | Right _ -> () - | Left error -> + | Ok _ -> () + | Error error -> error |> string |> Logger.err (tag "logPersistor") @@ -317,31 +326,6 @@ module DiscoService = }) | _ -> () - // ** preActions - - let private preActions (store: IAgentStore) = - [| Pipeline.createHandler (stateMutator store) - Pipeline.createHandler (pinResetHandler store) |] - - // ** processors - - let private processors (store: IAgentStore) = - [| Pipeline.createHandler (statePersistor store) - Pipeline.createHandler (mappingResolver store) - Pipeline.createHandler (logPersistor store) |] - - // ** publishers - - let private publishers (store: IAgentStore) = - [| Pipeline.createHandler (createPublisher store.State.ApiServer) - Pipeline.createHandler (createPublisher store.State.SocketServer) - Pipeline.createHandler (commandResolver store) |] - - // ** postActions - - let private postActions (store: IAgentStore) = - [| Pipeline.createHandler (subscriptionNotifier store) |] - // ** sendLocalData /// ## Send local data to leader upon connection. @@ -350,39 +334,39 @@ module DiscoService = /// browser sessions or locally connected client instances. These pieces of data need to be /// replicated to the leader once connected. IF those clients/sessions already exist, they /// will simply be ignored. + let private sendLocalData (socket: ITcpClient) (store: IAgentStore) = - if (store.State.SocketServer.Sessions.Count + store.State.ApiServer.Clients.Count) > 0 then - let sessions = - store.State.SocketServer.Sessions - |> Map.toList - |> List.map (snd >> AddSession) - let clients = - store.State.ApiServer.Clients - |> Map.toList - |> List.map (snd >> AddClient) - let tree = - store.State.AssetService.State - |> Option.map (fun tree -> [ AddFsTree tree ]) - |> Option.defaultValue List.empty - - let batch = List.concat [ sessions; clients; tree ] - - /// send a batched state machine command to leader if non-empty - if not (List.isEmpty batch) then - (clients.Length,sessions.Length) - |> String.format "sending batch command with {0} (clients,session) " - |> Logger.debug (tag "sendLocalData") - - batch - |> CommandBatch.ofList - |> RaftRequest.AppendEntry - |> Binary.encode - |> Request.create (Guid.ofId socket.ClientId) - |> socket.Request - else - store.State.RaftServer.RaftState - |> String.format "Nothing to send ({0})" + let mem = [ AddMember $ Machine.toClusterMember store.State.Machine ] + let sessions = + store.State.SocketServer.Sessions + |> Map.toList + |> List.map (snd >> AddSession) + let clients = + store.State.ApiServer.Clients + |> Map.toList + |> List.map (snd >> AddClient) + let tree = + store.State.AssetService.State + |> Option.map (fun tree -> [ AddFsTree tree ]) + |> Option.defaultValue List.empty + let batch = + List.concat [ + mem + sessions + clients + tree + ] + /// send a batched state machine command to leader if non-empty + if not (List.isEmpty batch) then + (clients.Length,sessions.Length) + |> String.format "sending batch command with {0} (clients,session) " |> Logger.debug (tag "sendLocalData") + batch + |> CommandBatch.ofList + |> RaftRequest.AppendEntry + |> Binary.encode + |> Request.create (Guid.ofId socket.ClientId) + |> socket.Request // ** handleLeaderEvents @@ -390,13 +374,13 @@ module DiscoService = /// command to append the locally connected clients and browser sessions to the leader. let private handleLeaderEvents socket store = function | TcpClientEvent.Connected _ -> sendLocalData socket store - | _ -> () + | e -> () // ** makeLeader /// Create a communication socket with the current Raft leader. Its important to note that /// the current members Id *must* be used to set up the client socket. - let private makeLeader (leader: RaftMember) (store: IAgentStore) = + let private makeLeader (leader:RaftMember) (store: IAgentStore) = let socket = TcpClient.create { Tag = "DiscoService.Leader.TcpClient" ClientId = store.State.Member.Id // IMPORTANT: this must be the current member's Id @@ -404,12 +388,58 @@ module DiscoService = PeerPort = leader.RaftPort Timeout = int Constants.REQ_TIMEOUT * 1 } - handleLeaderEvents socket store - |> socket.Subscribe - |> ignore - socket.Connect() + do handleLeaderEvents socket store + |> socket.Subscribe + |> ignore + do socket.Connect() Some { Member = leader; Socket = socket } + // ** maybeCreateLeader + + let private maybeCreateLeader (store: IAgentStore) = + let newLeader = + match store.State.Leader, store.State.RaftServer.Leader with + | Some { Member = currentLeader }, Some raftLeader -> + if currentLeader.Id <> raftLeader.Id && raftLeader.Id <> store.State.Member.Id + then + do Option.iter dispose store.State.Leader + // create redirect socket if we have new leader other than this current node + match Map.tryFind raftLeader.Id store.State.RaftServer.Raft.Peers with + | Some leader -> makeLeader leader store + | None -> + "Could not start re-direct socket: no leader" + |> Logger.debug (tag "maybeCreateLeader") + None + else + "Leader socket exists for current leader." + |> Logger.debug (tag "maybeCreateLeader") + store.State.Leader + | None, Some raftLeader -> + /// /// this service is currently leader, so append the local fstree + /// Option.iter + /// (AddFsTree >> DiscoEvent.appendService >> Pipeline.push pipeline) + /// store.State.AssetService.State + if raftLeader.Id <> store.State.Member.Id + then + // create redirect socket if we have new leader other than this current node + match Map.tryFind raftLeader.Id store.State.RaftServer.Raft.Peers with + | Some leader -> makeLeader leader store + | None -> + "Could not start re-direct socket: no leader" + |> Logger.debug (tag "maybeCreateLeader") + None + else + "Currently leader, not creating socket." + |> Logger.debug (tag "maybeCreateLeader") + store.State.Leader + | Some current, None -> + do dispose current + "No current leader, disposing current socket." + |> Logger.debug (tag "maybeCreateLeader") + None + | None, None -> None + store.Update { store.State with Leader = newLeader } + // ** processEvent /// ## Process DiscoEvents that have special semantics. @@ -417,9 +447,7 @@ module DiscoService = /// Events that need to be treated differently than normal state machine comand events come from /// RaftServer and are used to e.g. wire up communication with the leader for forwarding state /// machine commands to the leader. - let private processEvent (store: IAgentStore) pipeline ev = - Observable.onNext store.State.Subscriptions ev - match ev with + let private processEvent (store: IAgentStore) _ _ = function | DiscoEvent.EnterJointConsensus changes -> changes |> Array.map @@ -436,21 +464,6 @@ module DiscoService = |> Logger.debug (tag "processEvent") | DiscoEvent.ConfigurationDone mems -> - let ids = Array.map Member.id mems - let project = State.project store.State.Store.State - let config = Project.config project - match Config.getActiveSite config with - | None -> () /// this should ever happen - | Some activeSite -> - activeSite - |> ClusterConfig.members - |> Map.filter (fun id _ -> Array.contains id ids) - |> flip ClusterConfig.setMembers activeSite - |> flip Config.updateSite config - |> flip Project.updateConfig project - |> UpdateProject - |> DiscoEvent.appendService - |> Pipeline.push pipeline mems |> Array.map (Member.id >> string) |> Array.fold (fun s id -> s + " " + id) "New Configuration with: " @@ -465,37 +478,42 @@ module DiscoService = leader |> String.format "Leader changed to {0}" |> Logger.debug (tag "leaderChanged") + do maybeCreateLeader store - Option.iter dispose store.State.Leader - - let newLeader = - match leader with - | Some leaderId when leaderId <> store.State.Member.Id -> - // create redirect socket if we have new leader other than this current node - match store.State.RaftServer.Leader with - | Some leader -> makeLeader leader store - | None -> - "Could not start re-direct socket: no leader" - |> Logger.debug (tag "leaderChanged") - None - | Some _ -> - /// this service is currently leader, so append the local fstree - Option.iter - (AddFsTree >> DiscoEvent.appendService >> Pipeline.push pipeline) - store.State.AssetService.State - None - | None -> None - - store.Update { store.State with Leader = newLeader } - - | DiscoEvent.PersistSnapshot log -> - match Persistence.persistSnapshot store.State.Store.State log with - | Left error -> Logger.err (tag "persistSnapshot") (string error) - | _ -> () + | DiscoEvent.Append(_, DataSnapshot _) -> + match store.State.Leader with + | Some leader -> do sendLocalData leader.Socket store + | None -> do maybeCreateLeader store | DiscoEvent.RaftError error -> Logger.err (tag "processEvents") error.Message | _ -> () + // ** preActions + + let private preActions (store: IAgentStore) = + [| Pipeline.createHandler (stateMutator store) + Pipeline.createHandler (pinResetHandler store) |] + + // ** processors + + let private processors (store: IAgentStore) = + [| Pipeline.createHandler (statePersistor store) + Pipeline.createHandler (mappingResolver store) + Pipeline.createHandler (logPersistor store) |] + + // ** publishers + + let private publishers (store: IAgentStore) = + [| Pipeline.createHandler (createPublisher store.State.ApiServer) + Pipeline.createHandler (createPublisher store.State.SocketServer) + Pipeline.createHandler (commandResolver store) |] + + // ** postActions + + let private postActions (store: IAgentStore) = + [| Pipeline.createHandler (processEvent store) + Pipeline.createHandler (subscriptionNotifier store) |] + // ** forwardCommand let private forwardCommand (store: IAgentStore) cmd = @@ -526,11 +544,11 @@ module DiscoService = // | | | | __/ | | | | | |_) | __/ | \__ \ // |_| |_|\___|_| |_| |_|_.__/ \___|_| |___/ - | Append (_, AddMember mem) -> - if isLeader store then store.State.RaftServer.AddMember mem + | Append (_, AddMachine mem) -> + if isLeader store then store.State.RaftServer.AddMachine mem - | Append (_, RemoveMember mem) -> - if isLeader store then store.State.RaftServer.RemoveMember mem.Id + | Append (_, RemoveMachine mem) -> + if isLeader store then store.State.RaftServer.RemoveMachine mem.Id // ____ _ _ // / ___| ___ ___| | _____| |_ @@ -549,7 +567,7 @@ module DiscoService = | Append (Origin.Web id, AddSession session) -> session |> store.State.SocketServer.BuildSession id - |> Either.iter (AddSession >> handleAppend store) + |> Result.iter (AddSession >> handleAppend store) // replicate a RemoveSession command if the session exists | SessionClosed id -> @@ -587,10 +605,10 @@ module DiscoService = let private dispatchEvent store pipeline cmd = cmd |> dispatchStrategy |> function - | Process -> processEvent store pipeline cmd + | Process + | Publish -> publishEvent pipeline cmd | Replicate -> replicateEvent store cmd | Ignore -> Observable.onNext store.State.Subscriptions cmd - | Publish -> publishEvent pipeline cmd // ** createDispatcher @@ -624,20 +642,21 @@ module DiscoService = // ** retrieveSnapshot let private retrieveSnapshot (state: DiscoState) = - let path = Constants.RAFT_DIRECTORY <.> - Constants.SNAPSHOT_FILENAME + - Constants.ASSET_EXTENSION + let path = + Constants.RAFT_DIRECTORY <.> + Constants.SNAPSHOT_FILENAME + + Constants.ASSET_EXTENSION match DiscoData.read path with - | Right str -> + | Ok str -> try let yml = Yaml.deserialize str let id = DiscoId.Parse yml.Id let snapshot = DataSnapshot state.Store.State let members = match Config.getActiveSite state.Store.State.Project.Config with - | Some site -> site.Members |> Map.toArray |> Array.map snd + | Some site -> site.Members |> Map.toArray |> Array.map (snd >> ClusterMember.toRaftMember) | _ -> [| |] - (id,yml.Index ,yml.Term ,yml.LastIndex ,yml.LastTerm ,members , snapshot) + (id,yml.Index,yml.Term,yml.LastIndex,yml.LastTerm,members,snapshot) |> Snapshot |> Some with exn -> @@ -645,7 +664,7 @@ module DiscoService = |> Logger.err (tag "retrieveSnapshot") None - | Left error -> + | Error error -> error |> string |> Logger.err (tag "retrieveSnapshot") @@ -653,17 +672,17 @@ module DiscoService = // ** persistSnapshot - let private persistSnapshot (state: DiscoState) (log: RaftLogEntry) = + let private persistSnapshot (state: DiscoState) (log: LogEntry) = match Persistence.persistSnapshot state.Store.State log with - | Left error -> Logger.err (tag "persistSnapshot") (string error) - | _ -> () - state + | Error error -> Logger.err (tag "persistSnapshot") (string error) + | Ok () -> Logger.debug (tag "persistSnapshot") "successfully persisted snapshot" // ** makeRaftCallbacks let private makeRaftCallbacks (store: IAgentStore) = { new IRaftSnapshotCallbacks with member self.PrepareSnapshot () = Some store.State.Store.State + member self.PersistSnapshot log = persistSnapshot store.State log member self.RetrieveSnapshot () = retrieveSnapshot store.State } // ** makeApiCallbacks @@ -690,7 +709,7 @@ module DiscoService = | _ -> "Login rejected" |> Error.asProjectError (tag "loadProject") - |> Either.fail + |> Result.fail // ** updateSite @@ -699,7 +718,7 @@ module DiscoService = | Some (name, site) -> let site = state.Project.Config.Sites - |> Array.tryFind (fun s -> s.Id = site) + |> Map.tryFind site |> function | Some s -> s | None -> { ClusterConfig.Default with Name = name } @@ -711,8 +730,8 @@ module DiscoService = if Map.containsKey machineId site.Members then site else - let selfMember = - { Member.create(machineId) with + let selfMember: ClusterMember = + { ClusterMember.create(machineId) with IpAddress = serviceOptions.Machine.BindAddress GitPort = serviceOptions.Machine.GitPort WsPort = serviceOptions.Machine.WsPort @@ -727,7 +746,7 @@ module DiscoService = // ** makeState let private makeState store state serviceOptions _ = - either { + result { let subscriptions = Subscriptions() let state = updateSite state serviceOptions @@ -805,7 +824,7 @@ module DiscoService = // ** makeStore let private makeStore (serviceOptions: DiscoServiceOptions) = - either { + result { let store = AgentStore.create() let logDir = @@ -820,7 +839,7 @@ module DiscoService = let! (state: State) = serviceOptions.Machine |> Asset.loadWithMachine path - |> Either.map State.initialize + |> Result.map State.initialize let! updated = state.Users @@ -836,12 +855,12 @@ module DiscoService = // ** start let private start (store: IAgentStore) = - either { + result { store.State.Dispatcher.Start() // start all services let result = - either { + result { do! store.State.ApiServer.Start() do! store.State.SocketServer.Start() do! store.State.GitServer.Start() @@ -850,7 +869,7 @@ module DiscoService = } match result with - | Right _ -> + | Ok _ -> { store.State with Status = ServiceStatus.Running } |> store.Update @@ -858,7 +877,7 @@ module DiscoService = |> DiscoEvent.Status |> Observable.onNext store.State.Subscriptions return () - | Left error -> + | Error error -> { store.State with Status = ServiceStatus.Failed error } |> store.Update @@ -866,7 +885,7 @@ module DiscoService = |> DiscoEvent.Status |> Observable.onNext store.State.Subscriptions dispose store.State - return! Either.fail error + return! Result.fail error } // ** disposeService @@ -875,19 +894,19 @@ module DiscoService = dispose store.State // dispose the state store.Update { store.State with Status = ServiceStatus.Disposed } - // ** addMember + // ** addMachine - let private addMember (store: IAgentStore) (mem: RaftMember) = - AddMember mem + let private addMachine (store: IAgentStore) (mem: RaftMember) = + AddMachine mem |> DiscoEvent.appendService |> store.State.Dispatcher.Dispatch - // ** removeMember + // ** removeMachine - let private removeMember (store: IAgentStore) (id: MemberId) = + let private removeMachine (store: IAgentStore) (id: MemberId) = store.State.RaftServer.Raft.Peers |> Map.tryFind id - |> Option.iter (RemoveMember >> DiscoEvent.appendService >> store.State.Dispatcher.Dispatch) + |> Option.iter (RemoveMachine >> DiscoEvent.appendService >> store.State.Dispatcher.Dispatch) // ** append @@ -919,9 +938,9 @@ module DiscoService = member self.Periodic () = store.State.RaftServer.Periodic() - member self.AddMember mem = addMember store mem + member self.AddMachine mem = addMachine store mem - member self.RemoveMember id = removeMember store id + member self.RemoveMachine id = removeMachine store id member self.Append cmd = append store cmd @@ -948,28 +967,28 @@ module DiscoService = // member self.LeaveCluster () = // Tracing.trace (tag "LeaveCluster") <| fun () -> // match postCommand agent "LeaveCluster" Msg.Leave with - // | Right Reply.Ok -> Right () - // | Left error -> Left error - // | Right other -> + // | Ok Reply.Ok -> Ok () + // | Error error -> Error error + // | Ok other -> // String.format "Unexpected response from DiscoAgent: {0}" other // |> Error.asOther (tag "LeaveCluster") - // |> Either.fail + // |> Result.fail // member self.JoinCluster ip port = // Tracing.trace (tag "JoinCluster") <| fun () -> // match postCommand agent "JoinCluster" (fun chan -> Msg.Join(chan,ip, port)) with - // | Right Reply.Ok -> Right () - // | Left error -> Left error - // | Right other -> + // | Ok Reply.Ok -> Ok () + // | Error error -> Error error + // | Ok other -> // String.format "Unexpected response from DiscoAgent: {0}" other // |> Error.asOther (tag "JoinCluster") - // |> Either.fail + // |> Result.fail } // ** create let create (disco: DiscoServiceOptions) = - either { + result { let! store = makeStore disco return makeService store } diff --git a/src/Disco/Disco/Service/DiscoveryService.fs b/src/Disco/Disco/Service/DiscoveryService.fs index f5701fa7..ee9e5e5e 100644 --- a/src/Disco/Disco/Service/DiscoveryService.fs +++ b/src/Disco/Disco/Service/DiscoveryService.fs @@ -89,7 +89,7 @@ module DiscoveryService = |> Discovery.toDiscoveredService match service with - | Right parsed -> + | Ok parsed -> parsed.Id |> sprintf "resolved new service %O" |> Logger.debug (tag "addResolved") @@ -97,7 +97,7 @@ module DiscoveryService = parsed |> Msg.Discovered |> agent.Post - | Left _ -> () + | Error _ -> () // ** serviceAdded @@ -142,11 +142,11 @@ module DiscoveryService = let service = Discovery.toDiscoverableService discoverable service.Response.Add(serviceRegistered agent discoverable) service.Register() - Either.succeed service + Result.succeed service with | exn -> exn.Message |> Error.asOther (tag "registerService") - |> Either.fail + |> Result.fail // ** unregisterService @@ -165,12 +165,12 @@ module DiscoveryService = let browser = new ServiceBrowser() browser.ServiceAdded.AddHandler(new ServiceBrowseEventHandler(serviceAdded agent)) browser.ServiceRemoved.AddHandler(new ServiceBrowseEventHandler(serviceRemoved agent)) - browser |> Either.succeed + browser |> Result.succeed with | exn -> exn.Message |> Error.asOther (tag "makeBrowser") - |> Either.fail + |> Result.fail // ** handleStop @@ -205,8 +205,8 @@ module DiscoveryService = { ServiceType = ServiceType.WebSocket; Port = machine.WsPort } |] ExtraMetadata = Array.empty } match registerService agent discoverable with - | Right service -> { state with RegisterService = Some service } - | Left error -> + | Ok service -> { state with RegisterService = Some service } + | Error error -> error |> sprintf "error registering busy service: %O" |> Logger.err (tag "handleRegister") @@ -229,8 +229,8 @@ module DiscoveryService = { ServiceType = ServiceType.WebSocket; Port = machine.WsPort } |] ExtraMetadata = Array.empty } match registerService agent discoverable with - | Right service -> { state with RegisterService = Some service } - | Left error -> + | Ok service -> { state with RegisterService = Some service } + | Error error -> error |> sprintf "error registering idle service: %O" |> Logger.err (tag "handleUnRegister") @@ -316,14 +316,14 @@ module DiscoveryService = { new IDiscoveryService with member self.Start() = - either { + result { let! browser = makeBrowser agent store.Update { state with Browser = browser } do! try browser |> startBrowser - |> Either.succeed + |> Result.succeed with | exn -> tryDispose browser ignore @@ -334,7 +334,7 @@ module DiscoveryService = Logger.err (tag "Start") msg msg |> Error.asOther (tag "Start") - |> Either.fail + |> Result.fail agent.Post Msg.Start return () diff --git a/src/Disco/Disco/Service/GitServer.fs b/src/Disco/Disco/Service/GitServer.fs index d9ae090f..d951c796 100644 --- a/src/Disco/Disco/Service/GitServer.fs +++ b/src/Disco/Disco/Service/GitServer.fs @@ -118,7 +118,7 @@ module GitServer = // ** create - let create (mem: RaftMember) (project: DiscoProject) = + let create (mem: ClusterMember) (project: DiscoProject) = let mutable status = ServiceStatus.Stopped let cts = new CancellationTokenSource() let subscriptions = Subscriptions() @@ -130,7 +130,7 @@ module GitServer = member self.Subscribe(callback: DiscoEvent -> unit) = Observable.subscribe callback subscriptions - member self.Start () = either { + member self.Start () = result { do! Network.ensureIpAddress mem.IpAddress do! Network.ensureAvailability mem.IpAddress mem.GitPort diff --git a/src/Disco/Disco/Service/HttpServer.fs b/src/Disco/Disco/Service/HttpServer.fs index 7327991e..6d331e5c 100644 --- a/src/Disco/Disco/Service/HttpServer.fs +++ b/src/Disco/Disco/Service/HttpServer.fs @@ -129,9 +129,9 @@ module HttpServer = |> postCommand return match res with - | Left err -> + | Result.Error err -> Error.toMessage err |> Actions.respondWithCors ctx HTTP_500.status - | Right msg -> + | Ok msg -> msg |> Actions.respondWithCors ctx HTTP_200.status } choose [ @@ -154,7 +154,7 @@ module HttpServer = // ** makeConfig let private makeConfig machine (basePath: FilePath) (cts: CancellationTokenSource) = - either { + result { try let logger = let reg = Regex("\{(\w+)(?:\:(.*?))?\}") @@ -212,7 +212,7 @@ module HttpServer = // ** create let create (machine: DiscoMachine) (frontend: FilePath option) (postCommand: CommandAgent) = - either { + result { let status = ref ServiceStatus.Stopped let basePath = @@ -224,7 +224,7 @@ module HttpServer = return { new IHttpServer with - member self.Start () = either { + member self.Start () = result { try let _, server = basePath filepath "index.html" @@ -238,7 +238,7 @@ module HttpServer = return! exn.Message |> Error.asSocketError (tag "create") - |> Either.fail + |> Result.fail } member self.Dispose () = diff --git a/src/Disco/Disco/Service/Interfaces.fs b/src/Disco/Disco/Service/Interfaces.fs index f76ec3fa..6237976d 100644 --- a/src/Disco/Disco/Service/Interfaces.fs +++ b/src/Disco/Disco/Service/Interfaces.fs @@ -68,7 +68,7 @@ type IDiscoveryService = inherit IDisposable abstract Services: Map abstract Subscribe: (DiscoveryEvent -> unit) -> IDisposable - abstract Start: unit -> Either + abstract Start: unit -> DiscoResult abstract Register: project:DiscoProject -> unit abstract UnRegister: unit -> unit @@ -97,7 +97,7 @@ type IGitServer = inherit IDisposable abstract Status : ServiceStatus abstract Subscribe : (DiscoEvent -> unit) -> IDisposable - abstract Start : unit -> Either + abstract Start : unit -> DiscoResult // * IFsWatcher @@ -109,14 +109,15 @@ type IFsWatcher = type IRaftSnapshotCallbacks = abstract PrepareSnapshot: unit -> State option - abstract RetrieveSnapshot: unit -> RaftLogEntry option + abstract PersistSnapshot: LogEntry -> unit + abstract RetrieveSnapshot: unit -> LogEntry option // * IRaftServer type IRaftServer = inherit IDisposable inherit ISink - abstract Start : unit -> Either + abstract Start : unit -> DiscoResult abstract Member : RaftMember abstract MemberId : MemberId abstract Append : StateMachine -> unit @@ -124,8 +125,8 @@ type IRaftServer = abstract Status : ServiceStatus abstract Subscribe : (DiscoEvent -> unit) -> IDisposable abstract Periodic : unit -> unit - abstract AddMember : RaftMember -> unit - abstract RemoveMember : MemberId -> unit + abstract AddMachine : RaftMember -> unit + abstract RemoveMachine : MemberId -> unit abstract Connections : ConcurrentDictionary abstract Leader : RaftMember option abstract IsLeader : bool @@ -143,18 +144,18 @@ type IWebSocketServer = abstract Sessions : Map abstract Broadcast : StateMachine -> unit abstract Multicast : except:SessionId -> StateMachine -> unit - abstract BuildSession : SessionId -> Session -> Either + abstract BuildSession : SessionId -> Session -> Result abstract Subscribe : (DiscoEvent -> unit) -> System.IDisposable - abstract Start : unit -> Either + abstract Start : unit -> DiscoResult // * IAssetService type IAssetService = inherit IDisposable abstract State: FsTree option - abstract Start: unit -> Either + abstract Start: unit -> DiscoResult abstract Subscribe: (DiscoEvent -> unit) -> IDisposable - abstract Stop: unit -> Either + abstract Stop: unit -> DiscoResult // * IApiServerCallbacks @@ -166,7 +167,7 @@ type IApiServerCallbacks = type IApiServer = inherit IDisposable inherit ISink - abstract Start: unit -> Either + abstract Start: unit -> DiscoResult abstract Subscribe: (DiscoEvent -> unit) -> IDisposable abstract Clients: Map abstract SendSnapshot: unit -> unit @@ -176,7 +177,7 @@ type IApiServer = type IHttpServer = inherit System.IDisposable - abstract Start: unit -> Either + abstract Start: unit -> DiscoResult // * DiscoServiceOptions @@ -193,7 +194,7 @@ type DiscoServiceOptions = /// Interface type to close over internal actors and state. type IDiscoService = inherit IDisposable - abstract AddMember: RaftMember -> unit + abstract AddMachine: RaftMember -> unit abstract Append: StateMachine -> unit abstract Config: DiscoConfig with get, set abstract ForceElection: unit -> unit @@ -203,14 +204,14 @@ type IDiscoService = abstract Project: DiscoProject abstract RaftServer: IRaftServer abstract AssetService: IAssetService - abstract RemoveMember: MemberId -> unit + abstract RemoveMachine: MemberId -> unit abstract SocketServer: IWebSocketServer - abstract Start: unit -> Either + abstract Start: unit -> DiscoResult abstract State: State abstract Status: ServiceStatus abstract Subscribe: (DiscoEvent -> unit) -> IDisposable - // abstract JoinCluster : IpAddress -> uint16 -> Either - // abstract LeaveCluster : unit -> Either + // abstract JoinCluster : IpAddress -> uint16 -> DiscoResult + // abstract LeaveCluster : unit -> DiscoResult // * DiscoOptions @@ -227,6 +228,6 @@ type IDisco = abstract HttpServer: IHttpServer abstract DiscoveryService: IDiscoveryService option abstract DiscoService: IDiscoService option - abstract SaveProject: unit -> Either - abstract LoadProject: Name * UserName * Password * (Name * SiteId) option -> Either - abstract UnloadProject: unit -> Either + abstract SaveProject: unit -> DiscoResult + abstract LoadProject: Name * UserName * Password * (Name * SiteId) option -> DiscoResult + abstract UnloadProject: unit -> DiscoResult diff --git a/src/Disco/Disco/Service/Main.fs b/src/Disco/Disco/Service/Main.fs index b8db3443..ebe13de1 100644 --- a/src/Disco/Disco/Service/Main.fs +++ b/src/Disco/Disco/Service/Main.fs @@ -128,7 +128,7 @@ module Main = match target with | Some path when Directory.exists path && Directory.contains (path fileName) path -> match MachineConfig.load target with - | Right config -> config + | Ok config -> config | _ -> MachineConfig.create address None | _ -> MachineConfig.create address None @@ -150,14 +150,14 @@ module Main = if yes then MachineConfig.save target result - |> Either.map + |> Result.map (fun _ -> match target with | Some path -> printfn "Wrote machine configuration to: %A" path | None -> printfn "Wrote machine configuration to: ./etc/machinecfg.yaml") else printfn "Aborted." - Either.nothing + Result.nothing // ** setupDefaults @@ -184,13 +184,13 @@ module Main = match target with | Some path when Directory.exists path && Directory.contains (path fileName) path -> match MachineConfig.load target with - | Right config -> config + | Ok config -> config | _ -> MachineConfig.create address None | _ -> MachineConfig.create address None machine |> MachineConfig.save target - |> Either.map + |> Result.map (fun _ -> match target with | Some path -> printfn "Wrote machine configuration to: %A" path @@ -215,8 +215,8 @@ module Main = |> Option.map filepath |> MachineConfig.load match machine with - | Left error -> Error.exitWith error - | Right machine -> + | Error error -> Error.exitWith error + | Ok machine -> do MachineConfig.set machine let validation = MachineConfig.validate machine if not validation.IsEmpty then diff --git a/src/Disco/Disco/Service/NetUtils.fs b/src/Disco/Disco/Service/NetUtils.fs index c046e1b5..b9c56494 100644 --- a/src/Disco/Disco/Service/NetUtils.fs +++ b/src/Disco/Disco/Service/NetUtils.fs @@ -100,7 +100,7 @@ module NetUtils = /// - request: RaftRequest to send /// - client: client socket to use /// - /// Returns: Either + /// Returns: DiscoResult let performRequest (request: RaftRequest) (client: ITcpClient) = try rawRequest request client diff --git a/src/Disco/Disco/Service/Persistence.fs b/src/Disco/Disco/Service/Persistence.fs index 36bdaf2a..d7faebb0 100644 --- a/src/Disco/Disco/Service/Persistence.fs +++ b/src/Disco/Disco/Service/Persistence.fs @@ -35,18 +35,19 @@ module Persistence = /// ### Signature: /// - options: RaftOptions /// - /// Returns: Either + /// Returns: DiscoResult let createRaft (options: DiscoConfig) = - either { + result { let! mem = Config.selfMember options let! mems = Config.getMembers options let state = mem - |> Raft.create - |> Raft.addMembers mems - |> Raft.setMaxLogDepth options.Raft.MaxLogDepth - |> Raft.setRequestTimeout options.Raft.RequestTimeout - |> Raft.setElectionTimeout options.Raft.ElectionTimeout + |> ClusterMember.toRaftMember + |> RaftState.create + |> RaftState.addMembers (Map.map (fun _ -> ClusterMember.toRaftMember) mems) + |> RaftState.setMaxLogDepth options.Raft.MaxLogDepth + |> RaftState.setRequestTimeout options.Raft.RequestTimeout + |> RaftState.setElectionTimeout options.Raft.ElectionTimeout return state } @@ -62,9 +63,9 @@ module Persistence = /// ### Signature: /// - options: Project Config /// - /// Returns: Either - let loadRaft (options: DiscoConfig) : Either = - either { + /// Returns: DiscoResult + let loadRaft (options: DiscoConfig): DiscoResult = + result { let! mem = Config.selfMember options let! mems = Config.getMembers options let count = Map.fold (fun m _ _ -> m + 1) 0 mems @@ -75,9 +76,8 @@ module Persistence = let! state = Yaml.decode data return { state with - Member = mem - NumMembers = count - Peers = mems + MemberId = mem.Id + Peers = Map.map (fun _ -> ClusterMember.toRaftMember) mems MaxLogDepth = options.Raft.MaxLogDepth RequestTimeout = options.Raft.RequestTimeout ElectionTimeout = options.Raft.ElectionTimeout } @@ -93,10 +93,10 @@ module Persistence = /// ### Signature: /// - options: Project Config /// - /// Returns: Either + /// Returns: DiscoResult let getRaft (options: DiscoConfig) = match loadRaft options with - | Right raft -> Either.succeed raft + | Ok raft -> Result.succeed raft | _ -> createRaft options // ** saveRaft @@ -110,19 +110,19 @@ module Persistence = /// - config: DiscoConfig /// - raft: Raft state value /// - /// Returns: Either + /// Returns: DiscoResult let saveRaft (config: DiscoConfig) (raft: RaftState) = try raft |> Yaml.encode |> Payload |> DiscoData.write (Config.metadataPath config) - |> Either.succeed + |> Result.succeed with | exn -> sprintf "Project Save Error: %s" exn.Message |> Error.asProjectError "Persistence.saveRaft" - |> Either.fail + |> Result.fail // ** persistEntry @@ -134,7 +134,7 @@ module Persistence = /// - project: DiscoProject to work on /// - sm: StateMachine command /// - /// Returns: Either + /// Returns: DiscoResult let persistEntry (state: State) (sm: StateMachine) = let basePath = state.Project.Path let inline save t = Asset.save basePath t @@ -241,7 +241,7 @@ module Persistence = let path = PinGroup.absolutePath basePath pin.ClientId pin.PinGroupId if File.exists path then File.delete path - else Either.nothing + else Result.nothing | RemovePin pin -> @@ -254,7 +254,7 @@ module Persistence = let path = PinGroup.absolutePath basePath pin.ClientId pin.PinGroupId if File.exists path then File.delete path - else Either.nothing + else Result.nothing | Command AppCommand.Save -> save state @@ -264,7 +264,7 @@ module Persistence = // | |_| | |_| | | | __/ | // \___/ \__|_| |_|\___|_| - | _ -> Either.nothing + | _ -> Result.nothing // ** commitChanges @@ -276,9 +276,9 @@ module Persistence = /// - project: DiscoProject to work on /// - sm: StateMachine command /// - /// Returns: Either + /// Returns: DiscoResult let commitChanges (state: State) = - either { + result { let signature = User.Admin.Signature let! repo = state.Project |> Project.repository do! Git.Repo.stageAll repo @@ -292,14 +292,14 @@ module Persistence = repo |> Git.Config.remotes |> Map.map (konst (Git.Repo.push repo)) - |> Map.filter (konst (Either.isFail)) - |> Map.map (konst (Either.error)) + |> Map.filter (konst (Result.isFail)) + |> Map.map (konst (Result.error)) // ** persistSnapshot - let persistSnapshot (state: State) (log: RaftLogEntry) = - either { - let path = Project.toFilePath state.Project.Path + let persistSnapshot (state: State) (log: Disco.Raft.LogEntry) = + result { + let path = state.Project.Path do! state.Save(path) use! repo = Project.repository state.Project do! Git.Repo.stageAll repo @@ -312,8 +312,8 @@ module Persistence = // ** getRemote - let getRemote (project: DiscoProject) (repo: Repository) (leader: RaftMember) = - let uri = Uri.gitUri project.Name leader + let getRemote (project: DiscoProject) (repo: Repository) (leader: ClusterMember) = + let uri = Uri.gitUri project.Name leader.IpAddress leader.GitPort match Git.Config.tryFindRemote repo (string leader.Id) with | None -> leader.Id @@ -330,12 +330,12 @@ module Persistence = Git.Config.updateRemote repo remote uri | Some remote -> - Either.succeed remote + Result.succeed remote // ** ensureRemote - let ensureRemote (project: DiscoProject) (repo: Repository) (peer: RaftMember) = - let uri = Uri.gitUri project.Name peer + let ensureRemote (project: DiscoProject) (repo: Repository) (peer: ClusterMember) = + let uri = Uri.gitUri project.Name peer.IpAddress peer.GitPort match Git.Config.tryFindRemote repo (string peer.Id) with | None -> peer.Id @@ -352,13 +352,13 @@ module Persistence = Git.Config.updateRemote repo remote uri | Some remote -> - Either.succeed remote + Result.succeed remote // ** ensureRemotes let ensureRemotes (leader: MemberId) (project: DiscoProject) - (peers: Map) + (peers: Map) (repo: Repository) = peers |> Map.toArray @@ -372,6 +372,6 @@ module Persistence = if not (Git.Branch.isTracking branch) then Git.Branch.setTracked repo branch remote else - Either.nothing + Result.nothing #endif diff --git a/src/Disco/Disco/Service/RaftRequest.fs b/src/Disco/Disco/Service/RaftRequest.fs index 424fab4d..ded447b1 100644 --- a/src/Disco/Disco/Service/RaftRequest.fs +++ b/src/Disco/Disco/Service/RaftRequest.fs @@ -136,10 +136,10 @@ type RaftRequest = // ** FromBytes - static member FromBytes (bytes: byte array) : Either = + static member FromBytes (bytes: byte array) : DiscoResult = let msg = RaftMsgFB.GetRootAsRaftMsgFB(new ByteBuffer(bytes)) match msg.MsgType with - | RaftMsgTypeFB.RequestVoteFB -> either { + | RaftMsgTypeFB.RequestVoteFB -> result { let entry = msg.Msg() if entry.HasValue then let rv = entry.Value @@ -152,15 +152,15 @@ type RaftRequest = return! "Could not parse empty VoteRequestFB body" |> Error.asParseError "RaftRequest.FromBytes" - |> Either.fail + |> Result.fail else return! "Could not parse empty RequestVoteFB body" |> Error.asParseError "RaftRequest.FromBytes" - |> Either.fail + |> Result.fail } - | RaftMsgTypeFB.RequestAppendEntriesFB -> either { + | RaftMsgTypeFB.RequestAppendEntriesFB -> result { let entry = msg.Msg() if entry.HasValue then let ae = entry.Value @@ -173,15 +173,15 @@ type RaftRequest = return! "Could not parse empty AppendEntriesFB body" |> Error.asParseError "RaftRequest.FromBytes" - |> Either.fail + |> Result.fail else return! "Could not parse empty RequestAppendEntriesFB body" |> Error.asParseError "RaftRequest.FromBytes" - |> Either.fail + |> Result.fail } - | RaftMsgTypeFB.RequestInstallSnapshotFB -> either { + | RaftMsgTypeFB.RequestInstallSnapshotFB -> result { let entry = msg.Msg() if entry.HasValue then let is = entry.Value @@ -194,15 +194,15 @@ type RaftRequest = return! "Could not parse empty InstallSnapshotFB body" |> Error.asParseError "RaftRequest.FromBytes" - |> Either.fail + |> Result.fail else return! "Could not parse empty RequestInstallSnapshotFB body" |> Error.asParseError "RaftRequest.FromBytes" - |> Either.fail + |> Result.fail } - | RaftMsgTypeFB.RequestAppendEntryFB -> either { + | RaftMsgTypeFB.RequestAppendEntryFB -> result { let entry = msg.Msg() if entry.HasValue then let is = entry.Value @@ -214,15 +214,15 @@ type RaftRequest = return! "Could not parse empty AppendEntryFB body" |> Error.asParseError "RaftRequest.FromBytes" - |> Either.fail + |> Result.fail else return! "Could not parse empty RequestAppendEntryFB body" |> Error.asParseError "RaftRequest.FromBytes" - |> Either.fail + |> Result.fail } - // | RaftMsgTypeFB.HandShakeFB -> either { + // | RaftMsgTypeFB.HandShakeFB -> result { // let entry = msg.Msg() // if entry.HasValue then // let hs = entry.Value @@ -234,15 +234,15 @@ type RaftRequest = // return! // "Could not parse empty RaftMemberFB body" // |> Error.asParseError "RaftRequest.FromBytes" - // |> Either.fail + // |> Result.fail // else // return! // "Could not parse empty HandShakeFB body" // |> Error.asParseError "RaftRequest.FromBytes" - // |> Either.fail + // |> Result.fail // } - // | RaftMsgTypeFB.HandWaiveFB -> either { + // | RaftMsgTypeFB.HandWaiveFB -> result { // let entry = msg.Msg() // if entry.HasValue then // let hw = entry.Value @@ -254,18 +254,18 @@ type RaftRequest = // return! // "Could not parse empty RaftMemberFB body" // |> Error.asParseError "RaftRequest.FromBytes" - // |> Either.fail + // |> Result.fail // else // return! // "Could not parse empty HandShakeFB body" // |> Error.asParseError "RaftRequest.FromBytes" - // |> Either.fail + // |> Result.fail // } | x -> sprintf "Could not parse unknown RaftMsgTypeFB: %A" x |> Error.asParseError "RaftRequest.FromBytes" - |> Either.fail + |> Result.fail // * RaftResponse @@ -326,9 +326,9 @@ type RaftResponse = // ** FromFB - static member FromFB(msg: RaftMsgFB) : Either = + static member FromFB(msg: RaftMsgFB) : DiscoResult = match msg.MsgType with - | RaftMsgTypeFB.RespondVoteFB -> either { + | RaftMsgTypeFB.RespondVoteFB -> result { let entry = msg.Msg() if entry.HasValue then let fb = entry.Value @@ -341,15 +341,15 @@ type RaftResponse = return! "Could not parse empty VoteResponseFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail else return! "Could not parse empty RespondVoteFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail } - | RaftMsgTypeFB.RespondAppendEntriesFB -> either { + | RaftMsgTypeFB.RespondAppendEntriesFB -> result { let entry = msg.Msg() if entry.HasValue then let fb = entry.Value @@ -362,15 +362,15 @@ type RaftResponse = return! "Could not parse empty AppendResponseFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail else return! "Could not parse empty RespodnAppendEntriesFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail } - | RaftMsgTypeFB.RespondInstallSnapshotFB -> either { + | RaftMsgTypeFB.RespondInstallSnapshotFB -> result { let entry = msg.Msg() if entry.HasValue then let fb = entry.Value @@ -383,15 +383,15 @@ type RaftResponse = return! "Could not parse empty AppendResponseFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail else return! "Could not parse empty RespondInstallSnapshotFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail } - | RaftMsgTypeFB.RespondAppendEntryFB -> either { + | RaftMsgTypeFB.RespondAppendEntryFB -> result { let entry = msg.Msg() if entry.HasValue then let fb = entry.Value @@ -403,15 +403,15 @@ type RaftResponse = return! "Could not parse empty AppendResponseFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail else return! "Could not parse empty RespondInstallSnapshotFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail } - | RaftMsgTypeFB.ErrorResponseFB -> either { + | RaftMsgTypeFB.ErrorResponseFB -> result { let entry = msg.Msg() if entry.HasValue then let rv = entry.Value @@ -424,15 +424,15 @@ type RaftResponse = return! "Could not parse empty ErrorFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail else return! "Could not parse empty ErrorResponseFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail } - | RaftMsgTypeFB.RedirectFB -> either { + | RaftMsgTypeFB.RedirectFB -> result { let entry = msg.Msg() if entry.HasValue then let rd = entry.Value @@ -444,15 +444,15 @@ type RaftResponse = return! "Could not parse empty RaftMemberFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail else return! "Could not parse empty RedirectFB body" |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail } - // | RaftMsgTypeFB.WelcomeFB -> either { + // | RaftMsgTypeFB.WelcomeFB -> result { // let entry = msg.Msg() // if entry.HasValue then // let wl = entry.Value @@ -464,21 +464,21 @@ type RaftResponse = // return! // "Could not parse empty RaftMemberFB body" // |> Error.asParseError "RaftResponse.FromFB" - // |> Either.fail + // |> Result.fail // else // return! // "Could not parse empty WelcomeFB body" // |> Error.asParseError "RaftResponse.FromFB" - // |> Either.fail + // |> Result.fail // } // | RaftMsgTypeFB.ArrivederciFB -> - // Right Arrivederci + // Ok Arrivederci | x -> sprintf "Could not parse unknown RaftMsgTypeFB: %A" x |> Error.asParseError "RaftResponse.FromFB" - |> Either.fail + |> Result.fail // ** ToBytes @@ -486,6 +486,6 @@ type RaftResponse = // ** FromBytes - static member FromBytes (bytes: byte array) : Either = + static member FromBytes (bytes: byte array) : DiscoResult = let msg = RaftMsgFB.GetRootAsRaftMsgFB(ByteBuffer(bytes)) RaftResponse.FromFB msg diff --git a/src/Disco/Disco/Service/RaftServer.fs b/src/Disco/Disco/Service/RaftServer.fs index 5e6b6ce5..cafcbc1b 100644 --- a/src/Disco/Disco/Service/RaftServer.fs +++ b/src/Disco/Disco/Service/RaftServer.fs @@ -124,34 +124,15 @@ module rec RaftServer = // ** getMember - /// ## getMember - /// - /// Return the current mem. - /// - /// ### Signature: - /// - context: RaftServerState - /// - /// Returns: RaftMember - let private getMember (context: RaftServerState) = - context - |> getRaft - |> Raft.getSelf + /// Return the current RaftMember. + + let private getMember = getRaft >> RaftState.self // ** getMemberId - /// ## getMemberId - /// - /// Return the current mem Id. - /// - /// ### Signature: - /// - context: RaftServerState - /// - /// Returns: Id - let private getMemberId (context: RaftServerState) = - context - |> getRaft - |> Raft.getSelf - |> Member.id + /// Return the current RaftMember Id. + + let private getMemberId = getMember >> Member.id // ** updateRaft @@ -252,16 +233,12 @@ module rec RaftServer = |> sendRequest peer connections agent member self.PrepareSnapshot raft = - callbacks.PrepareSnapshot () - |> Option.map (DataSnapshot >> Raft.createSnapshot raft) + Option.map + (DataSnapshot >> Raft.createSnapshot raft) + (callbacks.PrepareSnapshot()) member self.RetrieveSnapshot () = callbacks.RetrieveSnapshot() - - member self.PersistSnapshot log = - log - |> DiscoEvent.PersistSnapshot - |> Msg.Notify - |> agent.Post + member self.PersistSnapshot log = callbacks.PersistSnapshot log member self.ApplyLog cmd = cmd @@ -270,19 +247,19 @@ module rec RaftServer = |> agent.Post member self.MemberAdded mem = - AddMember mem + AddMachine mem |> DiscoEvent.appendRaft |> Msg.Notify |> agent.Post member self.MemberUpdated mem = - UpdateMember mem + UpdateMachine mem |> DiscoEvent.appendRaft |> Msg.Notify |> agent.Post member self.MemberRemoved mem = - RemoveMember mem + RemoveMachine mem |> DiscoEvent.appendRaft |> Msg.Notify |> agent.Post @@ -323,7 +300,7 @@ module rec RaftServer = // self.State // |> RaftContext.getRaft // |> saveRaft options - // |> Either.mapError + // |> Result.mapError // (fun err -> // printfn "Could not persit vote change. %A" err) // |> ignore @@ -339,7 +316,7 @@ module rec RaftServer = // self.State // |> RaftContext.getRaft // |> saveRaft options - // |> Either.mapError + // |> Result.mapError // (fun err -> // printfn "Could not persit vote change. %A" err) // |> ignore @@ -356,20 +333,20 @@ module rec RaftServer = // ** appendEntry - let private appendEntry (state: RaftServerState) (entry: RaftLogEntry) = + let private appendEntry (state: RaftServerState) (entry: LogEntry) = let result = entry |> Raft.receiveEntry |> runRaft state.Raft state.Callbacks match result with - | Right (appended, raftState) -> + | Ok (appended, raftState) -> (appended, updateRaft state raftState) - |> Either.succeed + |> Result.succeed - | Left (err, raftState) -> + | Error (err, raftState) -> (err, updateRaft state raftState) - |> Either.fail + |> Result.fail // ** appendCommand @@ -385,15 +362,15 @@ module rec RaftServer = state.Raft.Peers |> Map.toArray |> Array.map snd - |> Log.mkConfig state.Raft.CurrentTerm + |> Log.configuration state.Raft.CurrentTerm |> appendEntry state match result with - | Right (entry, newstate) -> + | Ok (entry, newstate) -> entry.Id |> String.format "appended new Configuration in {0}" |> Logger.info (tag "onConfigDone") newstate - | Left (error, newstate) -> + | Error (error, newstate) -> error |> String.format "error appending new Configruation: {0}" |> Logger.err (tag "onConfigDone") @@ -409,18 +386,18 @@ module rec RaftServer = /// - state: current RaftServerState to work against /// - mems: the changes to make to the current cluster configuration /// - /// Returns: Either + let private addMembers (state: RaftServerState) (mems: RaftMember array) = - if Raft.isLeader state.Raft then + if RaftState.isLeader state.Raft then mems |> Array.map ConfigChange.MemberAdded - |> Log.mkConfigChange state.Raft.CurrentTerm + |> Log.jointConsensus state.Raft.CurrentTerm |> appendEntry state else let msg = "Unable to add new member. Not leader." let error = Error.asRaftError (tag "addMembers") msg Logger.err (tag "addMembers") msg - Either.fail (error, state) + Result.fail (error, state) // ** removeMembers @@ -440,20 +417,19 @@ module rec RaftServer = mems |> Array.map ConfigChange.MemberRemoved - |> Log.mkConfigChange state.Raft.CurrentTerm + |> Log.jointConsensus state.Raft.CurrentTerm |> appendEntry state // ** removeMember let private removeMember (state: RaftServerState) (id: MemberId) = - if Raft.isLeader state.Raft then + if RaftState.isLeader state.Raft then string id |> sprintf "attempting to remove members with id %A" |> Logger.debug (tag "removeMember") let potentialChange = - state.Raft - |> Raft.getMember id + RaftState.getMember id state.Raft match potentialChange with | Some mem -> removeMembers state [| mem |] @@ -461,12 +437,12 @@ module rec RaftServer = let msg = sprintf "Unable to remove member. Not found: %A" (string id) let error = Error.asRaftError (tag "removeMember") msg Logger.err (tag "removeMember") msg - Either.fail (error, state) + Result.fail (error, state) else let msg = "Unable to remove mem. Not leader." let error = Error.asRaftError (tag "removeMember") msg Logger.err (tag "removeMember") msg - Either.fail (error, state) + Result.fail (error, state) // ** processAppendEntries @@ -478,7 +454,7 @@ module rec RaftServer = Raft.receiveAppendEntries (Some sender) ae |> runRaft state.Raft state.Callbacks match result with - | Right (response, newstate) -> + | Ok (response, newstate) -> (state.Raft.Member.Id, response) |> AppendEntriesResponse |> Binary.encode @@ -486,7 +462,7 @@ module rec RaftServer = |> state.Server.Respond updateRaft state newstate - | Left (err, newstate) -> + | Error (err, newstate) -> (state.Raft.Member.Id, err) |> ErrorResponse |> Binary.encode @@ -500,17 +476,17 @@ module rec RaftServer = (cmd: StateMachine) (raw: Request) (agent: RaftAgent) = - if Raft.isLeader state.Raft then // I'm leader, so I try to append command + if RaftState.isLeader state.Raft then // I'm leader, so I try to append command match appendCommand state cmd with - | Right (entry, newstate) -> // command was appended, now queue a message and the later - entry // response to check its committed status, eventually - |> AppendEntryResponse // timing out or responding to the server + | Ok (entry, newstate) -> // command was appended, now queue a message and the later + entry // response to check its committed status, eventually + |> AppendEntryResponse // timing out or responding to the server |> Binary.encode |> Response.fromRequest raw |> fun response -> Msg.ReqCommitted(DateTime.Now, entry, response) |> agent.Post newstate - | Left (err, newstate) -> // Request was unsuccessful, respond immeditately + | Error (err, newstate) -> // Request was unsuccessful, respond immeditately (state.Raft.Member.Id, err) |> ErrorResponse |> Binary.encode @@ -518,7 +494,7 @@ module rec RaftServer = |> state.Server.Respond newstate else - match Raft.getLeader state.Raft with // redirect to known leader or fail + match RaftState.getLeader state.Raft with // redirect to known leader or fail | Some mem -> mem |> Redirect @@ -545,14 +521,14 @@ module rec RaftServer = Raft.receiveVoteRequest sender vr |> runRaft state.Raft state.Callbacks match result with - | Right (response, newstate) -> + | Ok (response, newstate) -> (state.Raft.Member.Id, response) |> RequestVoteResponse |> Binary.encode |> Response.fromRequest raw |> state.Server.Respond updateRaft state newstate - | Left (err, newstate) -> + | Error (err, newstate) -> (state.Raft.Member.Id, err) |> ErrorResponse |> Binary.encode @@ -567,19 +543,20 @@ module rec RaftServer = Raft.receiveInstallSnapshot is |> runRaft state.Raft state.Callbacks match result with - | Right (response, newstate) -> + | Ok (response, newstate) -> (state.Raft.Member.Id, response) |> InstallSnapshotResponse |> Binary.encode |> Response.fromRequest raw |> state.Server.Respond updateRaft state newstate - | Left (error, newstate) -> + | Error (error, newstate) -> (state.Raft.Member.Id, error) |> ErrorResponse |> Binary.encode |> Response.fromRequest raw |> state.Server.Respond + do Logger.err (tag "processInstallSnapshot") error.Message updateRaft state newstate // ** doRedirect @@ -591,9 +568,9 @@ module rec RaftServer = /// ### Signature: /// - state: RaftServerState /// - /// Returns: Either + /// Results: DiscoResult let private doRedirect (state: RaftServerState) (raw: Request) = - match Raft.getLeader state.Raft with + match RaftState.getLeader state.Raft with | Some mem -> mem |> Redirect @@ -626,9 +603,9 @@ module rec RaftServer = /// Returns: RaftResponse let private processHandshake (state: RaftServerState) (mem: RaftMember) (raw: RawRequest) (agent: RaftAgent) = Tracing.trace (tag "processHandshake") <| fun () -> - if Raft.isLeader state.Raft then + if RaftState.isLeader state.Raft then match addMembers state [| mem |] with - | Right (entry, newstate) -> + | Ok (entry, newstate) -> let response = // response to check its committed status, eventually mem |> Welcome @@ -638,7 +615,7 @@ module rec RaftServer = |> Msg.ReqCommitted |> agent.Post newstate - | Left (err, newstate) -> + | Error (err, newstate) -> err |> ErrorResponse |> Binary.encode @@ -655,9 +632,9 @@ module rec RaftServer = let private processHandwaive (state: RaftServerState) (mem: RaftMember) (raw: RawRequest) (agent: RaftAgent) = Tracing.trace (tag "processHandwaive") <| fun () -> - if Raft.isLeader state.Raft then + if RaftState.isLeader state.Raft then match removeMember state mem.Id with - | Right (entry, newstate) -> + | Ok (entry, newstate) -> let response = // response to check its committed status, eventually Arrivederci |> Binary.encode @@ -666,7 +643,7 @@ module rec RaftServer = |> Msg.ReqCommitted |> agent.Post newstate - | Left (err, newstate) -> + | Error (err, newstate) -> err |> ErrorResponse |> Binary.encode @@ -688,8 +665,8 @@ module rec RaftServer = |> runRaft state.Raft state.Callbacks match result with - | Right (_, newstate) -> updateRaft state newstate - | Left (err, newstate) -> + | Ok (_, newstate) -> updateRaft state newstate + | Error (err, newstate) -> err |> DiscoEvent.RaftError |> Msg.Notify @@ -707,8 +684,8 @@ module rec RaftServer = |> runRaft state.Raft state.Callbacks match result with - | Right (_, newstate) -> updateRaft state newstate - | Left (err, newstate) -> + | Ok (_, newstate) -> updateRaft state newstate + | Error (err, newstate) -> err |> DiscoEvent.RaftError |> Msg.Notify @@ -767,7 +744,7 @@ module rec RaftServer = let private tryJoin (state: RaftServerState) (ip: IpAddress) (port: uint16) = let rec _tryJoin retry peer = - either { + result { if retry < int state.Options.Raft.MaxRetries then use client = mkReqSocket peer @@ -794,7 +771,7 @@ module rec RaftServer = | ErrorResponse err -> sprintf "Unexpected error occurred. %A" err |> Logger.err "tryJoin" - return! Either.fail err + return! Result.fail err | resp -> sprintf "Unexpected response. %A" resp @@ -802,14 +779,14 @@ module rec RaftServer = return! "Unexpected response" |> Error.asRaftError (tag "tryJoin") - |> Either.fail + |> Result.fail else "Too many unsuccesful connection attempts." |> Logger.err "tryJoin" return! "Too many unsuccesful connection attempts." |> Error.asRaftError (tag "tryJoin") - |> Either.fail + |> Result.fail } Tracing.trace (tag "tryJoin") <| fun () -> @@ -832,14 +809,14 @@ module rec RaftServer = let leader = tryJoin state ip port match leader with - | Right leader -> + | Ok leader -> sprintf "Reached leader: %A Adding to mems." leader.Id |> Logger.info (tag "tryJoinCluster") - do! Raft.addMemberM leader + do! addMember leader do! Raft.becomeFollower () - | Left err -> + | Error err -> sprintf "Joining cluster failed. %A" err |> Logger.err (tag "tryJoinCluster") @@ -860,9 +837,9 @@ module rec RaftServer = /// - appState: RaftServerState TVar /// /// Returns: unit - let private tryLeave (state: RaftServerState) : Either = + let private tryLeave (state: RaftServerState): DiscoResult = let rec _tryLeave retry mem = - either { + result { if retry < int state.Options.Raft.MaxRetries then use client = mkReqSocket mem @@ -878,19 +855,19 @@ module rec RaftServer = return! "Too many retries, aborting." |> Error.asRaftError (tag "tryLeave") - |> Either.fail + |> Result.fail | Arrivederci -> return true - | ErrorResponse err -> return! Either.fail err + | ErrorResponse err -> return! Result.fail err | resp -> return! "Unexpected response" |> Error.asRaftError (tag "tryLeave") - |> Either.fail + |> Result.fail else return! "Too many unsuccesful connection attempts." |> Error.asRaftError (tag "tryLeave") - |> Either.fail + |> Result.fail } Tracing.trace (tag "tryLeave") <| fun () -> @@ -902,11 +879,11 @@ module rec RaftServer = | _ -> "Member data for leader id not found" |> Error.asRaftError (tag "tryLeave") - |> Either.fail + |> Result.fail | _ -> "No known Leader" |> Error.asRaftError (tag "tryLeave") - |> Either.fail + |> Result.fail *) // ** leaveCluster @@ -920,26 +897,26 @@ module rec RaftServer = match tryLeave state with - | Right true -> + | Ok true -> // FIXME: this might need more consequences than this "Successfully left cluster." |> Logger.info (tag "tryLeaveCluster") - | Right false -> + | Ok false -> "Could not leave cluster." |> Logger.err (tag "tryLeaveCluster") - | Left err -> + | Error err -> err |> sprintf "Could not leave cluster. %A" |> Logger.err (tag "tryLeaveCluster") do! Raft.becomeFollower () - let! peers = Raft.getMembersM () + let! peers = getMembers () for kv in peers do - do! Raft.removeMemberM kv.Value + do! Raft.removeMember kv.Value } |> runRaft state.Raft state.Callbacks @@ -949,24 +926,17 @@ module rec RaftServer = let private forceElection (state: RaftServerState) = raft { - let! timeout = Raft.electionTimeoutM () - do! Raft.setTimeoutElapsedM timeout + let! timeout = electionTimeout () + do! setTimeoutElapsed timeout do! Raft.periodic timeout } |> runRaft state.Raft state.Callbacks // ** startPeriodic - /// ## startPeriodic - /// /// Starts an asynchronous loop to run Raft's `periodic` function. Returns a token, with which the /// loop can be cancelled at a later time. - /// - /// ### Signature: - /// - timeout: interval at which the loop runs - /// - appState: current RaftServerState TVar - /// - /// Returns: CancellationTokenSource + let private startPeriodic (interval: int) (agent: RaftAgent) : IDisposable = Periodically.run interval <| fun () -> agent.Post(Msg.Periodic) @@ -978,10 +948,10 @@ module rec RaftServer = let private handleJoin (state: RaftServerState) (ip: IpAddress) (port: UInt16) = Tracing.trace (tag "handleJoin") <| fun () -> match tryJoinCluster state ip port with - | Right (_, newstate) -> + | Ok (_, newstate) -> notify state.Subscriptions DiscoEvent.JoinedCluster updateRaft state newstate - | Left (error, newstate) -> + | Error (error, newstate) -> error |> DiscoEvent.RaftError |> notify state.Subscriptions @@ -995,11 +965,11 @@ module rec RaftServer = let private handleLeave (state: RaftServerState) = Tracing.trace (tag "handleLeave") <| fun () -> match tryLeaveCluster state with - | Right (_, newstate) -> + | Ok (_, newstate) -> notify state.Subscriptions DiscoEvent.LeftCluster updateRaft state newstate - | Left (error, newstate) -> + | Error (error, newstate) -> error |> string |> Logger.err (tag "handleLeave") @@ -1013,8 +983,8 @@ module rec RaftServer = let private handleForceElection (state: RaftServerState) (agent: RaftAgent) = match forceElection state with - | Right (_, newstate) -> updateRaft state newstate - | Left (err, newstate) -> + | Ok (_, newstate) -> updateRaft state newstate + | Error (err, newstate) -> err |> sprintf "Unable to force an election: %A" |> Logger.err (tag "handleForceElection") @@ -1028,12 +998,12 @@ module rec RaftServer = let private handleAddCmd (state: RaftServerState) (agent: RaftAgent) (cmd: StateMachine) = match appendCommand state cmd with - | Right (_, newstate) -> + | Ok (_, newstate) -> // (DateTime.Now, entry) // |> Msg.IsCommitted // |> agent.Post newstate - | Left (err, newstate) -> + | Error (err, newstate) -> err |> string |> Logger.err (tag "handleAddCmd") @@ -1059,12 +1029,12 @@ module rec RaftServer = |> Option.map (registerPeerSocket agent) |> Option.iter (addPeerSocket state.Connections) match addMembers state [| mem |] with - | Right (_, newstate) -> + | Ok (_, newstate) -> // (DateTime.Now, entry) // |> Msg.IsCommitted // |> agent.Post newstate - | Left (err, newstate) -> + | Error (err, newstate) -> err |> string |> Logger.err (tag "handleAddMember") @@ -1080,12 +1050,12 @@ module rec RaftServer = (agent: RaftAgent) (id: MemberId) = match removeMember state id with - | Right (_, newstate) -> + | Ok (_, newstate) -> // (DateTime.Now, entry) // |> Msg.IsCommitted // |> agent.Post newstate - | Left (err, newstate) -> + | Error (err, newstate) -> err |> string |> Logger.err (tag "handleRemoveMember") @@ -1108,10 +1078,10 @@ module rec RaftServer = let delta = DateTime.Now - ts match result with - | Right (true, newstate) -> // the entry was committed, hence we reply to the caller + | Ok (true, newstate) -> // the entry was committed, hence we reply to the caller entry |> Reply.Entry - |> Either.succeed + |> Result.succeed |> chan.Reply delta.TotalMilliseconds @@ -1122,11 +1092,11 @@ module rec RaftServer = |> updateRaft data |> Loaded - | Right (false, newstate) -> // the entry was not yet committed + | Ok (false, newstate) -> // the entry was not yet committed if int delta.TotalMilliseconds > Constants.COMMAND_TIMEOUT then "Command timed out" // failed miserably |> Error.asRaftError "handleIsCommitted" - |> Either.fail + |> Result.fail |> chan.Reply delta.TotalMilliseconds @@ -1144,9 +1114,9 @@ module rec RaftServer = |> updateRaft data |> Loaded - | Left (err, newstate) -> // encountered an error during check. request failed + | Error (err, newstate) -> // encountered an error during check. request failed err - |> Either.fail + |> Result.fail |> chan.Reply newstate @@ -1157,7 +1127,7 @@ module rec RaftServer = // ** processRequest let private processRequest (data: RaftServerState) (agent: RaftAgent) (raw: Request) = - either { + result { let! request = Binary.decode raw.Body let newstate = match request with @@ -1174,8 +1144,8 @@ module rec RaftServer = let private handleServerRequest (state: RaftServerState) (raw: Request) agent = match processRequest state agent raw with - | Right newdata -> newdata - | Left error -> + | Ok newdata -> newdata + | Error error -> (state.Raft.Member.Id, error) |> ErrorResponse |> Binary.encode @@ -1216,7 +1186,7 @@ module rec RaftServer = let delta = DateTime.Now - ts match result with - | Right (true, newstate) -> + | Ok (true, newstate) -> state.Server.Respond raw delta @@ -1226,7 +1196,7 @@ module rec RaftServer = updateRaft state newstate - | Right (false, newstate) -> + | Ok (false, newstate) -> if int delta.TotalMilliseconds > Constants.COMMAND_TIMEOUT then "AppendEntry timed out" |> Error.asRaftError "handleReqCommitted" @@ -1245,7 +1215,7 @@ module rec RaftServer = |> Msg.ReqCommitted |> agent.Post updateRaft state newstate - | Left (err, newstate) -> + | Error (err, newstate) -> (state.Raft.Member.Id, err) |> ErrorResponse |> Binary.encode @@ -1257,14 +1227,14 @@ module rec RaftServer = let private handleServerResponse (state: RaftServerState) agent (raw: Response) = match Binary.decode raw.Body with - | Right response -> + | Ok response -> match response with | RequestVoteResponse (sender, vote) -> processVoteResponse state sender vote agent | AppendEntriesResponse (sender, ar) -> processAppendEntriesResponse state sender ar agent | InstallSnapshotResponse (sender, ar) -> processSnapshotResponse state sender ar agent | ErrorResponse (sender, error) -> processErrorResponse state sender error | _ -> state - | Left error -> + | Error error -> error |> string |> Logger.err (tag "handleRawRespose") @@ -1272,19 +1242,17 @@ module rec RaftServer = // ** handleClientState - let private handleClientState (state: RaftServerState) - (id: MemberId) - raftState = + let private handleClientState (state: RaftServerState) (id: MemberId) raftState = raft { - let! peer = Raft.getMemberM id + let! peer = RaftMonad.getMember id match peer with - | Some mem -> do! Raft.updateMemberM { mem with Status = raftState } + | Some mem -> do! RaftMonad.updateMember { mem with Status = raftState } | None -> () } |> runRaft state.Raft state.Callbacks |> function - | Right (_, newstate) -> updateRaft state newstate - | Left (err,_) -> + | Ok (_, newstate) -> updateRaft state newstate + | Error (err,_) -> err |> String.format "Could not set new state on member: {0}" |> Logger.err (tag "handleClientState") @@ -1294,18 +1262,18 @@ module rec RaftServer = let private handleClientResponse (state: RaftServerState) (raw: Response) agent = match raw.Body |> Binary.decode with - | Right (AppendEntryResponse entry) -> + | Ok (AppendEntryResponse entry) -> // FIXME: // this will likely take some more thought and handling sprintf "successfully appended entry in %O" entry.Id |> Logger.debug (tag "handleClientResponse") state - | Right (AppendEntriesResponse(id, ar)) -> processAppendEntriesResponse state id ar agent - | Right (RequestVoteResponse(id, vr)) -> processVoteResponse state id vr agent - | Right (InstallSnapshotResponse(id, ar)) -> processSnapshotResponse state id ar agent - | Right (ErrorResponse(id, error)) -> processErrorResponse state id error - | Right (Redirect leader) -> processRedirect state leader - | Left error -> + | Ok (AppendEntriesResponse(id, ar)) -> processAppendEntriesResponse state id ar agent + | Ok (RequestVoteResponse(id, vr)) -> processVoteResponse state id vr agent + | Ok (InstallSnapshotResponse(id, ar)) -> processSnapshotResponse state id ar agent + | Ok (ErrorResponse(id, error)) -> processErrorResponse state id error + | Ok (Redirect leader) -> processRedirect state leader + | Error error -> error |> sprintf "Error decoding response: %O" |> Logger.err (tag "handleClientResponse") @@ -1336,28 +1304,28 @@ module rec RaftServer = let private initializeRaft (callbacks: IRaftCallbacks) (state: RaftState) = let rand = System.Random() raft { - let term = term 0 - do! Raft.setTermM term - let! num = Raft.numMembersM () + let term = 0 + do! setCurrentTerm term + let! num = RaftMonad.numMembers () if num = 1 then - do! Raft.setTimeoutElapsedM 0 + do! RaftMonad.setTimeoutElapsed 0 do! Raft.becomeLeader () else // set the timeout to something random, to prevent split votes let timeout = 1 * rand.Next(0, int state.ElectionTimeout) - do! Raft.setTimeoutElapsedM timeout + do! RaftMonad.setTimeoutElapsed timeout do! Raft.becomeFollower () } |> runRaft state callbacks - |> Either.mapError fst - |> Either.map snd + |> Result.mapError fst + |> Result.map snd // ** handleStart let private handleStart (state: RaftServerState) (agent: RaftAgent) = match initializeRaft state.Callbacks state.Raft with - | Right initialized -> + | Ok initialized -> // periodic function let interval = int state.Options.Raft.PeriodicInterval let periodic = startPeriodic interval agent @@ -1367,7 +1335,7 @@ module rec RaftServer = Status = ServiceStatus.Running Raft = initialized Disposables = periodic :: state.Disposables } - | Left error -> + | Error error -> sprintf "Fatal, could not initialize Raft: %O" error |> Logger.err (tag "handleStart") agent.Post Msg.Started @@ -1420,7 +1388,7 @@ module rec RaftServer = // ** create let create (config: DiscoConfig) callbacks = - either { + result { let cts = new CancellationTokenSource() let connections = new Connections() let store = AgentStore.create() @@ -1462,7 +1430,7 @@ module rec RaftServer = // we must start the agent, so the dispose logic will work as expected do agent.Start() match server.Start() with - | Right () -> + | Ok () -> let srvobs = server.Subscribe(Msg.ServerEvent >> agent.Post) Map.iter @@ -1489,22 +1457,22 @@ module rec RaftServer = if result then match store.State.Status with | ServiceStatus.Failed error -> - Either.fail error - | _ -> Either.succeed () + Result.fail error + | _ -> Result.succeed () else "Timeout waiting for started signal" |> Error.asRaftError (tag "Start") - |> Either.fail - | Left error -> + |> Result.fail + | Error error -> error |> sprintf "error starting broker: %O" |> Logger.err (tag "Start") store.Update { store.State with Status = ServiceStatus.Failed error } - Either.fail error + Result.fail error else sprintf "Status error. %O" store.State.Status |> Error.asRaftError (tag "Start") - |> Either.fail + |> Result.fail member self.Raft with get () = store.State.Raft @@ -1538,10 +1506,10 @@ module rec RaftServer = // member self.LeaveCluster () = // agent.Post Msg.Leave - member self.AddMember mem = + member self.AddMachine mem = mem |> Msg.AddMember |> agent.Post - member self.RemoveMember id = + member self.RemoveMachine id = id |> Msg.RemoveMember |> agent.Post member self.Subscribe (callback: DiscoEvent -> unit) = @@ -1551,13 +1519,13 @@ module rec RaftServer = with get () = store.State.Connections member self.IsLeader - with get () = Raft.isLeader store.State.Raft + with get () = RaftState.isLeader store.State.Raft member self.RaftState - with get () = store.State.Raft.State + with get () = store.State.Raft.Member.State member self.Leader - with get () = Raft.getLeader store.State.Raft + with get () = RaftState.getLeader store.State.Raft member self.Dispose () = if not (Service.isDisposed store.State.Status) then diff --git a/src/Disco/Disco/Service/WebSocket.fs b/src/Disco/Disco/Service/WebSocket.fs index 36d8e993..9ffa3307 100644 --- a/src/Disco/Disco/Service/WebSocket.fs +++ b/src/Disco/Disco/Service/WebSocket.fs @@ -60,18 +60,18 @@ module WebSocketServer = IpAddress = IpAddress.Parse socket.ConnectionInfo.ClientIpAddress UserAgent = ua } if connections.TryUpdate(socketId, (socket, Some updated), current) then - Either.succeed updated + Result.succeed updated elif connections.TryUpdate(socketId, (socket, Some updated), current) then - Either.succeed updated + Result.succeed updated else "Updating connections failed after one retry" |> Error.asSocketError (tag "buildSession") - |> Either.fail + |> Result.fail | false, _ -> socketId |> String.format "No connection found for {0}" |> Error.asSocketError (tag "buildSession") - |> Either.fail + |> Result.fail // ** ucast @@ -85,22 +85,22 @@ module WebSocketServer = |> Binary.encode |> socket.Send |> ignore - |> Either.succeed + |> Result.succeed with exn -> exn.Message |> Error.asSocketError (tag "send") - |> Either.fail + |> Result.fail else sid |> String.format "Socket {0} not available" |> Error.asSocketError (tag "send") - |> Either.fail + |> Result.fail | false, _ -> sid |> string |> sprintf "Could not send message to session %s. Not found." |> Error.asSocketError (tag "send") - |> Either.fail + |> Result.fail // ** bcast @@ -117,16 +117,16 @@ module WebSocketServer = |> Seq.choose (fun id -> match ucast connections id msg with - | Right () -> None - | Left error -> + | Ok () -> None + | Error error -> error.Message |> String.format "Error broadcasting message: {0}" |> Logger.err (tag "bcast") Some id) |> Seq.toList |> function - | [ ] -> Either.nothing - | result -> Either.fail result + | [ ] -> Result.nothing + | result -> Result.fail result // ** mcast @@ -143,22 +143,22 @@ module WebSocketServer = let private mcast (connections: Connections) (id: SessionId) (msg: StateMachine) : - Either = + Result = connections.Keys |> Seq.filter (fun sid -> id <> sid) |> Seq.choose (fun id -> match ucast connections id msg with - | Right () -> None - | Left error -> + | Ok () -> None + | Error error -> error.Message |> String.format "Error multicasting message: {0}" |> Logger.err (tag "mcast") Some id) |> Seq.toList |> function - | [ ] -> Either.nothing - | result -> Either.fail result + | [ ] -> Result.nothing + | result -> Result.fail result // ** onNewSocket @@ -214,8 +214,8 @@ module WebSocketServer = socket.OnBinary <- fun bytes -> let sid = getConnectionId socket match Binary.decode bytes with - | Right cmd -> DiscoEvent.Append(Origin.Web sid, cmd) |> agent.Post - | Left err -> + | Ok cmd -> DiscoEvent.Append(Origin.Web sid, cmd) |> agent.Post + | Error err -> err |> string |> sprintf "Could not decode message: %s" @@ -261,8 +261,8 @@ module WebSocketServer = // ** create - let create (mem: RaftMember) = - either { + let create (mem: ClusterMember) = + result { let status = ref ServiceStatus.Stopped let connections = Connections() let subscriptions = Subscriptions() @@ -305,13 +305,13 @@ module WebSocketServer = match ev with | DiscoEvent.Append (_, cmd) -> bcast connections cmd - |> Either.mapError handleBroadcastErrors + |> Result.mapError handleBroadcastErrors |> ignore | _ -> () member self.Send (id: SessionId) (cmd: StateMachine) = ucast connections id cmd - |> Either.mapError + |> Result.mapError (Error.message >> sprintf "Error sending to %A: %s" id >> konst [ id ] @@ -320,12 +320,12 @@ module WebSocketServer = member self.Broadcast (cmd: StateMachine) = bcast connections cmd - |> Either.mapError handleBroadcastErrors + |> Result.mapError handleBroadcastErrors |> ignore member self.Multicast (except: SessionId) (cmd: StateMachine) = mcast connections except cmd - |> Either.mapError handleBroadcastErrors + |> Result.mapError handleBroadcastErrors |> ignore member self.BuildSession (id: SessionId) (session: Session) = @@ -357,12 +357,12 @@ module WebSocketServer = status := ServiceStatus.Running "WebSocketServer successfully started" |> Logger.debug (tag "Start") - |> Either.succeed + |> Result.succeed with | exn -> exn.Message |> Error.asSocketError (tag "Start") - |> Either.fail + |> Result.fail member self.Dispose () = if Service.isRunning !status then diff --git a/src/Disco/Disco/Tests/Core/ApiTests.fs b/src/Disco/Disco/Tests/Core/ApiTests.fs index 27190f5e..f1144ab6 100644 --- a/src/Disco/Disco/Tests/Core/ApiTests.fs +++ b/src/Disco/Disco/Tests/Core/ApiTests.fs @@ -26,7 +26,7 @@ module ApiTests = let project = { Id = DiscoId.Create() Name = name "Hello" - Path = Path.getTempPath() |> Project.ofFilePath + Path = Path.getTempPath() CreatedOn = Time.createTimestamp() LastSaved = Some (Time.createTimestamp ()) Copyright = None @@ -54,10 +54,10 @@ module ApiTests = let test_server_should_not_start_when_bind_fails = testCase "server should not start when bind fails" <| fun _ -> - either { + result { let mutable store = Store(mkState ()) - let mem = Member.create (DiscoId.Create()) + let mem = ClusterMember.create (DiscoId.Create()) use! server1 = ApiServer.create mem { new IApiServerCallbacks with @@ -72,17 +72,17 @@ module ApiTests = } do! match server2.Start() with - | Right () -> Left (Other("test","should have failed")) - | Left _ -> Right() + | Ok () -> Error (Other("test","should have failed")) + | Error _ -> Ok() } |> noError let test_server_should_replicate_state_snapshot_to_client = testCase "server should replicate state snapshot to client" <| fun _ -> - either { + result { let mutable store = Store(mkState ()) - let mem = Member.create (DiscoId.Create()) + let mem = ClusterMember.create (DiscoId.Create()) use! server = ApiServer.create mem { new IApiServerCallbacks with @@ -147,10 +147,10 @@ module ApiTests = let test_server_should_replicate_state_machine_commands_to_client = testCase "should replicate state machine commands to client" <| fun _ -> - either { + result { let store = Store(mkState ()) - let mem = Member.create (DiscoId.Create()) + let mem = ClusterMember.create (DiscoId.Create()) use! server = ApiServer.create mem { new IApiServerCallbacks with @@ -190,7 +190,6 @@ module ApiTests = AddCue (mkCue ()) AddPin (mkPin ()) AddCueList (mkCueList ()) - AddMember (mkMember ()) AddUser (mkUser ()) ] @@ -231,14 +230,14 @@ module ApiTests = let test_client_should_replicate_state_machine_commands_to_server = testCase "client should replicate state machine commands to server" <| fun _ -> - either { + result { use clientRegistered = new WaitEvent() use clientSnapshot = new WaitEvent() use clientUpdate = new WaitEvent() let store = Store(mkState ()) - let mem = Member.create (DiscoId.Create()) + let mem = ClusterMember.create (DiscoId.Create()) let srvr : DiscoServer = { Port = mem.ApiPort @@ -317,7 +316,7 @@ module ApiTests = expect "Server should have one cuelist" 1 len store.State.CueLists expect "Client should have one cuelist" 1 len client.State.CueLists - client.UpdatePin (Pin.setSlice (BoolSlice(index 0, false, false)) pin) + client.UpdatePin (Pin.setSlice (BoolSlice(0, false, false)) pin) do! waitFor "clientUpdate" clientUpdate @@ -354,9 +353,9 @@ module ApiTests = let test_server_should_dispose_properly = testCase "server should dispose properly" <| fun _ -> - either { + result { let store = Store(mkState ()) - let mem = Member.create (DiscoId.Create()) + let mem = ClusterMember.create (DiscoId.Create()) use! server = ApiServer.create mem { new IApiServerCallbacks with @@ -368,8 +367,9 @@ module ApiTests = let test_client_should_dispose_properly = testCase "client should dispose properly" <| fun _ -> - either { - let mem = Member.create (DiscoId.Create()) + result { + let machine = MachineConfig.create "127.0.0.1" None + let mem = Machine.toClusterMember machine let srvr : DiscoServer = { Port = mem.ApiPort diff --git a/src/Disco/Disco/Tests/Core/AssetServiceTests.fs b/src/Disco/Disco/Tests/Core/AssetServiceTests.fs index 77d38d05..efd1ad1a 100644 --- a/src/Disco/Disco/Tests/Core/AssetServiceTests.fs +++ b/src/Disco/Disco/Tests/Core/AssetServiceTests.fs @@ -43,12 +43,12 @@ module AssetServiceTests = do File.writeText contents None filePath let machine = { DiscoMachine.Default with AssetDirectory = basePath } let filters = FsTree.parseFilters machine.AssetFilter - let fsTree = FsTree.read machine.MachineId basePath filters |> Either.get + let fsTree = FsTree.read machine.MachineId basePath filters |> Result.get machine, fsTree let testInitialCrawl = testCase "should crawl asset directory correctly" <| fun _ -> - either { + result { let machine, tree = createAssetDirectory() use crawlDone = new WaitEvent() use! service = AssetService.create machine @@ -68,7 +68,7 @@ module AssetServiceTests = let testAddEntry = testCase "add entry should work" <| fun _ -> - either { + result { let machine, tree = createAssetDirectory() use crawlDone = new WaitEvent() use addDone = new WaitEvent() @@ -104,7 +104,7 @@ module AssetServiceTests = let testChangeEntry = testCase "change entry should work" <| fun _ -> - either { + result { let machine, tree = createAssetDirectory() use crawlDone = new WaitEvent() use changeDone = new WaitEvent() @@ -147,7 +147,7 @@ module AssetServiceTests = let testRemoveEntres = testCase "remove entries should work" <| fun _ -> - either { + result { let machine, tree = createAssetDirectory() use crawlDone = new WaitEvent() use removeDone = new WaitEvent() diff --git a/src/Disco/Disco/Tests/Core/AssetTests.fs b/src/Disco/Disco/Tests/Core/AssetTests.fs index c6689280..2b8c7fbf 100644 --- a/src/Disco/Disco/Tests/Core/AssetTests.fs +++ b/src/Disco/Disco/Tests/Core/AssetTests.fs @@ -31,22 +31,22 @@ module AssetTests = member self.ToYaml() = self member self.Save(basePath: FilePath) = - either { + result { let path = basePath Asset.path self let data = Yaml.encode self let! info = DiscoData.write path (Payload data) return () } - static member Load(path: FilePath) : Either = - either { + static member Load(path: FilePath): DiscoResult = + result { let! data = DiscoData.read path return Yaml.deserialize data } let test_write_read_asset_correctly = testCase "should write and read asset correctly" <| fun _ -> - either { + result { let path = tmpPath() let payload = string (DiscoId.Create()) let! info = DiscoData.write path (Payload payload) @@ -57,7 +57,7 @@ module AssetTests = let test_save_load_asset_correctly = testCase "should save and load asset correctly" <| fun _ -> - either { + result { let path = tmpPath() let asset = TestAsset() do! Asset.save path asset @@ -69,7 +69,7 @@ module AssetTests = let test_save_with_commit_adds_and_commits_an_asset = testCase "should save an asset with commit even if its new" <| fun _ -> - either { + result { let path = tmpPath() let! repo = Git.Repo.init path let signature = User.Admin.Signature diff --git a/src/Disco/Disco/Tests/Core/ConfigTests.fs b/src/Disco/Disco/Tests/Core/ConfigTests.fs index 4cd72667..e8eb241c 100644 --- a/src/Disco/Disco/Tests/Core/ConfigTests.fs +++ b/src/Disco/Disco/Tests/Core/ConfigTests.fs @@ -21,7 +21,7 @@ module ConfigTests = // let loadSaveTest = testCase "Save/Load MachineConfig with default path should render equal values" <| fun _ -> - either { + result { let config = MachineConfig.create "127.0.0.1" None do! MachineConfig.save None config @@ -34,7 +34,7 @@ module ConfigTests = let loadSaveCustomPathTest = testCase "Save/Load MachineConfig with default path should render equal values" <| fun _ -> - either { + result { let path = tmpPath() let config = MachineConfig.create "127.0.0.1" None diff --git a/src/Disco/Disco/Tests/Core/Disco/AddedMemberShouldHaveCorrectState.fs b/src/Disco/Disco/Tests/Core/Disco/AddedMemberShouldHaveCorrectState.fs new file mode 100644 index 00000000..00fa93ef --- /dev/null +++ b/src/Disco/Disco/Tests/Core/Disco/AddedMemberShouldHaveCorrectState.fs @@ -0,0 +1,156 @@ +(* + * This file is part of Distributed Show Control + * + * Copyright 2015, 2018 by it's authors. + * Some rights reserved. See COPYING, AUTHORS. + *) + +namespace Disco.Tests + +open System.IO +open System.Threading +open Expecto + +open Disco.Core +open Disco.Service +open Disco.Client +open Disco.Client.Interfaces +open Disco.Service.Interfaces +open Disco.Raft +open Disco.Net + +open Common + +module AddedMemberShouldHaveCorrectState = + + let test = + testCase "added member should have correct state" <| fun _ -> + result { + use configurationDone = new WaitEvent() + use snapshotDone = new WaitEvent() + use updateDone = new WaitEvent() + + let machine1 = mkMachine 4000us + let machine2 = mkMachine 5000us + + let mem1 = Machine.toClusterMember machine1 + let mem2 = Machine.toClusterMember machine2 + + let site1 = mkSite [ mem1 ] + let site2 = mkSite [ mem2 ] |> ClusterConfig.setName (name "Ohai!") + + let! project1 = mkProject machine1 site1 + + let path2 = machine2.WorkSpace (project1.Name |> unwrap |> filepath) + + let project2 = + project1.Config + |> Config.addSiteAndSetActive site2 + |> flip Project.setConfig project1 + |> Project.setPath path2 + + do! FileSystem.copyDir project1.Path path2 + do! project2.Save path2 + + /// do Logger.setFields { + /// LogEventFields.Default with + /// LogLevel = false + /// Time = false + /// Id = false + /// Tier = false + /// } + + /// use lobs = Logger.subscribe Logger.stdout + + let handler = function + | DiscoEvent.ConfigurationDone members -> configurationDone.Set() + | DiscoEvent.Append(_, DataSnapshot _) -> snapshotDone.Set() + | DiscoEvent.Append(_, CommandBatch batch) -> updateDone.Set() + | ev -> () + + let! repo1 = Project.repository project1 + + // _ + // / | + // | | + // | | + // |_| start + + use! service1 = DiscoService.create { + Machine = machine1 + ProjectName = project1.Name + UserName = User.Admin.UserName + Password = password Constants.ADMIN_DEFAULT_PASSWORD + SiteId = None + } + + use oobs1 = service1.Subscribe handler + do! service1.Start() + + // ____ + // |___ \ + // __) | + // / __/ + // |_____| start + + let! repo2 = Project.repository project2 + + use! service2 = DiscoService.create { + Machine = machine2 + ProjectName = project2.Name + UserName = User.Admin.UserName + Password = password Constants.ADMIN_DEFAULT_PASSWORD + SiteId = None + } + + use oobs2 = service2.Subscribe handler + do! service2.Start() + + + /// _____ + /// |___ / + /// |_ \ + /// ___) | + /// |____/ add member + + do service1.AddMachine (Machine.toRaftMember machine2) + + do! waitFor "configurationDone" configurationDone + + do! waitFor "snapshotDone" snapshotDone + do! waitFor "snapshotDone" snapshotDone + + do! waitFor "updateDone" updateDone + do! waitFor "updateDone" updateDone + + // we have to wait here because under some circumstances (when LeaderChange happens, and new + // leader socket gets created and local state is forwarded to the leader) CommandBatch gets + // sent 3x rather than 2x causing the next expectations to fail. + do updateDone.WaitOne(System.TimeSpan.FromSeconds 30.0) |> ignore + + Expect.equal + service1.State.Project.Config.Sites + service2.State.Project.Config.Sites + "Cluster Sites should be equal" + + Expect.equal + (service1.RaftServer.Raft.Peers |> Map.count) + 2 + "Raft peers of Service 1 Should have 2 Members" + + Expect.equal + (service2.RaftServer.Raft.Peers |> Map.count) + 2 + "Raft peers of Service 2 Should have 2 Members" + + Expect.equal + (service1.State.Project.Config |> Config.getActiveSite |> Option.map (ClusterConfig.members >> Map.count)) + (Some 2) + "ActiveSite of Service 1 Should have 2 Members" + + Expect.equal + (service2.State.Project.Config |> Config.getActiveSite |> Option.map (ClusterConfig.members >> Map.count)) + (Some 2) + "ActiveSite of Service 2 Should also have 2 Members" + } + |> noError diff --git a/src/Disco/Disco/Tests/Core/Disco/ClonesFromLeader.fs b/src/Disco/Disco/Tests/Core/Disco/ClonesFromLeader.fs index 355b6b10..2b1b321f 100644 --- a/src/Disco/Disco/Tests/Core/Disco/ClonesFromLeader.fs +++ b/src/Disco/Disco/Tests/Core/Disco/ClonesFromLeader.fs @@ -25,7 +25,7 @@ module ClonesFromLeader = let test = testCase "ensure disco server clones changes from leader" <| fun _ -> - either { + result { use checkGitStarted = new WaitEvent() use electionDone = new WaitEvent() use appendDone = new WaitEvent() diff --git a/src/Disco/Disco/Tests/Core/Disco/Common.fs b/src/Disco/Disco/Tests/Core/Disco/Common.fs index 7d7638e7..ef8078cb 100644 --- a/src/Disco/Disco/Tests/Core/Disco/Common.fs +++ b/src/Disco/Disco/Tests/Core/Disco/Common.fs @@ -34,7 +34,7 @@ module Common = WorkSpace = tmpPath() Path.getRandomFileName() } let mkProject (machine: DiscoMachine) (site: ClusterConfig) = - either { + result { let name = Path.GetRandomFileName() let path = machine.WorkSpace filepath name @@ -46,11 +46,11 @@ module Common = |> Config.addSiteAndSetActive site |> Config.setLogLevel (LogLevel.Debug) - let! project = Project.create (Project.ofFilePath path) name machine + let! project = Project.create path name machine let updated = { project with - Path = Project.ofFilePath path + Path = path Author = Some(author1) Config = cfg } @@ -60,14 +60,18 @@ module Common = } let mkMember (machine: DiscoMachine) = - { Member.create machine.MachineId with - RaftPort = machine.RaftPort - ApiPort = machine.ApiPort - GitPort = machine.GitPort - WsPort = machine.WsPort } + Machine.toClusterMember machine + + let mkSite (members: ClusterMember list) = + { ClusterConfig.Default with + Name = name "Cool Cluster Yo" + Members = + members + |> List.map (fun mem -> mem.Id, mem) + |> Map.ofList } let mkCluster (num: int) = - either { + result { let baseport = 4000us let machines = @@ -77,23 +81,20 @@ module Common = let members = List.map mkMember machines - let site = - { ClusterConfig.Default with - Name = name "Cool Cluster Yo" - Members = members |> List.map (fun mem -> mem.Id,mem) |> Map.ofList } + let site = mkSite members let project = List.fold (fun (i, project') machine -> if i = 0 then match mkProject machine site with - | Right project -> (i + 1, project) - | Left error -> failwithf "unable to create project: %O" error + | Ok project -> (i + 1, project) + | Error error -> failwithf "unable to create project: %O" error else - let path = Project.toFilePath project'.Path + let path = project'.Path match copyDir path (machine.WorkSpace (project'.Name |> unwrap |> filepath)) with - | Right () -> (i + 1, project') - | Left error -> failwithf "error copying project: %O" error) + | Ok () -> (i + 1, project') + | Error error -> failwithf "error copying project: %O" error) (0, Unchecked.defaultof) machines |> snd diff --git a/src/Disco/Disco/Tests/Core/Disco/CorrectPinPersistance.fs b/src/Disco/Disco/Tests/Core/Disco/CorrectPinPersistance.fs index 2051b095..e9a07ec4 100644 --- a/src/Disco/Disco/Tests/Core/Disco/CorrectPinPersistance.fs +++ b/src/Disco/Disco/Tests/Core/Disco/CorrectPinPersistance.fs @@ -34,7 +34,7 @@ module CorrectPinPersistance = then pending testName else testCase testName <| fun _ -> - either { + result { use started = new WaitEvent() use appendDone = new WaitEvent() use createDone = new WaitEvent() diff --git a/src/Disco/Disco/Tests/Core/Disco/DiscoServiceTests.fs b/src/Disco/Disco/Tests/Core/Disco/DiscoServiceTests.fs index 3ec7fa81..5b41c5d1 100644 --- a/src/Disco/Disco/Tests/Core/Disco/DiscoServiceTests.fs +++ b/src/Disco/Disco/Tests/Core/Disco/DiscoServiceTests.fs @@ -41,4 +41,5 @@ module DiscoServiceTests = PinBecomesDirty.test StateShouldBeCleanedOnClientRemove.test RemoveMemberShouldSplitCluster.test + AddedMemberShouldHaveCorrectState.test ] |> testSequenced diff --git a/src/Disco/Disco/Tests/Core/Disco/EnsureClientCommandForward.fs b/src/Disco/Disco/Tests/Core/Disco/EnsureClientCommandForward.fs index 9941ced5..03a2374f 100644 --- a/src/Disco/Disco/Tests/Core/Disco/EnsureClientCommandForward.fs +++ b/src/Disco/Disco/Tests/Core/Disco/EnsureClientCommandForward.fs @@ -25,7 +25,7 @@ module EnsureClientCommandForward = let test = testCase "ensure client commands are forwarded to leader" <| fun _ -> - either { + result { use electionDone = new WaitEvent() use clientReady = new WaitEvent() use clientAppendDone = new WaitEvent() @@ -167,7 +167,7 @@ module EnsureClientCommandForward = { Id = DiscoId.Create(); Name = name "Cue 3"; Slices = [||] } ] - do! either { + do! result { if service1.RaftServer.IsLeader then for cue in cues do client2.AddCue cue diff --git a/src/Disco/Disco/Tests/Core/Disco/EnsureClientUpdateNoLoop.fs b/src/Disco/Disco/Tests/Core/Disco/EnsureClientUpdateNoLoop.fs index 57b0167e..b551b2eb 100644 --- a/src/Disco/Disco/Tests/Core/Disco/EnsureClientUpdateNoLoop.fs +++ b/src/Disco/Disco/Tests/Core/Disco/EnsureClientUpdateNoLoop.fs @@ -25,7 +25,7 @@ module EnsureClientUpdateNoLoop = let test = testCase "ensure client slice update does not loop" <| fun _ -> - either { + result { use electionDone = new WaitEvent() use appendDone = new WaitEvent() use clientRegistered = new WaitEvent() diff --git a/src/Disco/Disco/Tests/Core/Disco/EnsureClientsReplicated.fs b/src/Disco/Disco/Tests/Core/Disco/EnsureClientsReplicated.fs index f4867aca..4ca24157 100644 --- a/src/Disco/Disco/Tests/Core/Disco/EnsureClientsReplicated.fs +++ b/src/Disco/Disco/Tests/Core/Disco/EnsureClientsReplicated.fs @@ -25,7 +25,7 @@ module EnsureClientsReplicated = let test = testCase "ensure connected clients are forwarded to leader" <| fun _ -> - either { + result { use electionDone = new WaitEvent() use addClientDone = new WaitEvent() use appendDone = new WaitEvent() diff --git a/src/Disco/Disco/Tests/Core/Disco/EnsureCueResolver.fs b/src/Disco/Disco/Tests/Core/Disco/EnsureCueResolver.fs index 82f8a8f9..b5f69390 100644 --- a/src/Disco/Disco/Tests/Core/Disco/EnsureCueResolver.fs +++ b/src/Disco/Disco/Tests/Core/Disco/EnsureCueResolver.fs @@ -25,7 +25,7 @@ module EnsureCueResolver = let test = testCase "ensure cue resolver works" <| fun _ -> - either { + result { use checkGitStarted = new WaitEvent() use electionDone = new WaitEvent() use appendDone = new WaitEvent() diff --git a/src/Disco/Disco/Tests/Core/Disco/EnsureMappingResolver.fs b/src/Disco/Disco/Tests/Core/Disco/EnsureMappingResolver.fs index f4597327..5f41f59a 100644 --- a/src/Disco/Disco/Tests/Core/Disco/EnsureMappingResolver.fs +++ b/src/Disco/Disco/Tests/Core/Disco/EnsureMappingResolver.fs @@ -25,7 +25,7 @@ module EnsureMappingResolver = let test = testCase "ensure mapping resolver works" <| fun _ -> - either { + result { use electionDone = new WaitEvent() use counter = new WaitEvent() diff --git a/src/Disco/Disco/Tests/Core/Disco/PinBecomesDirty.fs b/src/Disco/Disco/Tests/Core/Disco/PinBecomesDirty.fs index 3da1876b..30657b65 100644 --- a/src/Disco/Disco/Tests/Core/Disco/PinBecomesDirty.fs +++ b/src/Disco/Disco/Tests/Core/Disco/PinBecomesDirty.fs @@ -25,7 +25,7 @@ module PinBecomesDirty = let test = testCase "pin becomes dirty" <| fun _ -> - either { + result { use started = new WaitEvent() use updateDone = new WaitEvent() use saveDone = new WaitEvent() diff --git a/src/Disco/Disco/Tests/Core/Disco/PinBecomesOnlineOnClientConnect.fs b/src/Disco/Disco/Tests/Core/Disco/PinBecomesOnlineOnClientConnect.fs index 109ccafd..17451d8d 100644 --- a/src/Disco/Disco/Tests/Core/Disco/PinBecomesOnlineOnClientConnect.fs +++ b/src/Disco/Disco/Tests/Core/Disco/PinBecomesOnlineOnClientConnect.fs @@ -25,7 +25,7 @@ module PinBecomesOnlineOnClientConnect = let test = testCase "pin becomes online on client connect" <| fun _ -> - either { + result { use started = new WaitEvent() use appendDone = new WaitEvent() use clientRegistered = new WaitEvent() diff --git a/src/Disco/Disco/Tests/Core/Disco/RemoveMemberShouldSplitCluster.fs b/src/Disco/Disco/Tests/Core/Disco/RemoveMemberShouldSplitCluster.fs index f1bba6f0..368ea13f 100644 --- a/src/Disco/Disco/Tests/Core/Disco/RemoveMemberShouldSplitCluster.fs +++ b/src/Disco/Disco/Tests/Core/Disco/RemoveMemberShouldSplitCluster.fs @@ -25,12 +25,11 @@ module RemoveMemberShouldSplitCluster = let test = testCase "ensure follower forwards fstree to leader" <| fun _ -> - either { + result { use electionDone = new WaitEvent() use appendDone = new WaitEvent() use pushDone = new WaitEvent() use removeDone = new WaitEvent() - use updateDone = new WaitEvent() let! (project, zipped) = mkCluster 2 @@ -38,7 +37,6 @@ module RemoveMemberShouldSplitCluster = | DiscoEvent.GitPush _ -> pushDone.Set() | DiscoEvent.StateChanged(oldst, Leader) -> electionDone.Set() | DiscoEvent.Append(Origin.Service, AddFsTree _) -> appendDone.Set() - | DiscoEvent.Append(_, UpdateProject p) -> updateDone.Set() | DiscoEvent.ConfigurationDone _ -> removeDone.Set() | ev -> () // printfn "ev: %A" ev @@ -101,7 +99,7 @@ module RemoveMemberShouldSplitCluster = | false, false -> failwith "no leader" | true, true -> failwith "two leaders!!" - do leader.RemoveMember otherId + do leader.RemoveMachine otherId do! waitFor "removeDone" removeDone /// remove done on first service do! waitFor "removeDone" removeDone /// remove done on other service @@ -109,9 +107,6 @@ module RemoveMemberShouldSplitCluster = Expect.equal (Map.count service1.RaftServer.Raft.Peers) 1 "Should only have one peer" Expect.equal (Map.count service2.RaftServer.Raft.Peers) 1 "Should only have one peer" - do! waitFor "update project" updateDone - do! waitFor "update project" updateDone - let activeSite = leader.State |> State.project diff --git a/src/Disco/Disco/Tests/Core/Disco/StateShouldBeCleanedOnClientRemove.fs b/src/Disco/Disco/Tests/Core/Disco/StateShouldBeCleanedOnClientRemove.fs index c3f481ea..c30fde61 100644 --- a/src/Disco/Disco/Tests/Core/Disco/StateShouldBeCleanedOnClientRemove.fs +++ b/src/Disco/Disco/Tests/Core/Disco/StateShouldBeCleanedOnClientRemove.fs @@ -25,7 +25,7 @@ module StateShouldBeCleanedOnClientRemove = let test = testCase "state should be clean on client remove" <| fun _ -> - either { + result { use started = new WaitEvent() use batchDone = new WaitEvent() use clientRegistered = new WaitEvent() diff --git a/src/Disco/Disco/Tests/Core/FsTests.fs b/src/Disco/Disco/Tests/Core/FsTests.fs index 73719c1a..5344852d 100644 --- a/src/Disco/Disco/Tests/Core/FsTests.fs +++ b/src/Disco/Disco/Tests/Core/FsTests.fs @@ -25,19 +25,19 @@ module FsTests = FileSystem.rmDir (filepath path) |> ignore let withTree (f: FsTree -> unit) = - withTmpDir (fun path -> FsTree.create (DiscoId.Create()) path Array.empty |> Either.get |> f) + withTmpDir (fun path -> FsTree.create (DiscoId.Create()) path Array.empty |> Result.get |> f) let test_should_have_correct_base_path = testCase "should have correct base path" <| fun _ -> withTmpDir <| fun path -> - let tree = FsTree.create (DiscoId.Create()) path Array.empty |> Either.get + let tree = FsTree.create (DiscoId.Create()) path Array.empty |> Result.get Expect.equal (FsTree.basePath tree) (FsPath.parse path) "Should have correct base path" let test_should_handle_base_path_with_slash = testCase "should handle base path with slash" <| fun _ -> withTmpDir <| fun path -> let withSlash = filepath (unwrap path + "/") - let tree = FsTree.create (DiscoId.Create()) withSlash Array.empty |> Either.get + let tree = FsTree.create (DiscoId.Create()) withSlash Array.empty |> Result.get Expect.equal (FsTree.basePath tree) (FsPath.parse path) "Should have correct base path" let test_fspath_is_sane = diff --git a/src/Disco/Disco/Tests/Core/Generators.fs b/src/Disco/Disco/Tests/Core/Generators.fs index fa5f3b24..6b4fecde 100644 --- a/src/Disco/Disco/Tests/Core/Generators.fs +++ b/src/Disco/Disco/Tests/Core/Generators.fs @@ -80,8 +80,8 @@ module Generators = let uint32Gen = Arb.generate let uint64Gen = Arb.generate - let indexGen = Gen.map index intGen - let termGen = Gen.map term intGen + let indexGen = Gen.map ((*) 1) intGen + let termGen = Gen.map ((*) 1) intGen let nameGen = Gen.map name stringGen let emailGen = Gen.map email stringGen let hashGen = Gen.map checksum stringGen @@ -168,7 +168,7 @@ module Generators = LogDirectory = logpth CollectMetrics = cm MetricsHost = mh - MetricsPort = mhp + MetricsPort = mhp MetricsDb = mdb AssetDirectory = assetpth AssetFilter = assetFilter @@ -211,6 +211,35 @@ module Generators = // |_| \_\__,_|_| \__|_| |_|\___|_| |_| |_|_.__/ \___|_| let raftMemberGen = gen { + let! id = idGen + let! ip = ipGen + let! p = portGen + let! voting = boolGen + let! vfm = boolGen + let! state = raftStateGen + let! status = memberStatusGen + let! nidx = indexGen + let! midx = indexGen + return { + Id = id + IpAddress = ip + RaftPort = p + Voting = voting + VotedForMe = vfm + State = state + Status = status + NextIndex = nidx + MatchIndex = midx + } + } + + /// ____ _ _ __ __ _ + /// / ___| |_ _ ___| |_ ___ _ __| \/ | ___ _ __ ___ | |__ ___ _ __ + /// | | | | | | / __| __/ _ \ '__| |\/| |/ _ \ '_ ` _ \| '_ \ / _ \ '__| + /// | |___| | |_| \__ \ || __/ | | | | | __/ | | | | | |_) | __/ | + /// \____|_|\__,_|___/\__\___|_| |_| |_|\___|_| |_| |_|_.__/ \___|_| + + let clusterMemberGen = gen { let! id = idGen let! n = nameGen let! ip = ipGen @@ -221,12 +250,8 @@ module Generators = let! gp = portGen let! mcst = ipGen let! mp = portGen - let! voting = boolGen - let! vfm = boolGen let! state = raftStateGen let! status = memberStatusGen - let! nidx = indexGen - let! midx = indexGen return { Id = id HostName = n @@ -238,12 +263,8 @@ module Generators = WsPort = wp GitPort = gp ApiPort = ap - Voting = voting - VotedForMe = vfm State = state Status = status - NextIndex = nidx - MatchIndex = midx } } @@ -338,7 +359,7 @@ module Generators = let clusterGen = gen { let! id = idGen let! nm = nameGen - let! mems = mapGen raftMemberGen + let! mems = mapGen clusterMemberGen let! groups = Gen.arrayOf hostgroupGen return { Id = id @@ -364,7 +385,7 @@ module Generators = Clients = clients Raft = raft Timing = timing - Sites = sites } + Sites = Array.fold (fun m (site:ClusterConfig) -> Map.add site.Id site m) Map.empty sites } } // ____ _ _ @@ -1142,9 +1163,12 @@ module Generators = let simpleStateMachineGen = [ Gen.map UpdateProject projectGen Gen.constant UnloadProject - Gen.map AddMember raftMemberGen - Gen.map UpdateMember raftMemberGen - Gen.map RemoveMember raftMemberGen + Gen.map AddMember clusterMemberGen + Gen.map UpdateMember clusterMemberGen + Gen.map RemoveMember clusterMemberGen + Gen.map AddMachine raftMemberGen + Gen.map UpdateMachine raftMemberGen + Gen.map RemoveMachine raftMemberGen Gen.map AddClient clientGen Gen.map UpdateClient clientGen Gen.map RemoveClient clientGen @@ -1228,17 +1252,15 @@ module Generators = let! lidx = indexGen let! ltrm = termGen let! entry = - Gen.oneof [ Gen.map (fun (mems, prev) -> RaftLogEntry.Configuration(id, idx, trm, mems, prev)) - (Gen.zip raftMemArr prev) - - Gen.map (fun (chs, prev) -> RaftLogEntry.JointConsensus(id, idx, trm, chs, prev)) - (Gen.zip changeArr prev) - - Gen.map (fun (data, prev) -> RaftLogEntry.LogEntry(id, idx, trm, data, prev)) - (Gen.zip stateMachineGen prev) - - Gen.map (fun (mems, data) -> RaftLogEntry.Snapshot(id, idx, trm, lidx, ltrm, mems, data)) - (Gen.zip raftMemArr stateMachineGen) ] + Gen.oneof [ + Gen.map (fun (mems, prev) -> LogEntry.Configuration(id, idx, trm, mems, prev)) + (Gen.zip raftMemArr prev) + Gen.map (fun (chs, prev) -> LogEntry.JointConsensus(id, idx, trm, chs, prev)) + (Gen.zip changeArr prev) + Gen.map (fun (data, prev) -> LogEntry.LogEntry(id, idx, trm, data, prev)) + (Gen.zip stateMachineGen prev) + Gen.map (fun (mems, data) -> LogEntry.Snapshot(id, idx, trm, lidx, ltrm, mems, data)) + (Gen.zip raftMemArr stateMachineGen) ] return entry } @@ -1406,7 +1428,7 @@ module Generators = // |___/ let machineArb = Arb.fromGen machineGen - + let changeArb = Arb.fromGen changesGen let raftRequestArb = Arb.fromGen raftRequestGen let raftResponseArb = Arb.fromGen raftResponseGen diff --git a/src/Disco/Disco/Tests/Core/GitTests.fs b/src/Disco/Disco/Tests/Core/GitTests.fs index 97795427..e8874bcc 100644 --- a/src/Disco/Disco/Tests/Core/GitTests.fs +++ b/src/Disco/Disco/Tests/Core/GitTests.fs @@ -23,20 +23,20 @@ module GitTests = let tmpdir = mkTmpDir () let mem = - machine.MachineId - |> Member.create - |> Member.setGitPort (port p) + machine + |> Machine.toClusterMember + |> ClusterMember.setGitPort (port p) let config = machine |> Config.create - |> Config.setMembers (Map.ofArray [| (mem.Id,mem) |]) + |> Config.setMembers (Map.ofArray [| (mem.Id, mem) |]) |> Config.setLogLevel Debug let project = let p = - Project.create (Project.ofFilePath tmpdir) "Test Project" machine - |> Either.get + Project.create tmpdir "Test Project" machine + |> Result.get in { p with Config = config } machine, tmpdir, project, mem, project @@ -88,7 +88,7 @@ module GitTests = let test_server_startup = testCase "Server startup" <| fun _ -> - either { + result { let uuid, tmpdir, project, mem, path = mkEnvironment 10000us @@ -101,7 +101,7 @@ module GitTests = let test_server_startup_should_error_on_eaddrinuse = testCase "Server should fail on EADDRINUSE" <| fun _ -> - either { + result { let uuid, tmpdir, project, mem, path = mkEnvironment 10001us @@ -121,8 +121,8 @@ module GitTests = use gitserver2 = GitServer.create mem path do! match gitserver2.Start() with - | Right () -> Left (Other("test","Should have failed to start")) - | Left error -> Right () + | Ok () -> Error (Other("test","Should have failed to start")) + | Error error -> Ok () expect "Should not be runnning" true Service.isStopped gitserver2.Status } @@ -130,7 +130,7 @@ module GitTests = let test_server_availability = testCase "Server availability" <| fun _ -> - either { + result { let port = 10002us let started = new WaitEvent() @@ -153,12 +153,11 @@ module GitTests = let target = mkTmpDir () let repo = - mem - |> Uri.gitUri path.Name + Uri.gitUri path.Name mem.IpAddress mem.GitPort |> unwrap |> Git.Repo.clone target - expect "Should have successfully clone project" true Either.isSuccess repo + expect "Should have successfully clone project" true Result.isSuccess repo } |> noError diff --git a/src/Disco/Disco/Tests/Core/NetTests.fs b/src/Disco/Disco/Tests/Core/NetTests.fs index ea23580a..89e0ca4d 100644 --- a/src/Disco/Disco/Tests/Core/NetTests.fs +++ b/src/Disco/Disco/Tests/Core/NetTests.fs @@ -29,7 +29,7 @@ module NetIntegrationTests = let test_client_should_automatically_reconnect = testCase "client should automatically reconnect" <| fun _ -> - either { + result { let ip = IpAddress.Localhost let prt = port 5555us @@ -69,7 +69,7 @@ module NetIntegrationTests = let test_server_request_handling = testCase "server request handling" <| fun _ -> - either { + result { let rand = new System.Random() use stopper = new WaitEvent() @@ -199,7 +199,7 @@ module NetIntegrationTests = let test_duplicate_server_fails_gracefully = testCase "duplicate server fails gracefully" <| fun _ -> - either { + result { let ip = IpAddress.Localhost let prt = port 5555us @@ -219,15 +219,15 @@ module NetIntegrationTests = return! match server2.Start() with - | Right _ -> Left(Other("test","should have failed")) - | Left _ -> Right () + | Ok _ -> Error(Other("test","should have failed")) + | Error _ -> Ok () } |> noError let test_pub_socket_disposes_properly = testCase "pub socket disposes properly" <| fun _ -> - either { - let mem = DiscoId.Create() |> Member.create + result { + let mem = DiscoId.Create() |> ClusterMember.create use pub = PubSub.create mem do! pub.Start() } diff --git a/src/Disco/Disco/Tests/Core/PersistenceTests.fs b/src/Disco/Disco/Tests/Core/PersistenceTests.fs index 2baf17f2..ceb397aa 100644 --- a/src/Disco/Disco/Tests/Core/PersistenceTests.fs +++ b/src/Disco/Disco/Tests/Core/PersistenceTests.fs @@ -20,18 +20,18 @@ module PersistenceTests = Pin.Sink.toggle (mk()) (rndname()) group (mk()) [| true |] let mkProject () = - either { + result { let root = tmpPath() let name = rndstr() do! MachineConfig.init (konst "127.0.0.1") None (Some root) let machine = MachineConfig.get () - let path = Project.ofFilePath (root filepath name) + let path = root filepath name let! project = Project.create path name machine return machine, project } let mkState () = - either { + result { let! (machine, project) = mkProject () return machine, @@ -51,11 +51,11 @@ module PersistenceTests = let test_persist_add_pinwidgets_correctly = testCase "persist add pinwidgets correctly" <| fun _ -> - either { + result { let widget = mkPinWidget() - let! (machine, state) = mkState () |> Either.map (State.addPinWidget widget |> Tuple.mapSnd) + let! (machine, state) = mkState () |> Result.map (State.addPinWidget widget |> Tuple.mapSnd) let! _ = Persistence.persistEntry state (AddPinWidget widget) - let! loaded = Asset.loadWithMachine (Project.toFilePath state.Project.Path) machine + let! loaded = Asset.loadWithMachine state.Project.Path machine expect "state should contain PinWidget" true (Map.containsKey widget.Id) state.PinWidgets expect "PinWidgets should be the same" state.PinWidgets id loaded.PinWidgets } @@ -63,13 +63,13 @@ module PersistenceTests = let test_persist_add_pinmappings_correctly = testCase "persist add pinmappings correctly" <| fun _ -> - either { + result { let mapping = mkPinMapping() let! (machine, state) = mkState () - |> Either.map (State.addPinMapping mapping |> Tuple.mapSnd) + |> Result.map (State.addPinMapping mapping |> Tuple.mapSnd) let! _ = Persistence.persistEntry state (AddPinMapping mapping) - let! loaded = Asset.loadWithMachine (Project.toFilePath state.Project.Path) machine + let! loaded = Asset.loadWithMachine state.Project.Path machine expect "state should contain PinMapping" true (Map.containsKey mapping.Id) state.PinMappings expect "PinMappings should be the same" state.PinMappings id loaded.PinMappings } @@ -77,11 +77,11 @@ module PersistenceTests = let test_persist_add_pingroups_correctly = testCase "persist add pingroups correctly" <| fun _ -> - either { + result { let group = mkPinGroup() - let! (machine, state) = mkState () |> Either.map (State.addPinGroup group |> Tuple.mapSnd) + let! (machine, state) = mkState () |> Result.map (State.addPinGroup group |> Tuple.mapSnd) let! _ = Persistence.persistEntry state (AddPinGroup group) - let! loaded = Asset.loadWithMachine (Project.toFilePath state.Project.Path) machine + let! loaded = Asset.loadWithMachine state.Project.Path machine expect "state should contain PinGroup" true @@ -94,18 +94,18 @@ module PersistenceTests = let test_persist_remove_pinwidgets_correctly = testCase "persist remove pinwidgets correctly" <| fun _ -> - either { + result { let widget = mkPinWidget() - let! (machine, state) = mkState () |> Either.map (State.addPinWidget widget |> Tuple.mapSnd) + let! (machine, state) = mkState () |> Result.map (State.addPinWidget widget |> Tuple.mapSnd) let! _ = Persistence.persistEntry state (AddPinWidget widget) - let! loaded = Asset.loadWithMachine (Project.toFilePath state.Project.Path) machine + let! loaded = Asset.loadWithMachine state.Project.Path machine expect "state should contain PinWidget" true (Map.containsKey widget.Id) state.PinWidgets expect "PinWidgets should be the same" state.PinWidgets id loaded.PinWidgets let updated = State.removePinWidget widget loaded let! _ = Persistence.persistEntry state (RemovePinWidget widget) - let! loaded = Asset.loadWithMachine (Project.toFilePath updated.Project.Path) machine + let! loaded = Asset.loadWithMachine updated.Project.Path machine expect "state should contain PinWidget" true (Map.containsKey widget.Id >> not) updated.PinWidgets expect "PinWidgets should be the same" updated.PinWidgets id loaded.PinWidgets @@ -114,20 +114,20 @@ module PersistenceTests = let test_persist_remove_pinmappings_correctly = testCase "persist remove pinmappings correctly" <| fun _ -> - either { + result { let mapping = mkPinMapping() let! (machine, state) = mkState () - |> Either.map (State.addPinMapping mapping |> Tuple.mapSnd) + |> Result.map (State.addPinMapping mapping |> Tuple.mapSnd) let! _ = Persistence.persistEntry state (AddPinMapping mapping) - let! loaded = Asset.loadWithMachine (Project.toFilePath state.Project.Path) machine + let! loaded = Asset.loadWithMachine state.Project.Path machine expect "state should contain PinMapping" true (Map.containsKey mapping.Id) state.PinMappings expect "PinMappings should be the same" state.PinMappings id loaded.PinMappings let updated = State.removePinMapping mapping loaded let! _ = Persistence.persistEntry state (RemovePinMapping mapping) - let! loaded = Asset.loadWithMachine (Project.toFilePath updated.Project.Path) machine + let! loaded = Asset.loadWithMachine updated.Project.Path machine expect "state should contain PinMapping" true @@ -140,11 +140,11 @@ module PersistenceTests = let test_persist_remove_pingroups_correctly = testCase "persist remove pingroups correctly" <| fun _ -> - either { + result { let group = mkPinGroup() - let! (machine, state) = mkState () |> Either.map (State.addPinGroup group |> Tuple.mapSnd) + let! (machine, state) = mkState () |> Result.map (State.addPinGroup group |> Tuple.mapSnd) let! _ = Persistence.persistEntry state (AddPinGroup group) - let! loaded = Asset.loadWithMachine (Project.toFilePath state.Project.Path) machine + let! loaded = Asset.loadWithMachine state.Project.Path machine expect "state should contain PinGroup" true @@ -155,7 +155,7 @@ module PersistenceTests = let updated = State.removePinGroup group loaded let! _ = Persistence.persistEntry state (RemovePinGroup group) - let! loaded = Asset.loadWithMachine (Project.toFilePath updated.Project.Path) machine + let! loaded = Asset.loadWithMachine updated.Project.Path machine expect "state should contain PinGroup" true @@ -168,9 +168,9 @@ module PersistenceTests = let test_persist_add_cueplayers_correctly = testCase "persist add cueplayers correctly" <| fun _ -> - either { + result { let player = mkCuePlayer() - let! (machine, state) = mkState () |> Either.map (State.addCuePlayer player |> Tuple.mapSnd) + let! (machine, state) = mkState () |> Result.map (State.addCuePlayer player |> Tuple.mapSnd) let! _ = Persistence.persistEntry state (AddCuePlayer player) let! loaded = Asset.loadWithMachine state.Project.Path machine expect "state should contain CuePlayer" true (Map.containsKey player.Id) state.CuePlayers @@ -180,9 +180,9 @@ module PersistenceTests = let test_persist_remove_cueplayers_correctly = testCase "persist remove cueplayers correctly" <| fun _ -> - either { + result { let player = mkCuePlayer() - let! (machine, state) = mkState () |> Either.map (State.addCuePlayer player |> Tuple.mapSnd) + let! (machine, state) = mkState () |> Result.map (State.addCuePlayer player |> Tuple.mapSnd) let! _ = Persistence.persistEntry state (AddCuePlayer player) let! loaded = Asset.loadWithMachine state.Project.Path machine @@ -204,7 +204,7 @@ module PersistenceTests = let test_persist_add_pin_correctly = testCase "persist add pin correctly" <| fun _ -> - either { + result { let group = mkPinGroup() let pin = @@ -216,9 +216,9 @@ module PersistenceTests = [| true |] |> Pin.setPersisted true - let! (machine, state) = mkState () |> Either.map (State.addPinGroup group |> Tuple.mapSnd) + let! (machine, state) = mkState () |> Result.map (State.addPinGroup group |> Tuple.mapSnd) let! _ = Persistence.persistEntry state (AddPinGroup group) - let! loaded = Asset.loadWithMachine (Project.toFilePath state.Project.Path) machine + let! loaded = Asset.loadWithMachine state.Project.Path machine expect "state should contain PinGroup" true @@ -229,7 +229,7 @@ module PersistenceTests = let updated = State.addPin pin state let! _ = Persistence.persistEntry updated (AddPin pin) - let! loaded = Asset.loadWithMachine (Project.toFilePath updated.Project.Path) machine + let! loaded = Asset.loadWithMachine updated.Project.Path machine expect "state should contain Pin" true @@ -242,7 +242,7 @@ module PersistenceTests = let test_persist_remove_pin_correctly = testCase "persist remove pin correctly" <| fun _ -> - either { + result { let group = mkPinGroup() let pin = @@ -254,9 +254,9 @@ module PersistenceTests = [| true |] |> Pin.setPersisted true - let! (machine, state) = mkState () |> Either.map (State.addPinGroup group |> Tuple.mapSnd) + let! (machine, state) = mkState () |> Result.map (State.addPinGroup group |> Tuple.mapSnd) let! _ = Persistence.persistEntry state (AddPinGroup group) - let! loaded = Asset.loadWithMachine (Project.toFilePath state.Project.Path) machine + let! loaded = Asset.loadWithMachine state.Project.Path machine expect "state should contain PinGroup" true @@ -267,7 +267,7 @@ module PersistenceTests = let updated = State.addPin pin state let! _ = Persistence.persistEntry updated (AddPin pin) - let! loaded = Asset.loadWithMachine (Project.toFilePath updated.Project.Path) machine + let! loaded = Asset.loadWithMachine updated.Project.Path machine expect "state should contain Pin" true @@ -278,7 +278,7 @@ module PersistenceTests = let updated = State.removePin pin updated let! _ = Persistence.persistEntry updated (RemovePin pin) - let! reloaded = Asset.loadWithMachine (Project.toFilePath updated.Project.Path) machine + let! reloaded = Asset.loadWithMachine updated.Project.Path machine expect "state should not contain Pin" true diff --git a/src/Disco/Disco/Tests/Core/ProjectTests.fs b/src/Disco/Disco/Tests/Core/ProjectTests.fs index 9326480e..5fdaf952 100644 --- a/src/Disco/Disco/Tests/Core/ProjectTests.fs +++ b/src/Disco/Disco/Tests/Core/ProjectTests.fs @@ -26,15 +26,15 @@ module ProjectTests = // let loadSaveTest = testCase "Save/Load Project should render equal project values" <| fun _ -> - either { + result { let machine = MachineConfig.create "127.0.0.1" None let path = tmpPath() let name = Path.getFileName path |> unwrap - let! project = Project.create (Project.ofFilePath path) name machine + let! project = Project.create path name machine - let result = Asset.loadWithMachine (Project.toFilePath project.Path) machine + let result = Asset.loadWithMachine project.Path machine do! expectE "Projects should be equal" true ((=) project) result } @@ -49,13 +49,13 @@ module ProjectTests = let dirtyTest = testCase "Project create should render clean repo" <| fun _ -> - either { + result { let machine = MachineConfig.create "127.0.0.1" None let path = tmpPath() let name = Path.getFileName path |> unwrap - let! project = Project.create (Project.ofFilePath path) name machine + let! project = Project.create path name machine let! repo = Project.repository project let! status = Git.Repo.status repo let untracked = status.Untracked.Count() @@ -73,20 +73,20 @@ module ProjectTests = let relpathTest = testCase "Project create should only work on absolute paths" <| fun _ -> - either { + result { let machine = MachineConfig.create "127.0.0.1" None let path = Path.getRandomFileName() - let result = Project.create (Project.ofFilePath path) (unwrap path) machine + let result = Project.create path (unwrap path) machine - expect "Create should have failed" false Either.isSuccess result + expect "Create should have failed" false Result.isSuccess result return! match result with - | Left (GitError("Git.Repo.stage",_)) -> Right () - | Left other -> Left other - | Right other -> Left (Other("relpathTest", sprintf "Should have failed: %A" other)) + | Error (GitError("Git.Repo.stage",_)) -> Ok () + | Error other -> Error other + | Ok other -> Error (Other("relpathTest", sprintf "Should have failed: %A" other)) } |> noError @@ -98,7 +98,7 @@ module ProjectTests = // let testCustomizedCfg = testCase "Save/Load of Project with customized configs" <| fun _ -> - either { + result { let machine = MachineConfig.create "127.0.0.1" None let path = tmpPath() @@ -117,45 +117,53 @@ module ProjectTests = Version = version "1.2.34.4" Required = false }] - let memA = + let raftMemA = { Member.create (DiscoId.Create()) with - HostName = name "moomoo" IpAddress = IpAddress.Parse "182.123.18.2" Status = Running RaftPort = port 1234us } - let memB = + let raftMemB = { Member.create (DiscoId.Create()) with - HostName = name "taataaa" IpAddress = IpAddress.Parse "118.223.8.12" Status = Joining RaftPort = port 1234us } + let clusterMemA = + { Machine.toClusterMember machine with + Id = raftMemA.Id } + + let clusterMemB = + { Machine.toClusterMember machine with + Id = raftMemB.Id } + let groupA: HostGroup = { Name = name "Group A" - ; Members = [| DiscoId.Create() |] - } + Members = [| DiscoId.Create() |] } let groupB: HostGroup = { Name = name "Group B" - ; Members = [| DiscoId.Create() |] - } + Members = [| DiscoId.Create() |] } let cluster = { Id = DiscoId.Create() Name = name "A mighty cool cluster" - Members = Map.ofArray [| (memA.Id,memA); (memB.Id,memB) |] + Members = + Map.ofArray [| + (raftMemA.Id, clusterMemA) + (raftMemB.Id, clusterMemB) + |] Groups = [| groupA; groupB |] } - let! project = Project.create (Project.ofFilePath path) (unwrap fn) machine + let! project = Project.create path (unwrap fn) machine let updated = - Project.updateConfig + Project.setConfig { project.Config with Raft = engineCfg Clients = clientCfg ActiveSite = Some cluster.Id - Sites = [| cluster |] } + Sites = Map [ cluster.Id,cluster ] } project let! commit = DiscoData.saveWithCommit path User.Admin.Signature updated @@ -205,12 +213,12 @@ module ProjectTests = // let saveInitsGit = testCase "Saved Project should be a git repository with yaml file." <| fun _ -> - either { + result { let machine = MachineConfig.create "127.0.0.1" None let path = tmpPath() let name = Path.getFileName path |> unwrap - let! _ = Project.create (Project.ofFilePath path) name machine + let! _ = Project.create path name machine let loaded = Asset.loadWithMachine path machine @@ -223,23 +231,23 @@ module ProjectTests = let getRepo = Project.repository - >> Either.isSuccess + >> Result.isSuccess do! expectE "Projects should have repo" true getRepo loaded let checkDirty (project: DiscoProject) = project |> Project.repository - |> Either.bind Git.Repo.isDirty - |> Either.get + |> Result.bind Git.Repo.isDirty + |> Result.get do! expectE "Projects should not be dirty" false checkDirty loaded let commitCount (project: DiscoProject) = project |> Project.repository - |> Either.map Git.Repo.commitCount - |> Either.get + |> Result.map Git.Repo.commitCount + |> Result.get do! expectE "Projects should have initial commit" 1 commitCount loaded } @@ -253,7 +261,7 @@ module ProjectTests = // let savesMultipleCommits = testCase "Saving project should contain multiple commits" <| fun _ -> - either { + result { let machine = MachineConfig.create "127.0.0.1" None let path = tmpPath() @@ -261,7 +269,7 @@ module ProjectTests = let author1 = "karsten" - let! project = Project.create (Project.ofFilePath path) name machine + let! project = Project.create path name machine let updated = { project with Author = Some author1 } let! commit = DiscoData.saveWithCommit path User.Admin.Signature updated @@ -299,15 +307,15 @@ module ProjectTests = let upToDatePath = testCase "Saving project should always contain an up-to-date path" <| fun _ -> - either { + result { let machine = MachineConfig.create "127.0.0.1" None let path = tmpPath() let name = Path.getFileName path |> unwrap - let! project = Project.create (Project.ofFilePath path) name machine + let! project = Project.create path name machine let! (loaded: DiscoProject) = Asset.loadWithMachine path machine - expect "Project should have correct path" path Project.toFilePath loaded.Path + expect "Project should have correct path" path id loaded.Path let newpath = tmpPath() @@ -315,19 +323,19 @@ module ProjectTests = let! (loaded: DiscoProject) = Asset.loadWithMachine newpath machine - expect "Project should have correct path" newpath Project.toFilePath loaded.Path + expect "Project should have correct path" newpath id loaded.Path } |> noError let saveAsset = testCase "Should save an asset in new commit" <| fun _ -> - either { + result { let machine = MachineConfig.create "127.0.0.1" None let path = tmpPath() let fn = Path.getFileName path |> unwrap - let! project = Project.create (Project.ofFilePath path) fn machine + let! project = Project.create path fn machine let user = { Id = DiscoId.Create() @@ -343,7 +351,7 @@ module ProjectTests = let! (commit, project) = Project.saveAsset user User.Admin project let! (loaded: User) = - let userpath = Project.toFilePath project.Path Asset.path user + let userpath = project.Path Asset.path user File.readText(userpath) |> Yaml.decode @@ -353,15 +361,15 @@ module ProjectTests = let createDefaultUser = testCase "Should create a default admin user" <| fun _ -> - either { + result { let machine = MachineConfig.create "127.0.0.1" None let path = tmpPath() let name = Path.getFileName path |> unwrap - let! project = Project.create (Project.ofFilePath path) name machine + let! project = Project.create path name machine let! (admin: User) = - Project.toFilePath project.Path Asset.path User.Admin + project.Path Asset.path User.Admin |> File.readText |> Yaml.decode diff --git a/src/Disco/Disco/Tests/Core/RaftIntegrationTests.fs b/src/Disco/Disco/Tests/Core/RaftIntegrationTests.fs index 9fddcd6e..797aee13 100644 --- a/src/Disco/Disco/Tests/Core/RaftIntegrationTests.fs +++ b/src/Disco/Disco/Tests/Core/RaftIntegrationTests.fs @@ -27,25 +27,28 @@ module RaftIntegrationTests = let test_validate_correct_req_socket_tracking = testCase "validate correct req socket tracking" <| fun _ -> - either { + result { let machine1 = MachineConfig.create "127.0.0.1" None let machine2 = MachineConfig.create "127.0.0.1" None let mem1 = - machine1.MachineId - |> Member.create - |> Member.setRaftPort (port 8000us) + machine1 + |> Machine.toClusterMember + |> ClusterMember.setRaftPort (port 8000us) let mem2 = - machine2.MachineId - |> Member.create - |> Member.setRaftPort (port 8001us) + machine2 + |> Machine.toClusterMember + |> ClusterMember.setRaftPort (port 8001us) let site = { ClusterConfig.Default with Name = name "Cool Cluster Yo" - Members = Map.ofArray [| (mem1.Id, mem1) - (mem2.Id, mem2) |] } + Members = + Map.ofArray [| + (mem1.Id, mem1) + (mem2.Id, mem2) + |] } let leadercfg = machine1 |> Config.create @@ -61,6 +64,7 @@ module RaftIntegrationTests = let! leader = RaftServer.create leadercfg { new IRaftSnapshotCallbacks with member self.RetrieveSnapshot() = None + member self.PersistSnapshot _ = () member self.PrepareSnapshot() = None } do! leader.Start() @@ -69,6 +73,7 @@ module RaftIntegrationTests = let! follower = RaftServer.create followercfg { new IRaftSnapshotCallbacks with member self.RetrieveSnapshot() = None + member self.PersistSnapshot _ = () member self.PrepareSnapshot() = None } do! follower.Start() @@ -84,15 +89,15 @@ module RaftIntegrationTests = let test_validate_raft_service_bind_correct_port = testCase "validate raft service bind correct port" <| fun _ -> - either { + result { use started = new WaitEvent() let port = port 12000us let machine = MachineConfig.create "127.0.0.1" None let mem = - machine.MachineId - |> Member.create - |> Member.setRaftPort port + machine + |> Machine.toClusterMember + |> ClusterMember.setRaftPort port let site = { ClusterConfig.Default with @@ -107,6 +112,7 @@ module RaftIntegrationTests = use! leader = RaftServer.create leadercfg { new IRaftSnapshotCallbacks with member self.RetrieveSnapshot() = None + member self.PersistSnapshot _ = () member self.PrepareSnapshot() = None } @@ -125,12 +131,13 @@ module RaftIntegrationTests = use! follower = RaftServer.create leadercfg { new IRaftSnapshotCallbacks with member self.RetrieveSnapshot() = None + member self.PersistSnapshot _ = () member self.PrepareSnapshot() = None } do! match follower.Start() with - | Right _ -> Left (Other("test","follower should have failed")) - | Left _ -> Right () + | Ok _ -> Error (Other("test","follower should have failed")) + | Error _ -> Ok () expect "Should be failed" true Service.hasFailed follower.Status } @@ -138,7 +145,7 @@ module RaftIntegrationTests = let test_validate_follower_joins_leader_after_startup = testCase "validate follower joins leader after startup" <| fun _ -> - either { + result { use check1 = new WaitEvent() let setState (id: DiscoId) (are: WaitEvent) = function @@ -153,14 +160,14 @@ module RaftIntegrationTests = let machine2 = MachineConfig.create "127.0.0.1" None let mem1 = - machine1.MachineId - |> Member.create - |> Member.setRaftPort (port 8000us) + machine1 + |> Machine.toClusterMember + |> ClusterMember.setRaftPort (port 8000us) let mem2 = - machine2.MachineId - |> Member.create - |> Member.setRaftPort (port 8001us) + machine2 + |> Machine.toClusterMember + |> ClusterMember.setRaftPort (port 8001us) let site = { ClusterConfig.Default with @@ -183,6 +190,7 @@ module RaftIntegrationTests = use! leader = RaftServer.create leadercfg { new IRaftSnapshotCallbacks with member self.RetrieveSnapshot() = None + member self.PersistSnapshot _ = () member self.PrepareSnapshot() = None } @@ -193,6 +201,7 @@ module RaftIntegrationTests = use! follower = RaftServer.create followercfg { new IRaftSnapshotCallbacks with member self.RetrieveSnapshot() = None + member self.PersistSnapshot _ = () member self.PrepareSnapshot() = None } @@ -206,7 +215,7 @@ module RaftIntegrationTests = let test_log_snapshotting_should_clean_all_logs = testCase "log snapshotting should clean all logs" <| fun _ -> - either { + result { use snapshotCheck = new WaitEvent() use expectedCheck = new WaitEvent() @@ -217,9 +226,9 @@ module RaftIntegrationTests = let store = Store(State.Empty) let mem1 = - machine1.MachineId - |> Member.create - |> Member.setRaftPort (port 8000us) + machine1 + |> Machine.toClusterMember + |> ClusterMember.setRaftPort (port 8000us) let site = { ClusterConfig.Default with @@ -235,6 +244,7 @@ module RaftIntegrationTests = use! leader = RaftServer.create leadercfg { new IRaftSnapshotCallbacks with member self.RetrieveSnapshot() = None + member self.PersistSnapshot _ = () member self.PrepareSnapshot() = snapshotCheck.Set() |> ignore Some store.State @@ -266,7 +276,7 @@ module RaftIntegrationTests = let test_validate_add_member_works = testCase "validate add member works" <| fun _ -> - either { + result { use added = new WaitEvent() use configured = new WaitEvent() use check1 = new WaitEvent() @@ -283,7 +293,7 @@ module RaftIntegrationTests = |> sprintf "%O became follower" |> Logger.debug "test" are.Set() |> ignore - | DiscoEvent.Append(Origin.Raft, AddMember mem) -> + | DiscoEvent.Append(Origin.Raft, AddMachine mem) -> mem.Id |> sprintf "%O was added" |> Logger.debug "test" @@ -299,13 +309,18 @@ module RaftIntegrationTests = let machine2 = MachineConfig.create "127.0.0.1" None let mem1 = - machine1.MachineId - |> Member.create - |> Member.setRaftPort (port 8000us) + machine1 + |> Machine.toClusterMember + |> ClusterMember.setRaftPort (port 8000us) let mem2 = - machine2.MachineId - |> Member.create + machine2 + |> Machine.toClusterMember + |> ClusterMember.setRaftPort (port 8001us) + + let raftMem2 = + machine2 + |> Machine.toRaftMember |> Member.setRaftPort (port 8001us) let site1 = @@ -329,20 +344,22 @@ module RaftIntegrationTests = |> Config.setLogLevel (LogLevel.Debug) use! leader = RaftServer.create leadercfg { - new IRaftSnapshotCallbacks with - member self.RetrieveSnapshot() = None - member self.PrepareSnapshot() = None - } + new IRaftSnapshotCallbacks with + member self.RetrieveSnapshot() = None + member self.PersistSnapshot _ = () + member self.PrepareSnapshot() = None + } use obs1 = leader.Subscribe (setState mem1.Id check1) do! leader.Start() use! follower = RaftServer.create followercfg { - new IRaftSnapshotCallbacks with - member self.RetrieveSnapshot() = None - member self.PrepareSnapshot() = None - } + new IRaftSnapshotCallbacks with + member self.RetrieveSnapshot() = None + member self.PersistSnapshot _ = () + member self.PrepareSnapshot() = None + } use obs2 = follower.Subscribe (setState mem2.Id check2) @@ -351,24 +368,12 @@ module RaftIntegrationTests = do! waitFor "check1" check1 do! waitFor "check2" check2 - leader.AddMember mem2 // add mem2 to cluster + leader.AddMachine raftMem2 // add mem2 to cluster do! waitFor "added" added do! waitFor "configured" configured } |> noError - // _ _ - // _ __ ___ _ __ __| (_)_ __ __ _ - // | '_ \ / _ \ '_ \ / _` | | '_ \ / _` | - // | |_) | __/ | | | (_| | | | | | (_| | - // | .__/ \___|_| |_|\__,_|_|_| |_|\__, | - // |_| |___/ - - let test_follower_join_should_fail_on_duplicate_raftid = - pending "follower join should fail on duplicate raftid" - - let test_all_rafts_should_share_a_common_distributed_event_log = - pending "all rafts should share a common distributed event log" // _ _ _ _____ _ // / \ | | | |_ _|__ ___| |_ ___ @@ -378,17 +383,9 @@ module RaftIntegrationTests = let raftIntegrationTests = testList "Raft Integration Tests" [ - // raft test_validate_correct_req_socket_tracking test_validate_raft_service_bind_correct_port test_validate_follower_joins_leader_after_startup - - // db test_log_snapshotting_should_clean_all_logs - - // cluster changes test_validate_add_member_works - - // test_follower_join_should_fail_on_duplicate_raftid - // test_all_rafts_should_share_a_common_distributed_event_log ] |> testSequenced diff --git a/src/Disco/Disco/Tests/Core/SerializationTests.fs b/src/Disco/Disco/Tests/Core/SerializationTests.fs index 81ced217..557d2817 100644 --- a/src/Disco/Disco/Tests/Core/SerializationTests.fs +++ b/src/Disco/Disco/Tests/Core/SerializationTests.fs @@ -24,9 +24,9 @@ module SerializationTests = let test_binary_machine = testCase "DiscoMachine binary serialization should work" <| fun _ -> - binaryEncDec + binaryEncDec |> Prop.forAll Generators.machineArb - |> Check.QuickThrowOnFailure + |> Check.QuickThrowOnFailure /// _____ ___ __ /// | ___|__|_ _|_ __ / _| ___ @@ -280,58 +280,6 @@ module SerializationTests = |> Prop.forAll Generators.raftResponseArb |> Check.QuickThrowOnFailure - // ____ __ _ - // | _ \ __ _ / _| |_ - // | |_) / _` | |_| __| - // | _ < (_| | _| |_ - // |_| \_\__,_|_| \__| - - let test_save_restore_raft_value_correctly = - testCase "save/restore raft value correctly" <| fun _ -> - either { - let machine = MachineConfig.create "127.0.0.1" None - - let self = - machine.MachineId - |> Member.create - - let mem1 = - DiscoId.Create() - |> Member.create - - let mem2 = - DiscoId.Create() - |> Member.create - - let site = - { ClusterConfig.Default with - Name = name "Cool Cluster Yo" - Members = Map.ofArray [| (self.Id,self) - (mem1.Id, mem1) - (mem2.Id, mem2) |] } - - let config = - machine - |> Config.create - |> Config.addSiteAndSetActive site - - let trm = term 666 - - let! raft = - createRaft config - |> Either.map (Raft.setTerm trm) - - saveRaft config raft - |> Either.mapError Error.throw - |> ignore - - let! loaded = loadRaft config - - expect "Member should be correct" self Raft.self loaded - expect "Term should be correct" trm Raft.currentTerm loaded - } - |> noError - // ____ _ _ // | _ \ _ __ ___ (_) ___ ___| |_ // | |_) | '__/ _ \| |/ _ \/ __| __| @@ -614,7 +562,6 @@ module SerializationTests = test_command_batch test_correct_request_serialization tests_parse_state_deserialization - test_save_restore_raft_value_correctly test_validate_config_change test_validate_user_yaml_serialization test_validate_user_binary_serialization diff --git a/src/Disco/Disco/Tests/Core/StateTests.fs b/src/Disco/Disco/Tests/Core/StateTests.fs index 52678d7b..cc1058e3 100644 --- a/src/Disco/Disco/Tests/Core/StateTests.fs +++ b/src/Disco/Disco/Tests/Core/StateTests.fs @@ -8,6 +8,7 @@ namespace Disco.Tests open Expecto +open System.Collections.Generic open Disco.Core open Disco.Raft @@ -16,7 +17,7 @@ module StateTests = let test_apply_fstree_add_correctly = testCase "should apply fstree add correctly" <| fun _ -> - either { + result { let initial = State.Empty let tree = FsTreeTesting.deepTree 2 let state = State.addFsTree tree initial @@ -26,7 +27,7 @@ module StateTests = let test_apply_fsentry_add_correctly = testCase "should apply fsentry add correctly" <| fun _ -> - either { + result { let tree = FsTreeTesting.deepTree 2 let initial = State.addFsTree tree State.Empty let directory = @@ -51,7 +52,7 @@ module StateTests = let test_apply_fsentry_remove_correctly = testCase "should apply fsentry remove correctly" <| fun _ -> - either { + result { let tree = FsTreeTesting.deepTree 2 let initial = State.addFsTree tree State.Empty let entry = @@ -65,9 +66,22 @@ module StateTests = } |> noError + let test_apply_datasnapshot_correctly = + testCase "should apply datasnapshot correctly" <| fun _ -> + result { + let initial = State.Empty + let cue = Cue.create "Hello" Array.empty + let state = State.addCue cue initial + Expect.contains state.Cues (KeyValuePair(cue.Id, cue)) "should contain cue" + let state = State.update state (DataSnapshot initial) + Expect.equal state initial "should reset the state" + } + |> noError + let stateTests = testList "State Tests" [ test_apply_fstree_add_correctly test_apply_fsentry_add_correctly test_apply_fsentry_remove_correctly + test_apply_datasnapshot_correctly ] diff --git a/src/Disco/Disco/Tests/Core/Synchronization.fs b/src/Disco/Disco/Tests/Core/Synchronization.fs index c588d6fb..ae72c86d 100644 --- a/src/Disco/Disco/Tests/Core/Synchronization.fs +++ b/src/Disco/Disco/Tests/Core/Synchronization.fs @@ -17,7 +17,7 @@ module SynchronizationTests = let test_should_call_monitor_correct_number_of_times = testCase "should call monitor correct number of times" <| fun _ -> - either { + result { use ev = new WaitEvent() async { do! Async.Sleep(1000) diff --git a/src/Disco/Disco/Tests/Core/UtilTests.fs b/src/Disco/Disco/Tests/Core/UtilTests.fs index e528c2b8..6fae958e 100644 --- a/src/Disco/Disco/Tests/Core/UtilTests.fs +++ b/src/Disco/Disco/Tests/Core/UtilTests.fs @@ -23,7 +23,7 @@ module UtilTests = let test_rmdir_should_delete_recursively = testCase "rmdir should delete recursively with read-only items" <| fun _ -> - either { + result { let! dir = Path.getRandomFileName() |> Directory.createDirectory diff --git a/src/Disco/Disco/Tests/Raft/AppendEntriesTests.fs b/src/Disco/Disco/Tests/Raft/AppendEntriesTests.fs index 17af38d4..d94c768e 100644 --- a/src/Disco/Disco/Tests/Raft/AppendEntriesTests.fs +++ b/src/Disco/Disco/Tests/Raft/AppendEntriesTests.fs @@ -30,20 +30,20 @@ module AppendEntries = let peer = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM peer - do! expectM "Should have no current leader" None Raft.currentLeader - do! Raft.setTermM (term 5) + do! addMember peer + do! expectM "Should have no current leader" None RaftState.currentLeader + do! setCurrentTerm 5 let msg = - { Term = term 1 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 0 - ; LeaderCommit = index 0 - ; Entries = None } + { Term = 1 + PrevLogIdx = 0 + PrevLogTerm = 0 + LeaderCommit = 0 + Entries = None } let! result = Raft.receiveAppendEntries (Some peer.Id) msg expect "Request should have failed" true AppendResponse.failed result - do! expectM "Should still not have a leader" None Raft.currentLeader + do! expectM "Should still not have a leader" None RaftState.currentLeader } |> runWithDefaults |> ignore @@ -51,13 +51,13 @@ module AppendEntries = let follower_recv_appendentries_does_not_need_mem = testCase "follower recv appendentries does not need mem" <| fun _ -> raft { - do! Raft.addMemberM (Member.create (DiscoId.Create())) + do! addMember (Member.create (DiscoId.Create())) let msg = - { Term = term 1 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 0 - ; LeaderCommit = index 1 - ; Entries = None } + { Term = 1 + PrevLogIdx = 0 + PrevLogTerm = 0 + LeaderCommit = 1 + Entries = None } let! response = Raft.receiveAppendEntries None msg expect "Request should be success" true AppendResponse.succeeded response @@ -70,24 +70,24 @@ module AppendEntries = raft { let peer = Member.create (DiscoId.Create()) - do! Raft.addMemberM peer - do! Raft.setTermM (term 1) - do! expectM "Should not have a leader" None Raft.currentLeader + do! addMember peer + do! setCurrentTerm 1 + do! expectM "Should not have a leader" None RaftState.currentLeader let msg = { - Term = term 2 - PrevLogIdx = index 0 - PrevLogTerm = term 0 - LeaderCommit = index 0 + Term = 2 + PrevLogIdx = 0 + PrevLogTerm = 0 + LeaderCommit = 0 Entries = None } let! (response: AppendResponse) = Raft.receiveAppendEntries (Some peer.Id) msg expect "Should be successful" true AppendResponse.succeeded response - expect "Response should have term 2" (term 2) AppendResponse.term response + expect "Response should have term 2" 2 AppendResponse.term response - do! expectM "Raft should have term 2" (term 2) Raft.currentTerm - do! expectM "should have leader" (Some peer.Id) Raft.currentLeader + do! expectM "Raft should have term 2" 2 RaftState.currentTerm + do! expectM "should have leader" (Some peer.Id) RaftState.currentLeader } |> runWithDefaults |> ignore @@ -96,18 +96,17 @@ module AppendEntries = testCase "follower recv appendentries does not log if no entries are specified" <| fun _ -> raft { let peer = Member.create (DiscoId.Create()) - do! Raft.addMemberM peer - do! Raft.setStateM Follower - do! expectM "Should have 0 log entries" 0 Raft.numLogs + do! addMember peer + do! setState Follower + do! expectM "Should have 0 log entries" 0 RaftState.numLogs let msg = - { Term = term 1 - ; PrevLogIdx = index 1 - ; PrevLogTerm = term 4 - ; LeaderCommit = index 5 - ; Entries = None - } + { Term = 1 + PrevLogIdx = 1 + PrevLogTerm = 4 + LeaderCommit = 5 + Entries = None } let! response = Raft.receiveAppendEntries (Some peer.Id) msg - do! expectM "Should still have 0 log entries" 0 Raft.numLogs + do! expectM "Should still have 0 log entries" 0 RaftState.numLogs } |> runWithDefaults |> ignore @@ -116,21 +115,20 @@ module AppendEntries = testCase "follower recv appendentries increases log" <| fun _ -> raft { let peer = Member.create (DiscoId.Create()) - do! Raft.addMemberM peer - do! Raft.setStateM Follower - do! expectM "Should log count 0" 0 Raft.numLogs + do! addMember peer + do! setState Follower + do! expectM "Should log count 0" 0 RaftState.numLogs let msg = - { Term = term 3 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 1 - ; LeaderCommit = index 5 - ; Entries = Log.make (term 2) defSM |> Some - } + { Term = 3 + PrevLogIdx = 0 + PrevLogTerm = 1 + LeaderCommit = 5 + Entries = Log.make 2 defSM |> Some } let! response = Raft.receiveAppendEntries (Some peer.Id) msg expect "Should be a success" true AppendResponse.succeeded response - do! expectM "Should have log count 1" 1 Raft.numLogs - let! entry = Raft.getEntryAtM (index 1) - expect "Should have term 2" (term 2) (Option.get >> LogEntry.getTerm) entry + do! expectM "Should have log count 1" 1 RaftState.numLogs + let! entry = entryAt 1 + expect "Should have term 2" 2 (Option.get >> LogEntry.term) entry } |> runWithDefaults |> ignore @@ -139,16 +137,15 @@ module AppendEntries = testCase "follower recv appendentries reply false if doesnt have log at prev log idx which matches prev log term" <| fun _ -> raft { let peer = Member.create (DiscoId.Create()) - do! Raft.addMemberM peer - do! Raft.setTermM (term 2) + do! addMember peer + do! setCurrentTerm 2 let msg = - { Term = term 2 - ; PrevLogIdx = index 1 - ; PrevLogTerm = term 1 - ; LeaderCommit = index 5 - ; Entries = Log.make (term 0) defSM |> Some - } + { Term = 2 + PrevLogIdx = 1 + PrevLogTerm = 1 + LeaderCommit = 5 + Entries = Log.make 0 defSM |> Some } let! response = Raft.receiveAppendEntries (Some peer.Id) msg expect "Should not have succeeded" true AppendResponse.failed response } @@ -158,7 +155,7 @@ module AppendEntries = let _entries_for_conflict_tests (payload : StateMachine array) = raft { for t in payload do - do! Raft.createEntryM t >>= ignoreM + do! createEntry t >>= ignoreM } let follower_recv_appendentries_delete_entries_if_conflict_with_new_entries = @@ -168,7 +165,7 @@ module AppendEntries = raft { let getNth n = - Raft.getEntryAt n >> + RaftState.entryAt n >> Option.get >> LogEntry.data >> Option.get @@ -183,8 +180,8 @@ module AppendEntries = let peer = Member.create (DiscoId.Create()) - do! Raft.addMemberM peer - do! Raft.setTermM (term 1) + do! addMember peer + do! setCurrentTerm 1 do! _entries_for_conflict_tests data // add some log entries @@ -195,20 +192,20 @@ module AppendEntries = } let newer = { - Term = term 2 - PrevLogIdx = index 1 - PrevLogTerm = term 1 - LeaderCommit = index 5 - Entries = Log.make (term 2) addCue |> Some + Term = 2 + PrevLogIdx = 1 + PrevLogTerm = 1 + LeaderCommit = 5 + Entries = Log.make 2 addCue |> Some } let! response = Raft.receiveAppendEntries (Some peer.Id) newer expect "Should have succeeded" true AppendResponse.succeeded response - do! expectM "Should have 2 entries" 2 Raft.numLogs + do! expectM "Should have 2 entries" 2 RaftState.numLogs - do! expectM "First should have 'one' value" (data.[0]) (getNth (index 1)) - do! expectM "second should have 'four' value" (addCue) (getNth (index 2)) + do! expectM "First should have 'one' value" (data.[0]) (getNth 1) + do! expectM "second should have 'four' value" (addCue) (getNth 2) } |> runWithRaft raft' cbs |> ignore @@ -217,7 +214,7 @@ module AppendEntries = testCase "follower recv appendentries delete entries if current idx greater than prev log idx" <| fun _ -> let getNth n = raft { - let! entry = Raft.getEntryAtM n + let! entry = entryAt n return entry |> Option.get |> LogEntry.data } @@ -234,22 +231,21 @@ module AppendEntries = let cbs = Callbacks.Create (ref defSM) :> IRaftCallbacks raft { - do! Raft.addMemberM peer - do! Raft.setTermM (term 1) + do! addMember peer + do! setCurrentTerm 1 do! _entries_for_conflict_tests data // add some log entries let newer = - { Term = term 2 - ; PrevLogIdx = index 1 - ; PrevLogTerm = term 1 - ; LeaderCommit = index 5 - ; Entries = None - } + { Term = 2 + PrevLogIdx = 1 + PrevLogTerm = 1 + LeaderCommit = 5 + Entries = None } let! response = Raft.receiveAppendEntries (Some peer.Id) newer expect "Should have succeeded" true AppendResponse.succeeded response - do! expectM "Should have 1 log entry" 1 Raft.numLogs - let! entry = getNth (index 1) + do! expectM "Should have 1 log entry" 1 RaftState.numLogs + let! entry = getNth 1 expect "Should have correct value" (Some data.[0]) id entry } |> runWithRaft raft' cbs @@ -260,24 +256,23 @@ module AppendEntries = let peer = Member.create (DiscoId.Create()) let log = - LogEntry((DiscoId.Create()), index 2, term 1, DataSnapshot (State.Empty), - Some <| LogEntry((DiscoId.Create()), index 2, term 1, DataSnapshot (State.Empty), None)) + LogEntry((DiscoId.Create()), 2, 1, DataSnapshot (State.Empty), + Some <| LogEntry((DiscoId.Create()), 2, 1, DataSnapshot (State.Empty), None)) raft { - do! Raft.addMemberM peer - do! Raft.setTermM (term 1) + do! addMember peer + do! setCurrentTerm 1 let newer = - { Term = term 1 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 1 - ; LeaderCommit = index 5 - ; Entries = Some log - } + { Term = 1 + PrevLogIdx = 0 + PrevLogTerm = 1 + LeaderCommit = 5 + Entries = Some log } let! response = Raft.receiveAppendEntries (Some peer.Id) newer expect "Should be a success" true AppendResponse.succeeded response - do! expectM "Should have 2 logs" 2 Raft.numLogs + do! expectM "Should have 2 logs" 2 RaftState.numLogs } |> runWithDefaults |> ignore @@ -286,36 +281,35 @@ module AppendEntries = testCase "follower recv appendentries does not add dupe entries already in log" <| fun _ -> let peer = Member.create (DiscoId.Create()) - let entry = LogEntry((DiscoId.Create()), index 2, term 1, DataSnapshot (State.Empty), None) + let entry = LogEntry((DiscoId.Create()), 2, 1, DataSnapshot (State.Empty), None) let log = Log.fromEntries entry let next = - { Term = term 1 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 1 - ; LeaderCommit = index 5 - ; Entries = Some entry - } + { Term = 1 + PrevLogIdx = 0 + PrevLogTerm = 1 + LeaderCommit = 5 + Entries = Some entry } let raft' = defaultServer () let cbs = Callbacks.Create (ref defSM) :> IRaftCallbacks raft { - do! Raft.addMemberM peer - do! Raft.setTermM (term 1) + do! addMember peer + do! setCurrentTerm 1 let! response = Raft.receiveAppendEntries (Some peer.Id) next expect "Should be a success" true AppendResponse.succeeded response let! response = Raft.receiveAppendEntries (Some peer.Id) next expect "Should still be a success" true AppendResponse.succeeded response - do! expectM "Should have log count 1" 1 Raft.numLogs + do! expectM "Should have log count 1" 1 RaftState.numLogs - let log'' = Log.append (Log.make (term 1) (DataSnapshot (State.Empty))) log + let log'' = Log.append (Log.make 1 (DataSnapshot (State.Empty))) log let msg = { next with Entries = log''.Data } let! response = Raft.receiveAppendEntries (Some peer.Id) msg expect "Should be a success" true AppendResponse.succeeded response - do! expectM "Should have 2 entries now" 2 Raft.numLogs + do! expectM "Should have 2 entries now" 2 RaftState.numLogs } |> runWithRaft raft' cbs |> ignore @@ -325,25 +319,24 @@ module AppendEntries = let peer = Member.create (DiscoId.Create()) let log = - LogEntry((DiscoId.Create()), index 0, term 1, DataSnapshot (State.Empty), - Some <| LogEntry((DiscoId.Create()), index 0, term 1, DataSnapshot (State.Empty), - Some <| LogEntry((DiscoId.Create()), index 0, term 1, DataSnapshot (State.Empty), - Some <| LogEntry((DiscoId.Create()), index 0, term 1, DataSnapshot (State.Empty), None)))) + LogEntry((DiscoId.Create()), 0, 1, DataSnapshot (State.Empty), + Some $ LogEntry((DiscoId.Create()), 0, 1, DataSnapshot (State.Empty), + Some $ LogEntry((DiscoId.Create()), 0, 1, DataSnapshot (State.Empty), + Some $ LogEntry((DiscoId.Create()), 0, 1, DataSnapshot (State.Empty), None)))) let msg = - { Term = term 1 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 1 - ; LeaderCommit = index 5 - ; Entries = Some log - } + { Term = 1 + PrevLogIdx = 0 + PrevLogTerm = 1 + LeaderCommit = 5 + Entries = Some log } raft { - do! Raft.addMemberM peer + do! addMember peer let! response = Raft.receiveAppendEntries (Some peer.Id) msg expect "Should have been successful" true AppendResponse.succeeded response - expect "Should have correct CurrentIndex" (index 4) AppendResponse.currentIndex response - do! expectM "Should have commit index 4" (index 4) Raft.commitIndex + expect "Should have correct CurrentIndex" 4 AppendResponse.currentIndex response + do! expectM "Should have commit index 4" 4 RaftState.commitIndex } |> runWithDefaults |> ignore @@ -353,25 +346,24 @@ module AppendEntries = let peer = Member.create (DiscoId.Create()) let log = - LogEntry((DiscoId.Create()), index 0, term 1, DataSnapshot (State.Empty), - Some <| LogEntry((DiscoId.Create()), index 0, term 1, DataSnapshot (State.Empty), - Some <| LogEntry((DiscoId.Create()), index 0, term 1, DataSnapshot (State.Empty), - Some <| LogEntry((DiscoId.Create()), index 0, term 1, DataSnapshot (State.Empty), None)))) + LogEntry((DiscoId.Create()), 0, 1, DataSnapshot (State.Empty), + Some <| LogEntry((DiscoId.Create()), 0, 1, DataSnapshot (State.Empty), + Some <| LogEntry((DiscoId.Create()), 0, 1, DataSnapshot (State.Empty), + Some <| LogEntry((DiscoId.Create()), 0, 1, DataSnapshot (State.Empty), None)))) let msg = - { Term = term 1 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 1 - ; LeaderCommit = index 0 - ; Entries = Some log - } + { Term = 1 + PrevLogIdx = 0 + PrevLogTerm = 1 + LeaderCommit = 0 + Entries = Some log } raft { - do! Raft.addMemberM peer + do! addMember peer let! response1 = Raft.receiveAppendEntries (Some peer.Id) msg - let! response2 = Raft.receiveAppendEntries (Some peer.Id) { msg with PrevLogIdx = index 3; LeaderCommit = index 3; Entries = None } + let! response2 = Raft.receiveAppendEntries (Some peer.Id) { msg with PrevLogIdx = 3; LeaderCommit = 3; Entries = None } expect "Should have been successful" true AppendResponse.succeeded response2 - do! expectM "Should have commit index 3" (index 3) Raft.commitIndex + do! expectM "Should have commit index 3" 3 RaftState.commitIndex } |> runWithDefaults |> ignore @@ -381,29 +373,28 @@ module AppendEntries = testCase "follower recv appendentries failure includes current idx" <| fun _ -> let peer = Member.create (DiscoId.Create()) - let log id = LogEntry(id, index 0, term 1, DataSnapshot (State.Empty), None) + let log id = LogEntry(id, 0, 1, DataSnapshot (State.Empty), None) let msg = - { Term = term 0 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 0 - ; LeaderCommit = index 0 - ; Entries = None - } + { Term = 0 + PrevLogIdx = 0 + PrevLogTerm = 0 + LeaderCommit = 0 + Entries = None } raft { - do! Raft.addMemberM peer - do! Raft.setTermM (term 1) - do! Raft.appendEntryM (log (DiscoId.Create())) >>= ignoreM + do! addMember peer + do! setCurrentTerm 1 + do! appendEntry (log (DiscoId.Create())) >>= ignoreM let! response = Raft.receiveAppendEntries (Some peer.Id) msg expect "Should not be successful" true AppendResponse.failed response - expect "Should have current index 1" (index 1) AppendResponse.currentIndex response + expect "Should have current index 1" 1 AppendResponse.currentIndex response - do! Raft.appendEntryM (log (DiscoId.Create())) >>= ignoreM + do! appendEntry (log (DiscoId.Create())) >>= ignoreM let! response = Raft.receiveAppendEntries (Some peer.Id) msg expect "Should not be successful" true AppendResponse.failed response - expect "Should have current index 2" (index 2) AppendResponse.currentIndex response + expect "Should have current index 2" 2 AppendResponse.currentIndex response } |> runWithDefaults |> ignore @@ -413,19 +404,18 @@ module AppendEntries = let peer = Member.create (DiscoId.Create()) let msg = - { Term = term 1 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 0 - ; LeaderCommit = index 0 - ; Entries = None - } + { Term = 1 + PrevLogIdx = 0 + PrevLogTerm = 0 + LeaderCommit = 0 + Entries = None } raft { - do! Raft.setElectionTimeoutM 1000 - do! Raft.addMemberM peer + do! setElectionTimeout 1000 + do! addMember peer do! Raft.periodic 900 let! response = Raft.receiveAppendEntries (Some peer.Id) msg - do! expectM "Should have timeout elapsed 0" 0 Raft.timeoutElapsed + do! expectM "Should have timeout elapsed 0" 0 RaftState.timeoutElapsed } |> runWithDefaults |> ignore diff --git a/src/Disco/Disco/Tests/Raft/JointConsensusTests.fs b/src/Disco/Disco/Tests/Raft/JointConsensusTests.fs index e4143a6d..8ae681e2 100644 --- a/src/Disco/Disco/Tests/Raft/JointConsensusTests.fs +++ b/src/Disco/Disco/Tests/Raft/JointConsensusTests.fs @@ -23,7 +23,7 @@ module JointConsensus = let server_periodic_executes_all_cfg_changes = testCase "periodic executes all cfg changes" <| fun _ -> - let trm = term 1 + let trm = 1 let response = { Term = trm; Granted = true; Reason = None } @@ -31,9 +31,9 @@ module JointConsensus = let mem2 = Member.create (DiscoId.Create()) let log = - JointConsensus(DiscoId.Create(), index 3, term 0, [| MemberAdded mem2 |], - Some <| JointConsensus(DiscoId.Create(), index 2, term 0, [| MemberRemoved mem1 |], - Some <| JointConsensus(DiscoId.Create(), index 1, term 0, [| MemberAdded mem1 |], None))) + JointConsensus(DiscoId.Create(), 3, 0, [| MemberAdded mem2 |], + Some <| JointConsensus(DiscoId.Create(),2,0, [| MemberRemoved mem1 |], + Some <| JointConsensus(DiscoId.Create(),1,0, [| MemberAdded mem1 |], None))) let getstuff r = Map.toList r.Peers @@ -43,11 +43,11 @@ module JointConsensus = raft { do! Raft.becomeLeader () do! Raft.receiveEntry log >>= ignoreM - let! me = Raft.selfM() + let! me = self () - do! expectM "Should have 1 mems" 1 Raft.numMembers + do! expectM "Should have 1 mems" 1 RaftState.numMembers do! Raft.periodic 10 - do! expectM "Should have 2 mems" 2 Raft.numMembers + do! expectM "Should have 2 mems" 2 RaftState.numMembers do! expectM "Should have correct mems" (List.sort [me.Id; mem2.Id]) getstuff } |> runWithDefaults @@ -59,43 +59,43 @@ module JointConsensus = let mem = Member.create nid2 let mkjc term = - JointConsensus(DiscoId.Create(), index 1, term, [| MemberAdded(mem) |] , None) + JointConsensus(DiscoId.Create(),1, term, [| MemberAdded(mem) |] , None) let mkcnf term mems = - Configuration(DiscoId.Create(), index 1, term, mems , None) + Configuration(DiscoId.Create(),1, term, mems , None) - let ci = ref (index 0) + let ci = ref 0 let state = defaultServer() let cbs = Callbacks.Create (ref defSM) :> IRaftCallbacks let makeResponse() = - { Term = term 0 + { Term = 0 Success = true CurrentIndex = !ci - FirstIndex = index 1 } + FirstIndex = 1 } raft { - do! Raft.setElectionTimeoutM 1000 + do! setElectionTimeout 1000 do! Raft.becomeLeader () - do! expectM "Should have commit idx of zero" (index 0) Raft.commitIndex - do! expectM "Should have mem count of one" 1 Raft.numMembers - let! term = Raft.currentTermM () + do! expectM "Should have commit idx of zero" 0 RaftState.commitIndex + do! expectM "Should have mem count of one" 1 RaftState.numMembers + let! term = currentTerm () // Add the first entry - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx // otherwise we get a StaleResponse error let! one = Raft.receiveEntry (Log.make term defSM) - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id // Add another entry - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx let! two = Raft.receiveEntry (Log.make term defSM) - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id @@ -106,11 +106,11 @@ module JointConsensus = do! expectM "'two' should be committed" true (konst r2) // enter the 2-phase commit for configuration change - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx let! three = Raft.receiveEntry (mkjc term) - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id @@ -118,21 +118,21 @@ module JointConsensus = do! expectM "'three' should be committed" true (konst r3) // call periodic to apply join consensus entry - do! expectM "Should not be in joint-consensus yet" false Raft.inJointConsensus - let! idx = Raft.currentIndexM () + do! expectM "Should not be in joint-consensus yet" false RaftState.inJointConsensus + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 - do! expectM "Should be in joint-consensus now" true Raft.inJointConsensus + do! expectM "Should be in joint-consensus now" true RaftState.inJointConsensus - do! expectM "Should be non-voting mem for start" false (Raft.getMember nid2 >> Option.get >> Member.isVoting) - do! expectM "Should be in joining state for start" Joining (Raft.getMember nid2 >> Option.get >> Member.status) + do! expectM "Should be non-voting mem for start" false (RaftState.getMember nid2 >> Option.get >> Member.isVoting) + do! expectM "Should be in joining state for start" Joining (RaftState.getMember nid2 >> Option.get >> Member.status) // add another regular entry - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx let! four = Raft.receiveEntry (Log.make term defSM) - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id @@ -140,32 +140,32 @@ module JointConsensus = do! expectM "'four' should not be committed" false (konst r4) // and another - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx let! five = Raft.receiveEntry (Log.make term defSM) - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id let! r5 = Raft.responseCommitted five do! expectM "'five' should not be committed" false (konst r5) - do! expectM "Should still be in joint-consensus" true Raft.inJointConsensus + do! expectM "Should still be in joint-consensus" true RaftState.inJointConsensus // call periodic to ensure these are applied - let! idx = Raft.currentIndexM () - ci := idx + index 1 + let! idx = currentIndex () + ci := idx + 1 do! Raft.periodic 1000 - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id // when the server notices that all mems are up-to-date it will atomatically append // a Configuration entry to exit the JointConsensus - do! expectM "Should not be in joint-consensus anymore" false Raft.inJointConsensus - do! expectM "Should have nothing in ConfigChange" None Raft.lastConfigChange + do! expectM "Should not be in joint-consensus anymore" false RaftState.inJointConsensus + do! expectM "Should have nothing in ConfigChange" None RaftState.configChangeEntry let! r6 = Raft.responseCommitted three let! r7 = Raft.responseCommitted four @@ -189,8 +189,8 @@ module JointConsensus = let nid = DiscoId.Create() yield (nid, Member.create nid) |] // create mem in the Raft state - let ci = ref (index 0) - let trm = ref (term 1) + let ci = ref 0 + let trm = ref 1 let lokk = new System.Object() let vote = { Granted = true; Term = !trm; Reason = None } @@ -201,21 +201,21 @@ module JointConsensus = { Term = !trm Success = true CurrentIndex = !ci - FirstIndex = index 1 } + FirstIndex = 1 } raft { let me = snd mems.[0] - do! Raft.setSelfM me - do! Raft.setPeersM (mems |> Map.ofArray) + do! setSelf me + do! setPeers (mems |> Map.ofArray) // same as calling becomeCandidate but not circumventing requestAllVotes - do! Raft.setTermM !trm - do! Raft.resetVotesM () - do! Raft.voteForMyself () - do! Raft.setLeaderM None - do! Raft.setStateM Candidate + do! setCurrentTerm !trm + do! resetVotes () + do! voteForMyself () + do! setLeader None + do! setState Candidate - do! expectM "Should have $n mems" n Raft.numMembers + do! expectM "Should have $n mems" n RaftState.numMembers // _ _ _ _ // ___| | ___ ___| |_(_) ___ _ __ / | @@ -225,16 +225,16 @@ module JointConsensus = // // with the full cluster of 10 mems in total - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - do! expectM "Should use the regular configuration" false Raft.inJointConsensus + do! expectM "Should use the regular configuration" false RaftState.inJointConsensus // we need only 5 votes coming in (plus our own) to make a majority for nid in 1 .. (n / 2) do do! Raft.receiveVoteResponse (fst mems.[int nid]) { vote with Term = !trm } - do! expectM "Should be leader in base configuration" Leader Raft.getState + do! expectM "Should be leader in base configuration" Leader RaftState.state // __ _ // _ __ _____ __ ___ ___ _ __ / _(_) __ _ @@ -242,7 +242,7 @@ module JointConsensus = // | | | | __/\ V V / | (_| (_) | | | | _| | (_| | // |_| |_|\___| \_/\_/ \___\___/|_| |_|_| |_|\__, | // |___/ - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) // we establish a new cluster configuration *without* the last 5 mems let entry = @@ -250,16 +250,16 @@ module JointConsensus = |> Array.take (n / 2) |> Array.map snd |> Log.calculateChanges peers - |> Log.mkConfigChange (term 1) + |> Log.jointConsensus 1 - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx let! response = Raft.receiveEntry entry for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 @@ -273,10 +273,10 @@ module JointConsensus = for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "(1) Should still have correct mem count for new configuration" (n / 2) Raft.numPeers - do! expectM "(1) Should still have correct logical mem count" n Raft.numLogicalPeers - do! expectM "(1) Should still have correct mem count for old configuration" n Raft.numOldPeers - do! expectM "(1) Should have JointConsensus entry as ConfigChange" (LogEntry.getId entry) (Raft.lastConfigChange >> Option.get >> LogEntry.getId) + do! expectM "(1) Should still have correct mem count for new configuration" (n / 2) RaftState.numMembers + do! expectM "(1) Should still have correct logical mem count" n RaftState.numLogicalPeers + do! expectM "(1) Should still have correct mem count for old configuration" n RaftState.numOldMembers + do! expectM "(1) Should have JointConsensus entry as ConfigChange" (LogEntry.id entry) (RaftState.configChangeEntry >> Option.get >> LogEntry.id) // _ _ _ ____ // ___| | ___ ___| |_(_) ___ _ __ |___ \ @@ -287,13 +287,13 @@ module JointConsensus = // now in joint consensus state, with 2 configurations (old and new) // same as calling becomeCandidate but not circumventing requestAllVotes - do! Raft.setTermM (!trm + term 1) - do! Raft.resetVotesM () - do! Raft.voteForMyself () - do! Raft.setLeaderM None - do! Raft.setStateM Candidate + do! setCurrentTerm (!trm + 1) + do! resetVotes () + do! voteForMyself () + do! setLeader None + do! setState Candidate - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t // testing with the new configuration (the mems with the lower id values) @@ -303,7 +303,7 @@ module JointConsensus = let nid = fst <| mems.[int idx] do! Raft.receiveVoteResponse nid { vote with Term = !trm } - do! expectM "Should be leader in joint consensus with votes from the new configuration" Leader Raft.getState + do! expectM "Should be leader in joint consensus with votes from the new configuration" Leader RaftState.state // _ _ _ _____ // ___| | ___ ___| |_(_) ___ _ __ |___ / @@ -314,13 +314,13 @@ module JointConsensus = // still in joint consensus state // same as calling becomeCandidate but not circumventing requestAllVotes - do! Raft.setTermM (!trm + term 1) - do! Raft.resetVotesM () - do! Raft.voteForMyself () - do! Raft.setLeaderM None - do! Raft.setStateM Candidate + do! setCurrentTerm (!trm + 1) + do! resetVotes () + do! voteForMyself () + do! setLeader None + do! setState Candidate - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t // testing with the old configuration (the mems with the higher id @@ -329,7 +329,7 @@ module JointConsensus = let nid = fst mems.[int idx] do! Raft.receiveVoteResponse nid { vote with Term = !trm } - do! expectM "Should be leader in joint consensus with votes from the old configuration" Leader Raft.getState + do! expectM "Should be leader in joint consensus with votes from the old configuration" Leader RaftState.state // __ _ _ _ // _ __ ___ ___ ___ _ __ / _(_) __ _ _ _ _ __ __ _| |_(_) ___ _ __ @@ -339,30 +339,30 @@ module JointConsensus = // is now complete! |___/ // appends Configuration entry - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id // when configuration entry is considered committed, joint-consensus is over - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id do! Raft.periodic 1000 - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "Should only have half the mems" (n / 2) Raft.numMembers - do! expectM "Should have None as ConfigChange" None Raft.lastConfigChange + do! expectM "Should only have half the mems" (n / 2) RaftState.numMembers + do! expectM "Should have None as ConfigChange" None RaftState.configChangeEntry // _ _ _ _ _ // ___| | ___ ___| |_(_) ___ _ __ | || | @@ -373,19 +373,19 @@ module JointConsensus = // with the new configuration only (should not work with mems in old config anymore) // same as calling becomeCandidate but not circumventing requestAllVotes - do! Raft.setTermM (!trm + term 1) - do! Raft.resetVotesM () - do! Raft.voteForMyself () - do! Raft.setLeaderM None - do! Raft.setStateM Candidate + do! setCurrentTerm (!trm + 1) + do! resetVotes () + do! voteForMyself () + do! setLeader None + do! setState Candidate - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t for nid in 1 .. ((n / 2) / 2) do do! Raft.receiveVoteResponse (fst mems.[int nid]) { vote with Term = !trm } - do! expectM "Should be leader in election with regular configuration" Leader Raft.getState + do! expectM "Should be leader in election with regular configuration" Leader RaftState.state // _ _ _ // __ _ __| | __| | _ __ ___ __| | ___ ___ @@ -393,23 +393,23 @@ module JointConsensus = // | (_| | (_| | (_| | | | | | (_) | (_| | __/\__ \ // \__,_|\__,_|\__,_| |_| |_|\___/ \__,_|\___||___/ - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) // we establish a new cluster configuration with 5 new mems let entry = mems |> Array.map snd |> Log.calculateChanges peers - |> Log.mkConfigChange (term 1) + |> Log.jointConsensus 1 - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx let! response = Raft.receiveEntry entry for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 @@ -420,10 +420,10 @@ module JointConsensus = for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "(2) Should still have correct mem count for new configuration 2" n Raft.numPeers - do! expectM "(2) Should still have correct logical mem count 2" n Raft.numLogicalPeers - do! expectM "(2) Should still have correct mem count for old configuration 2" (n / 2) Raft.numOldPeers - do! expectM "(2) Should have JointConsensus entry as ConfigChange 2" (LogEntry.getId entry) (Raft.lastConfigChange >> Option.get >> LogEntry.getId) + do! expectM "(2) Should still have correct mem count for new configuration 2" n RaftState.numMembers + do! expectM "(2) Should still have correct logical mem count 2" n RaftState.numLogicalPeers + do! expectM "(2) Should still have correct mem count for old configuration 2" (n / 2) RaftState.numOldMembers + do! expectM "(2) Should have JointConsensus entry as ConfigChange 2" (LogEntry.id entry) (RaftState.configChangeEntry >> Option.get >> LogEntry.id) // _ _ _ ____ // ___| | ___ ___| |_(_) ___ _ __ | ___| @@ -432,20 +432,20 @@ module JointConsensus = // \___|_|\___|\___|\__|_|\___/|_| |_| |____/ // same as calling becomeCandidate but not circumventing requestAllVotes - do! Raft.setTermM (!trm + term 1) - do! Raft.resetVotesM () - do! Raft.voteForMyself () - do! Raft.setLeaderM None - do! Raft.setStateM Candidate + do! setCurrentTerm (!trm + 1) + do! resetVotes () + do! voteForMyself () + do! setLeader None + do! setState Candidate - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t // should become candidate with the old configuration of 5 mems only for nid in 1 .. ((n / 2) / 2) do do! Raft.receiveVoteResponse (fst mems.[int nid]) { vote with Term = !trm } - do! expectM "Should be leader in election in joint consensus with old configuration" Leader Raft.getState + do! expectM "Should be leader in election in joint consensus with old configuration" Leader RaftState.state // _ _ _ __ // ___| | ___ ___| |_(_) ___ _ __ / /_ @@ -454,28 +454,28 @@ module JointConsensus = // \___|_|\___|\___|\__|_|\___/|_| |_| \___/ // same as calling becomeCandidate but not circumventing requestAllVotes - do! Raft.setTermM (!trm + term 1) - do! Raft.resetVotesM () - do! Raft.voteForMyself () - do! Raft.setLeaderM None - do! Raft.setStateM Candidate + do! setCurrentTerm (!trm + 1) + do! resetVotes () + do! voteForMyself () + do! setLeader None + do! setState Candidate - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t // should become candidate with the new configuration of 10 mems also for id in (n / 2) .. (n - 1) do let nid = fst mems.[int id] - let! result = Raft.getMemberM nid + let! result = getMember nid match result with | Some mem -> // the mems are not able to vote at first, because they will need // to be up to date to do that - do! Raft.updateMemberM { mem with Status = Running; Voting = true } + do! updateMember { mem with Status = Running; Voting = true } do! Raft.receiveVoteResponse nid { vote with Term = !trm } | _ -> failwith "Member not found. :(" - do! expectM "Should be leader in election in joint consensus with new configuration" Leader Raft.getState + do! expectM "Should be leader in election in joint consensus with new configuration" Leader RaftState.state // __ _ _ _ // _ __ ___ ___ ___ _ __ / _(_) __ _ _ _ _ __ __ _| |_(_) ___ _ __ @@ -485,18 +485,18 @@ module JointConsensus = // is now complete. |___/ // append Configuration and wait for it to be committed - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id // make sure Configuration is committed - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 for peer in peers do @@ -506,8 +506,8 @@ module JointConsensus = for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "Should have all the mems" n Raft.numMembers - do! expectM "Should have None as ConfigChange" None Raft.lastConfigChange + do! expectM "Should have all the mems" n RaftState.numMembers + do! expectM "Should have None as ConfigChange" None RaftState.configChangeEntry } |> runWithCBS cbs |> noError @@ -516,8 +516,8 @@ module JointConsensus = testCase "should revert to follower state on config change removal" <| fun _ -> let n = 10 // we want ten mems overall - let ci = ref (index 0) - let trm = ref (term 1) + let ci = ref 0 + let trm = ref 1 let lokk = new System.Object() let mems = @@ -533,23 +533,23 @@ module JointConsensus = { Term = !trm Success = true CurrentIndex = !ci - FirstIndex = index 1 } + FirstIndex = 1 } raft { let self = snd mems.[0] // - do! Raft.setSelfM self + do! setSelf self - do! Raft.setPeersM (mems |> Map.ofArray) + do! setPeers (mems |> Map.ofArray) // same as calling becomeCandidate, but w/o the IO - do! Raft.setTermM !trm - do! Raft.resetVotesM () - do! Raft.voteForMyself () - do! Raft.setLeaderM None - do! Raft.setStateM Candidate + do! setCurrentTerm !trm + do! resetVotes () + do! voteForMyself () + do! setLeader None + do! setState Candidate - do! expectM "Should have be candidate" Candidate Raft.getState - do! expectM "Should have $n mems" n Raft.numMembers + do! expectM "Should have be candidate" Candidate RaftState.state + do! expectM "Should have $n mems" n RaftState.numMembers // _ _ _ _ // ___| | ___ ___| |_(_) ___ _ __ / | @@ -558,16 +558,16 @@ module JointConsensus = // \___|_|\___|\___|\__|_|\___/|_| |_| |_| // // with the full cluster of 10 mems in total - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - do! expectM "Should use the regular configuration" false Raft.inJointConsensus + do! expectM "Should use the regular configuration" false RaftState.inJointConsensus // we need only 5 votes coming in (plus our own) to make a majority for nid in 1 .. (n / 2) do do! Raft.receiveVoteResponse (fst mems.[int nid]) { vote with Term = !trm } - do! expectM "Should be leader in base configuration" Leader Raft.getState + do! expectM "Should be leader in base configuration" Leader RaftState.state // __ _ // _ __ _____ __ ___ ___ _ __ / _(_) __ _ @@ -575,10 +575,10 @@ module JointConsensus = // | | | | __/\ V V / | (_| (_) | | | | _| | (_| | // |_| |_|\___| \_/\_/ \___\___/|_| |_|_| |_|\__, | // |___/ - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) // we establish a new cluster configuration *without* the last 5 mems let entry = @@ -586,13 +586,13 @@ module JointConsensus = |> Array.map snd |> Array.skip (n / 2) |> Log.calculateChanges peers - |> Log.mkConfigChange !trm + |> Log.jointConsensus !trm let! response = Raft.receiveEntry entry for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 @@ -603,11 +603,11 @@ module JointConsensus = for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "Should still have correct mem count for new configuration" (n / 2) Raft.numPeers - do! expectM "Should still have correct logical mem count" n Raft.numLogicalPeers - do! expectM "Should still have correct mem count for old configuration" n Raft.numOldPeers - do! expectM "Should have JointConsensus entry as ConfigChange" (LogEntry.getId entry) (Raft.lastConfigChange >> Option.get >> LogEntry.getId) - do! expectM "Should be found in joint consensus configuration myself" true (Raft.getMember self.Id >> Option.isSome) + do! expectM "Should still have correct mem count for new configuration" (n / 2) RaftState.numMembers + do! expectM "Should still have correct logical mem count" n RaftState.numLogicalPeers + do! expectM "Should still have correct mem count for old configuration" n RaftState.numOldMembers + do! expectM "Should have JointConsensus entry as ConfigChange" (LogEntry.id entry) (RaftState.configChangeEntry >> Option.get >> LogEntry.id) + do! expectM "Should be found in joint consensus configuration myself" true (RaftState.getMember self.Id >> Option.isSome) // __ _ _ _ // _ __ ___ ___ ___ _ __ / _(_) __ _ _ _ _ __ __ _| |_(_) ___ _ __ @@ -617,30 +617,30 @@ module JointConsensus = // is now complete! |___/ // appends a Configuration entry - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1001 for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id // finalizes the joint-consensus mode - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1001 for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id do! Raft.periodic 1001 - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) for peer in peers do do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "Should only have half one mem (myself)" 1 Raft.numMembers - do! expectM "Should have None as ConfigChange" None Raft.lastConfigChange + do! expectM "Should only have half one mem (myself)" 1 RaftState.numMembers + do! expectM "Should have None as ConfigChange" None RaftState.configChangeEntry } |> runWithCBS cbs |> noError @@ -649,14 +649,14 @@ module JointConsensus = testCase "should send appendentries to all servers in joint consensus" <| fun _ -> let lokk = new System.Object() let count = ref 0 - let ci = ref (index 0) - let trm = ref (term 1) + let ci = ref 0 + let trm = ref 1 let init = defaultServer() let cbs = { Callbacks.Create (ref defSM) with SendAppendEntries = fun _ _ -> lock lokk <| fun _ -> count := 1 + !count } :> IRaftCallbacks - // let response = Some { Success = true; Term = !trm; CurrentIndex = !ci; FirstIndex = index 1 } } + // let response = Some { Success = true; Term = !trm; CurrentIndex = !ci; FirstIndex = 1 } } let n = 10 // we want ten mems overall @@ -667,13 +667,13 @@ module JointConsensus = |> Map.ofArray raft { - let! self = Raft.getSelfM () + let! self = self () do! Raft.becomeLeader () // increases term! - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - do! expectM "Should be Leader" Leader Raft.getState + do! expectM "Should be Leader" Leader RaftState.state // __ _ // _ __ _____ __ ___ ___ _ __ / _(_) __ _ @@ -682,7 +682,7 @@ module JointConsensus = // |_| |_|\___| \_/\_/ \___\___/|_| |_|_| |_|\__, | // |___/ adding a ton of mems - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) // we establish a new cluster configuration *without* the last 5 mems // with mem id's 5 - 9 @@ -691,23 +691,23 @@ module JointConsensus = |> Array.map snd |> Array.append [| self |] |> Log.calculateChanges peers - |> Log.mkConfigChange !trm + |> Log.jointConsensus !trm let! response = Raft.receiveEntry entry - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 // need to call periodic apply entry (add mems for real) do! Raft.periodic 1000 // appendAllEntries now called - do! expectM "Should still have correct mem count for new configuration" n Raft.numPeers - do! expectM "Should still have correct logical mem count" n Raft.numLogicalPeers - do! expectM "Should still have correct mem count for old configuration" 1 Raft.numOldPeers - do! expectM "Should have JointConsensus entry as ConfigChange" (LogEntry.getId entry) (Raft.lastConfigChange >> Option.get >> LogEntry.getId) - do! expectM "Should be in joint consensus configuration" true Raft.inJointConsensus + do! expectM "Should still have correct mem count for new configuration" n RaftState.numMembers + do! expectM "Should still have correct logical mem count" n RaftState.numLogicalPeers + do! expectM "Should still have correct mem count for old configuration" 1 RaftState.numOldMembers + do! expectM "Should have JointConsensus entry as ConfigChange" (LogEntry.id entry) (RaftState.configChangeEntry >> Option.get >> LogEntry.id) + do! expectM "Should be in joint consensus configuration" true RaftState.inJointConsensus - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t let! response = Raft.receiveEntry (Log.make !trm defSM) @@ -723,7 +723,7 @@ module JointConsensus = testCase "should send appendentries to all servers in joint consensus" <| fun _ -> let lokk = new System.Object() let count = ref 0 - let trm = ref (term 1) + let trm = ref 1 let init = defaultServer() let cbs = { Callbacks.Create (ref defSM) with SendRequestVote = fun _ _ -> lock lokk <| fun _ -> count := 1 + !count } @@ -739,10 +739,10 @@ module JointConsensus = yield (nid, Member.create nid) |] // create mem in the Raft state raft { - let! self = Raft.getSelfM () + let! self = self () do! Raft.becomeLeader () // increases term! - do! expectM "Should have be Leader" Leader Raft.getState + do! expectM "Should have be Leader" Leader RaftState.state // __ _ // _ __ _____ __ ___ ___ _ __ / _(_) __ _ @@ -751,7 +751,7 @@ module JointConsensus = // |_| |_|\___| \_/\_/ \___\___/|_| |_|_| |_|\__, | // |___/ adding a ton of mems - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) // we establish a new cluster configuration *without* the last 5 mems // with mem id's 5 - 9 @@ -760,22 +760,22 @@ module JointConsensus = |> Array.map snd |> Array.append [| self |] |> Log.calculateChanges peers - |> Log.mkConfigChange (term 1) + |> Log.jointConsensus 1 let! response = Raft.receiveEntry entry do! Raft.periodic 1000 - do! expectM "Should still have correct mem count for new configuration" n Raft.numPeers - do! expectM "Should still have correct logical mem count" n Raft.numLogicalPeers - do! expectM "Should still have correct mem count for old configuration" 1 Raft.numOldPeers - do! expectM "Should have JointConsensus entry as ConfigChange" (LogEntry.getId entry) (Raft.lastConfigChange >> Option.get >> LogEntry.getId) - do! expectM "Should be in joint consensus configuration" true Raft.inJointConsensus + do! expectM "Should still have correct mem count for new configuration" n RaftState.numMembers + do! expectM "Should still have correct logical mem count" n RaftState.numLogicalPeers + do! expectM "Should still have correct mem count for old configuration" 1 RaftState.numOldMembers + do! expectM "Should have JointConsensus entry as ConfigChange" (LogEntry.id entry) (RaftState.configChangeEntry >> Option.get >> LogEntry.id) + do! expectM "Should be in joint consensus configuration" true RaftState.inJointConsensus - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) for peer in peers do - do! Raft.updateMemberM { peer with Status = Running; Voting = true } + do! updateMember { peer with Status = Running; Voting = true } do! Raft.startElection () @@ -795,10 +795,10 @@ module JointConsensus = let self = snd mems.[0] let lokk = new System.Object() - let ci = ref (index 0) - let trm = ref (term 1) + let ci = ref 0 + let trm = ref 1 let count = ref 0 - let init = Raft.create self + let init = RaftState.create self let cbs = { Callbacks.Create (ref defSM) with SendAppendEntries = fun _ _ -> lock lokk <| fun _ -> count := 1 + !count } @@ -808,25 +808,25 @@ module JointConsensus = { Success = true Term = !trm CurrentIndex = !ci - FirstIndex = index 1 } + FirstIndex = 1 } raft { - do! Raft.setPeersM (mems |> Map.ofArray) - do! Raft.setStateM Candidate - do! Raft.setTermM !trm + do! setPeers (mems |> Map.ofArray) + do! setState Candidate + do! setCurrentTerm !trm do! Raft.becomeLeader () // increases term! - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) for peer in peers do do! makeResponse () |> Raft.receiveAppendEntriesResponse peer.Id - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - do! expectM "Should have be Leader" Leader Raft.getState - do! expectM "Should have $n mems" n Raft.numMembers + do! expectM "Should have be Leader" Leader RaftState.state + do! expectM "Should have $n mems" n RaftState.numMembers // __ _ // _ __ _____ __ ___ ___ _ __ / _(_) __ _ @@ -835,7 +835,7 @@ module JointConsensus = // |_| |_|\___| \_/\_/ \___\___/|_| |_|_| |_|\__, | // |___/ - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) // we establish a new cluster configuration *without* the last 5 mems // with mem id's 5 - 9 @@ -844,14 +844,14 @@ module JointConsensus = |> Array.map snd |> Array.take (n / 2) |> Log.calculateChanges peers - |> Log.mkConfigChange !trm + |> Log.jointConsensus !trm let! response = Raft.receiveEntry entry for peer in peers do do! makeResponse () |> Raft.receiveAppendEntriesResponse peer.Id - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! expectM "This count should be correct" ((n - 1) * 2) (!count |> konst) @@ -871,11 +871,11 @@ module JointConsensus = for peer in peers do do! makeResponse () |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "(1) Should still have correct mem count for new configuration" (n / 2) Raft.numPeers - do! expectM "(1) Should still have correct logical mem count" n Raft.numLogicalPeers - do! expectM "(1) Should still have correct mem count for old configuration" n Raft.numOldPeers - do! expectM "(1) Should have JointConsensus entry as ConfigChange" (LogEntry.getId entry) (Raft.lastConfigChange >> Option.get >> LogEntry.getId) - do! expectM "(1) Should be in joint consensus configuration" true Raft.inJointConsensus + do! expectM "(1) Should still have correct mem count for new configuration" (n / 2) RaftState.numMembers + do! expectM "(1) Should still have correct logical mem count" n RaftState.numLogicalPeers + do! expectM "(1) Should still have correct mem count for old configuration" n RaftState.numOldMembers + do! expectM "(1) Should have JointConsensus entry as ConfigChange" (LogEntry.id entry) (RaftState.configChangeEntry >> Option.get >> LogEntry.id) + do! expectM "(1) Should be in joint consensus configuration" true RaftState.inJointConsensus let! committed = Raft.responseCommitted response do! expectM "should have been committed" true (konst committed) @@ -887,26 +887,26 @@ module JointConsensus = // |_| \___| \___\___/|_| |_|_| |_|\__, |\__,_|_| \__,_|\__|_|\___/|_| |_| // is now complete! |___/ - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 for peer in peers do do! makeResponse () |> Raft.receiveAppendEntriesResponse peer.Id - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx do! Raft.periodic 1000 for peer in peers do do! makeResponse () |> Raft.receiveAppendEntriesResponse peer.Id // after this periodic, the new cluster configuraion is applied - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) do! Raft.periodic 1000 for peer in peers do do! makeResponse () |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "(2) Should only have half the mems" (n / 2) Raft.numMembers - do! expectM "(2) Should have None as ConfigChange" None Raft.lastConfigChange + do! expectM "(2) Should only have half the mems" (n / 2) RaftState.numMembers + do! expectM "(2) Should have None as ConfigChange" None RaftState.configChangeEntry // _ _ _ // __ _ __| | __| | _ __ ___ __| | ___ ___ @@ -914,7 +914,7 @@ module JointConsensus = // | (_| | (_| | (_| | | | | | (_) | (_| | __/\__ \ // \__,_|\__,_|\__,_| |_| |_|\___/ \__,_|\___||___/ - let! peers = Raft.getMembersM () >>= (Map.toArray >> Array.map snd >> returnM) + let! peers = getMembers () >>= (Map.toArray >> Array.map snd >> returnM) // we establish a new cluster configuration with 5 new mems let entry = @@ -922,14 +922,14 @@ module JointConsensus = |> Array.map snd |> Array.append [| self |] |> Log.calculateChanges peers - |> Log.mkConfigChange (term 1) + |> Log.jointConsensus 1 let! response = Raft.receiveEntry entry for peer in peers do do! makeResponse () |> Raft.receiveAppendEntriesResponse peer.Id - let! idx = Raft.currentIndexM () + let! idx = currentIndex () ci := idx let! result = Raft.responseCommitted response @@ -943,10 +943,10 @@ module JointConsensus = for peer in peers do do! makeResponse () |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "Should still have correct mem count for new configuration" n Raft.numPeers - do! expectM "Should still have correct logical mem count" n Raft.numLogicalPeers - do! expectM "Should still have correct mem count for old configuration" (n / 2) Raft.numOldPeers - do! expectM "Should have JointConsensus entry as ConfigChange" (LogEntry.getId entry) (Raft.lastConfigChange >> Option.get >> LogEntry.getId) + do! expectM "Should still have correct mem count for new configuration" n RaftState.numMembers + do! expectM "Should still have correct logical mem count" n RaftState.numLogicalPeers + do! expectM "Should still have correct mem count for old configuration" (n / 2) RaftState.numOldMembers + do! expectM "Should have JointConsensus entry as ConfigChange" (LogEntry.id entry) (RaftState.configChangeEntry >> Option.get >> LogEntry.id) let! result = Raft.responseCommitted response do! expectM "Should be committed" true (konst result) diff --git a/src/Disco/Disco/Tests/Raft/LogTests.fs b/src/Disco/Disco/Tests/Raft/LogTests.fs index 98e429e6..b0fe6ab8 100644 --- a/src/Disco/Disco/Tests/Raft/LogTests.fs +++ b/src/Disco/Disco/Tests/Raft/LogTests.fs @@ -26,35 +26,35 @@ module Log = let log_new_log_is_empty = testCase "When create, a log should be empty" <| fun _ -> - let log : RaftLog = Log.empty + let log: Log = Log.empty expect "Should be zero" 0 Log.length log let log_is_non_empty = testCase "When create, a log should not be empty" <| fun _ -> Log.empty - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) |> assume "Should be one" 1 Log.length - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) |> assume "Should be two" 2 Log.length - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) |> assume "Should be three" 3 Log.length |> ignore let log_have_correct_index = testCase "When I add an entry, it should have the correct index" <| fun _ -> Log.empty - |> Log.append (Log.make (term 1) defSM) - |> assume "Should have currentIndex 1" (index 1) Log.getIndex - |> assume "Should have currentTerm 1" (term 1) Log.getTerm + |> Log.append (Log.make 1 defSM) + |> assume "Should have currentIndex 1" 1 Log.index + |> assume "Should have currentTerm 1" 1 Log.term |> assume "Should have no lastTerm" None Log.prevTerm |> assume "Should have no lastIndex" None Log.prevIndex - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) - |> assume "Should have currentIndex 2" (index 2) Log.getIndex - |> assume "Should have currentTerm 1" (term 1) Log.getTerm - |> assume "Should have lastTerm 1" (Some (term 1)) Log.prevTerm - |> assume "Should have lastIndex 1" (Some (index 1)) Log.prevIndex + |> assume "Should have currentIndex 2" 2 Log.index + |> assume "Should have currentTerm 1" 1 Log.term + |> assume "Should have lastTerm 1" (Some 1) Log.prevTerm + |> assume "Should have lastIndex 1" (Some 1) Log.prevIndex |> ignore @@ -66,23 +66,23 @@ module Log = let log = Log.empty - |> Log.append (LogEntry(id1, index 0, term 1, defSM, None)) - |> Log.append (LogEntry(id2, index 0, term 1, defSM, None)) - |> Log.append (LogEntry(id3, index 0, term 1, defSM, None)) + |> Log.append (LogEntry(id1, 0, 1, defSM, None)) + |> Log.append (LogEntry(id2, 0, 1, defSM, None)) + |> Log.append (LogEntry(id3, 0, 1, defSM, None)) - Log.at (index 1) log - |> assume "Should be correct one" id1 (LogEntry.getId << Option.get) + Log.at 1 log + |> assume "Should be correct one" id1 (LogEntry.id << Option.get) |> ignore - Log.at (index 2) log - |> assume "Should also be correct one" id2 (LogEntry.getId << Option.get) + Log.at 2 log + |> assume "Should also be correct one" id2 (LogEntry.id << Option.get) |> ignore - Log.at (index 3) log - |> assume "Should also be correct one" id3 (LogEntry.getId << Option.get) + Log.at 3 log + |> assume "Should also be correct one" id3 (LogEntry.id << Option.get) |> ignore - expect "Should find none at invalid index" None (Log.at (index 8)) log + expect "Should find none at invalid index" None (Log.at 8) log let log_find_by_id = testCase "When I get an entry by index, it should be equal" <| fun _ -> @@ -92,20 +92,20 @@ module Log = let log = Log.empty - |> Log.append (LogEntry(id1, index 0, term 1, defSM, None)) - |> Log.append (LogEntry(id2, index 0, term 1, defSM, None)) - |> Log.append (LogEntry(id3, index 0, term 1, defSM, None)) + |> Log.append (LogEntry(id1, 0, 1, defSM, None)) + |> Log.append (LogEntry(id2, 0, 1, defSM, None)) + |> Log.append (LogEntry(id3, 0, 1, defSM, None)) Log.find id1 log - |> assume "Should be correct one" id1 (LogEntry.getId << Option.get) + |> assume "Should be correct one" id1 (LogEntry.id << Option.get) |> ignore Log.find id2 log - |> assume "Should also be correct one" id2 (LogEntry.getId << Option.get) + |> assume "Should also be correct one" id2 (LogEntry.id << Option.get) |> ignore Log.find id3 log - |> assume "Should also be correct one" id3 (LogEntry.getId << Option.get) + |> assume "Should also be correct one" id3 (LogEntry.id << Option.get) |> ignore Log.find (DiscoId.Create()) log @@ -115,12 +115,12 @@ module Log = let log_depth_test = testCase "Should have the correct log depth" <| fun _ -> Log.empty - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) |> assume "Should have length 3" 3 Log.length - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) |> assume "Should have depth 5" 5 Log.length |> ignore @@ -129,11 +129,11 @@ module Log = let sm = AddCue { Id = DiscoId.Create(); Name = name "Wonderful"; Slices = [| |] } let log = Log.empty - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) sm) - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 sm) + |> Log.append (Log.make 1 defSM) - let folder (m: int) (log: RaftLogEntry) : Continue = + let folder (m: int) (log: LogEntry) : Continue = let value = (LogEntry.data >> Option.get) log if value = sm then LogEntry.finish (m + 9) @@ -149,14 +149,14 @@ module Log = testCase "Should have correct length" <| fun _ -> let log = Log.empty - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) log - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) |> assume "Should have length 6" 6 Log.length |> ignore @@ -164,20 +164,20 @@ module Log = testCase "Should have monotonic index" <| fun _ -> let isMonotonic log = let __mono (last,ret) _log = - let i = LogEntry.getIndex _log - if ret then (i, i = (last + index 1)) else (i, ret) - Log.foldLogR __mono (index 0,true) log + let i = LogEntry.index _log + if ret then (i, i = (last + 1)) else (i, ret) + Log.foldLogR __mono (0,true) log let log = Log.empty - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) log - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) - |> Log.append (Log.make (term 1) defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) + |> Log.append (Log.make 1 defSM) |> assume "Should be monotonic" true (isMonotonic >> snd) |> ignore @@ -196,13 +196,13 @@ module Log = log Log.empty - |> Log.append (Log.make (term 1) (AddCue cues.[0])) - |> Log.append (Log.make (term 1) (AddCue cues.[1])) - |> Log.append (Log.make (term 1) (AddCue cues.[2])) - |> Log.append (Log.make (term 1) (AddCue cues.[3])) - |> Log.append (Log.make (term 1) (AddCue cues.[4])) - |> Log.append (Log.make (term 1) (AddCue cues.[5])) - |> Log.until (index 4) + |> Log.append (Log.make 1 (AddCue cues.[0])) + |> Log.append (Log.make 1 (AddCue cues.[1])) + |> Log.append (Log.make 1 (AddCue cues.[2])) + |> Log.append (Log.make 1 (AddCue cues.[3])) + |> Log.append (Log.make 1 (AddCue cues.[4])) + |> Log.append (Log.make 1 (AddCue cues.[5])) + |> Log.until 4 |> assume "Should have 3 logs" 3 (Option.get >> LogEntry.depth) |> assume "Should have log with these values" [AddCue cues.[5]; AddCue cues.[4]; AddCue cues.[3]] (Option.get >> getData) |> ignore @@ -212,10 +212,10 @@ module Log = let id1 = DiscoId.Create() let id2 = DiscoId.Create() - let term = term 1 + let term = 1 - let idx1 = index 1 - let idx2 = index 2 + let idx1 = 1 + let idx2 = 2 let entries = LogEntry(id2,idx2,term,DataSnapshot (State.Empty), @@ -231,9 +231,9 @@ module Log = let id1 = DiscoId.Create() let id2 = DiscoId.Create() - let term = term 1 - let idx1 = index 1 - let idx2 = index 2 + let term = 1 + let idx1 = 1 + let idx2 = 2 let entries = LogEntry(id2,idx2,term,DataSnapshot(State.Empty), @@ -250,10 +250,10 @@ module Log = let id2 = DiscoId.Create() let id3 = DiscoId.Create() - let term = term 1 - let idx1 = index 1 - let idx2 = index 2 - let idx3 = index 3 + let term = 1 + let idx1 = 1 + let idx2 = 2 + let idx3 = 3 let entires = LogEntry(id2,idx2,term,DataSnapshot(State.Empty), @@ -268,12 +268,12 @@ module Log = Log.append newer log |> assume "Should have length 3" 3 Log.length - |> expect "Should have proper id" id3 (Log.entries >> Option.get >> LogEntry.getId) + |> expect "Should have proper id" id3 (Log.entries >> Option.get >> LogEntry.id) let log_snapshot_remembers_last_state = testCase "snapshot remembers last state" <| fun _ -> - let term = term 8 + let term = 8 let data = [ for i in 0 .. 3 do yield DataSnapshot(State.Empty) ] @@ -288,7 +288,7 @@ module Log = Log.snapshot mems (DataSnapshot(State.Empty)) log |> assume "Should have correct lastTerm" (Some term) Log.lastTerm - |> expect "Should have correct lastIndex" (Some <| Log.getIndex log) Log.lastIndex + |> expect "Should have correct lastIndex" (Some <| Log.index log) Log.lastIndex let log_untilExcluding_should_return_expected_enries = testCase "untilExcluding should return expected enries" <| fun _ -> @@ -300,18 +300,18 @@ module Log = Name = name (string n) Slices = Array.empty } ] - |> List.fold (fun m s -> Log.append (Log.make (term 0) s) m) Log.empty + |> List.fold (fun m s -> Log.append (Log.make 0 s) m) Log.empty |> assume "Should be at correct index" num Log.length - |> assume "Should pick correct item" (index 16) (Log.untilExcluding (index 15) >> Option.get >> LogEntry.last >> LogEntry.getIndex) - |> assume "Should have correct index" (AddCue { Id = id; Name = name "16"; Slices = [| |] } |> Some) (Log.untilExcluding (index 15) >> Option.get >> LogEntry.last >> LogEntry.data) - |> assume "Should have correct index" (AddCue { Id = id; Name = name "15"; Slices = [| |] } |> Some) (Log.until (index 15) >> Option.get >> LogEntry.last >> LogEntry.data) + |> assume "Should pick correct item" 16 (Log.untilExcluding 15 >> Option.get >> LogEntry.last >> LogEntry.index) + |> assume "Should have correct index" (AddCue { Id = id; Name = name "16"; Slices = [| |] } |> Some) (Log.untilExcluding 15 >> Option.get >> LogEntry.last >> LogEntry.data) + |> assume "Should have correct index" (AddCue { Id = id; Name = name "15"; Slices = [| |] } |> Some) (Log.until 15 >> Option.get >> LogEntry.last >> LogEntry.data) |> ignore let log_append_should_work_with_snapshots_too = testCase "append should work with snapshots too" <| fun _ -> let log = Log.empty - |> Log.append (Snapshot(DiscoId.Create(), index 0, term 0, index 9, term 1, Array.empty, DataSnapshot(State.Empty))) + |> Log.append (Snapshot(DiscoId.Create(), 0, 0, 9, 1, Array.empty, DataSnapshot(State.Empty))) expect "Log should be size 1" 1 Log.length log @@ -324,7 +324,7 @@ module Log = let combine a b = (a, b) - let def = LogEntry(DiscoId.Create(),index 0,term 0,defSM,None) + let def = LogEntry(DiscoId.Create(),0,0,defSM,None) let folder log (id,term,index) = LogEntry(id,index,term,defSM,Some log) @@ -332,7 +332,7 @@ module Log = [ for trm in 1 .. 4 do let offset = random.Next(1,60) for idx in offset .. offset + random.Next(10,70) do - let (_,t,i) as result = (DiscoId.Create(), term trm, index idx) + let (_,t,i) as result = (DiscoId.Create(), 1 * trm, 1 * idx) if idx = offset then fidxs := (t,i) :: !fidxs yield result ] @@ -341,8 +341,8 @@ module Log = |> combine (!fidxs |> Map.ofList) for trm in 1 .. 4 do - let fidx = Log.firstIndex (term trm) log - let result = Map.tryFind (term trm) indices + let fidx = Log.firstIndex (1 * trm) log + let result = Map.tryFind (1 * trm) indices expect "Should be equal" result id fidx let log_getn_should_return_right_number_of_entries = @@ -352,7 +352,7 @@ module Log = let log = [ for n in 0 .. (n - 1) do yield DataSnapshot(State.Empty) ] - |> List.fold (fun m n -> Log.append (Log.make (term 0) n) m) Log.empty + |> List.fold (fun m n -> Log.append (Log.make 0 n) m) Log.empty expect "should have correct depth" n Log.length log diff --git a/src/Disco/Disco/Tests/Raft/RaftTestUtils.fs b/src/Disco/Disco/Tests/Raft/RaftTestUtils.fs index 76cb50c9..dfcc329c 100644 --- a/src/Disco/Disco/Tests/Raft/RaftTestUtils.fs +++ b/src/Disco/Disco/Tests/Raft/RaftTestUtils.fs @@ -46,9 +46,9 @@ module RaftTestUtils = { SendRequestVote : RaftMember -> VoteRequest -> unit SendAppendEntries : RaftMember -> AppendEntries -> unit SendInstallSnapshot : RaftMember -> InstallSnapshot -> unit - PersistSnapshot : RaftLogEntry -> unit - PrepareSnapshot : RaftState -> RaftLog option - RetrieveSnapshot : unit -> RaftLogEntry option + PersistSnapshot : LogEntry -> unit + PrepareSnapshot : RaftState -> Log option + RetrieveSnapshot : unit -> LogEntry option ApplyLog : StateMachine -> unit MemberAdded : RaftMember -> unit MemberUpdated : RaftMember -> unit @@ -59,8 +59,8 @@ module RaftTestUtils = LeaderChanged : MemberId option -> unit PersistVote : RaftMember option -> unit PersistTerm : Term -> unit - PersistLog : RaftLogEntry -> unit - DeleteLog : RaftLogEntry -> unit + PersistLog : LogEntry -> unit + DeleteLog : LogEntry -> unit LogMsg : RaftMember -> CallSite -> LogLevel -> String -> unit } interface IRaftCallbacks with @@ -99,7 +99,7 @@ module RaftTestUtils = PrepareSnapshot = fun raft -> Raft.createSnapshot raft !data |> Some - PersistSnapshot = fun (entry: RaftLogEntry) -> + PersistSnapshot = fun (entry: LogEntry) -> if debug then sprintf "Perisisting Snapshot: %A" entry |> Logger.debug "PersistSnapshot" @@ -161,7 +161,7 @@ module RaftTestUtils = let defaultServer () = DiscoId.Create() |> Member.create - |> Raft.create + |> RaftState.create let runWithCBS cbs action = let raft = defaultServer() @@ -174,9 +174,8 @@ module RaftTestUtils = let defSM = mkTmpDir() - |> Project.ofFilePath |> mkState - |> Either.get + |> Result.get |> StateMachine.DataSnapshot let runWithDefaults action = @@ -226,12 +225,12 @@ module RaftTestUtils = let runWithRaft r c m = runRaft r c m let expectError e = function - | Left (e',_) when e = e' -> () - | Left (e',_) when e <> e' -> + | Error (e',_) when e = e' -> () + | Error (e',_) when e <> e' -> Expecto.Tests.failtestf "Expected error: %A but got: %A" e e' | _ as v -> Expecto.Tests.failtestf "Expected error but got: %A" v let noError = function - | Left (e,_) -> failwithf "ERROR: %A" e + | Error (e,_) -> failwithf "ERROR: %A" e | _ -> () diff --git a/src/Disco/Disco/Tests/Raft/Scenarios.fs b/src/Disco/Disco/Tests/Raft/Scenarios.fs index b60ef9bc..b681850c 100644 --- a/src/Disco/Disco/Tests/Raft/Scenarios.fs +++ b/src/Disco/Disco/Tests/Raft/Scenarios.fs @@ -84,7 +84,7 @@ module Scenarios = raft { match msg with | RequestVote(sid,req) -> - let! peer = Raft.getMemberM sid + let! peer = getMember sid if Option.isSome peer then let sender = Option.get peer @@ -92,7 +92,7 @@ module Scenarios = let! response = Raft.receiveVoteRequest sid req let! raft' = get - let receiver = Raft.self raft' + let receiver = RaftState.self raft' if not response.Granted then __logg <| sprintf "(1) result was not granted" let updated = { response with Term = raft'.CurrentTerm } @@ -110,8 +110,8 @@ module Scenarios = if not response.Success then __logg "(2) result was Fail" let! raft' = get - let sender = Raft.self raft' - let! peer = Raft.getMemberM sid + let sender = RaftState.self raft' + let! peer = getMember sid match peer with | Some receiver -> let msg = AppendEntriesResponse(sender.Id, response) @@ -125,7 +125,7 @@ module Scenarios = raft { let! raft' = get - let receiver = Map.find raft'.Member.Id peers + let receiver = Map.find raft'.MemberId peers let inbox = (!receiver).Inbox let outbox = (!receiver).Inbox @@ -197,9 +197,9 @@ module Scenarios = } :> IRaftCallbacks let raft = - Raft.create peers.[int n] - |> Raft.setElectionTimeout 500 - |> Raft.addMembers (Array.map toPair peers |> Map.ofArray) + RaftState.create peers.[int n] + |> RaftState.setElectionTimeout 500 + |> RaftState.addMembers (Array.map toPair peers |> Map.ofArray) yield (raft,callbacks) |] @@ -209,7 +209,7 @@ module Scenarios = |> fun result -> Array.set servers 0 (result, snd servers.[0]) - expect "Should be candidate now" Candidate Raft.getState (fst servers.[0]) + expect "Should be candidate now" Candidate RaftState.state (fst servers.[0]) for j in 0..19 do Map.fold totalMsgs 0 senders @@ -219,7 +219,7 @@ module Scenarios = while anyMsgs senders do for idx in 0UL .. (numPeers - 1UL) do let srv = servers.[int idx] - __logg <| sprintf "[raft: %d] [state: %A]" idx (fst srv).State + __logg <| sprintf "[raft: %d] [state: %A]" idx (fst srv).Member.State pollMsgs senders |> evalRaft (fst srv) (snd srv) @@ -233,7 +233,7 @@ module Scenarios = |> fun r -> Array.set servers (int n) (r, snd srv) let __fldr result raft = - if Raft.isLeader raft then result + 1 else result + if RaftState.isLeader raft then result + 1 else result let leaders = Array.map fst servers |> Array.fold __fldr 0 Expect.equal leaders 1 "System should have have one leader" diff --git a/src/Disco/Disco/Tests/Raft/ServerTests.fs b/src/Disco/Disco/Tests/Raft/ServerTests.fs index e5ebac4a..eeaa91bf 100644 --- a/src/Disco/Disco/Tests/Raft/ServerTests.fs +++ b/src/Disco/Disco/Tests/Raft/ServerTests.fs @@ -26,14 +26,14 @@ module ServerTests = testCase "Raft server voted for records who we voted for" <| fun _ -> let id1 = DiscoId.Create() raft { - do! expectM "Should one mem" 1 Raft.numMembers - do! Raft.addMemberM (Member.create id1) - do! expectM "Should two mems" 2 Raft.numMembers + do! expectM "Should one mem" 1 RaftState.numMembers + do! addMember (Member.create id1) + do! expectM "Should two mems" 2 RaftState.numMembers - let! mem = Raft.getMemberM id1 - do! Raft.voteFor mem + let! mem = getMember id1 + do! voteFor mem - do! expectM "Should have voted for last id" id1 (Raft.votedFor >> Option.get) + do! expectM "Should have voted for last id" id1 (RaftState.votedFor >> Option.get) } |> runWithDefaults |> noError @@ -41,13 +41,13 @@ module ServerTests = let server_idx_starts_at_one = testCase "Raft server index should start at 1" <| fun _ -> raft { - do! expectM "Should have default idx" (index 0) Raft.currentIndex - do! Raft.createEntryM (DataSnapshot (State.Empty)) >>= ignoreM - do! expectM "Should have current idx" (index 1) Raft.currentIndex - do! Raft.createEntryM (DataSnapshot (State.Empty)) >>= ignoreM - do! expectM "Should have current idx" (index 2) Raft.currentIndex - do! Raft.createEntryM (DataSnapshot (State.Empty)) >>= ignoreM - do! expectM "Should have current idx" (index 3) Raft.currentIndex + do! expectM "Should have default idx" (0) RaftState.currentIndex + do! createEntry (DataSnapshot (State.Empty)) >>= ignoreM + do! expectM "Should have current idx" (1) RaftState.currentIndex + do! createEntry (DataSnapshot (State.Empty)) >>= ignoreM + do! expectM "Should have current idx" (2) RaftState.currentIndex + do! createEntry (DataSnapshot (State.Empty)) >>= ignoreM + do! expectM "Should have current idx" (3) RaftState.currentIndex } |> runWithDefaults |> noError @@ -55,7 +55,7 @@ module ServerTests = let server_currentterm_defaults_to_zero = testCase "Raft server current Term should default to zero" <| fun _ -> raft { - do! expectM "Should be Zero" (term 0) Raft.currentTerm // + do! expectM "Should be Zero" 0 RaftState.currentTerm // } |> runWithDefaults |> noError @@ -63,8 +63,8 @@ module ServerTests = let server_set_currentterm_sets_term = testCase "Raft server set term sets term" <| fun _ -> raft { - do! Raft.setTermM (term 5) - do! expectM "Should be correct term" (term 5) Raft.currentTerm + do! setCurrentTerm 5 + do! expectM "Should be correct term" 5 RaftState.currentTerm } |> runWithDefaults |> noError @@ -76,12 +76,12 @@ module ServerTests = raft { // add mem and vote for it - do! Raft.addMemberM mem1 - do! Raft.voteFor (Some mem1) - do! expectM "should be correct id" mem1.Id (Raft.votedFor >> Option.get) - do! Raft.addMemberM mem2 - do! Raft.voteFor (Some mem2) - do! expectM "should be correct id" mem2.Id (Raft.votedFor >> Option.get) + do! addMember mem1 + do! voteFor (Some mem1) + do! expectM "should be correct id" mem1.Id (RaftState.votedFor >> Option.get) + do! addMember mem2 + do! voteFor (Some mem2) + do! expectM "should be correct id" mem2.Id (RaftState.votedFor >> Option.get) } |> runWithDefaults |> noError @@ -91,13 +91,13 @@ module ServerTests = let mem = Member.create (DiscoId.Create()) raft { - do! Raft.addNonVotingMemberM mem - let! peer = Raft.getMemberM mem.Id + do! addNonVotingMember mem + let! peer = getMember mem.Id expect "Non-voting mem should not be voting" false Member.isVoting (Option.get peer) - do! Raft.addMemberM mem - let! peer = Raft.getMemberM mem.Id + do! addMember mem + let! peer = getMember mem.Id expect "Member should be voting" true Member.isVoting (Option.get peer) - do! expectM "Should have two mems (incl. self)" 2 Raft.numMembers + do! expectM "Should have two mems (incl. self)" 2 RaftState.numMembers } |> runWithDefaults |> noError @@ -108,14 +108,14 @@ module ServerTests = let mem2 = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM mem1 - do! expectM "Should have Member count of two" 2 Raft.numMembers - do! Raft.addMemberM mem2 - do! expectM "Should have Member count of three" 3 Raft.numMembers - do! Raft.removeMemberM mem1 - do! expectM "Should have Member count of two" 2 Raft.numMembers - do! Raft.removeMemberM mem2 - do! expectM "Should have Member count of one" 1 Raft.numMembers + do! addMember mem1 + do! expectM "Should have Member count of two" 2 RaftState.numMembers + do! addMember mem2 + do! expectM "Should have Member count of three" 3 RaftState.numMembers + do! removeMember mem1 + do! expectM "Should have Member count of two" 2 RaftState.numMembers + do! removeMember mem2 + do! expectM "Should have Member count of one" 1 RaftState.numMembers } |> runWithDefaults |> noError @@ -123,9 +123,9 @@ module ServerTests = let server_election_start_increments_term = testCase "Raft election increments current term" <| fun _ -> raft { - do! Raft.setTermM (term 2) + do! setCurrentTerm 2 do! Raft.startElection () - do! expectM "Raft should have correct term" (term 3) Raft.currentTerm + do! expectM "Raft should have correct term" 3 RaftState.currentTerm } |> runWithDefaults |> noError @@ -134,8 +134,8 @@ module ServerTests = let server_set_state = testCase "Raft set state should set supplied state" <| fun _ -> raft { - do! Raft.setStateM Leader - do! expectM "Raft should be leader now" Leader Raft.getState + do! setState Leader + do! expectM "Raft should be leader now" Leader RaftState.state } |> runWithDefaults |> noError @@ -143,7 +143,7 @@ module ServerTests = let server_starts_as_follower = testCase "Raft starts as follower" <| fun _ -> raft { - do! expectM "Raft state should be Follower" Follower Raft.getState + do! expectM "Raft state should be Follower" Follower RaftState.state } |> runWithDefaults |> noError @@ -158,18 +158,18 @@ module ServerTests = let cbs = Callbacks.Create (ref (DataSnapshot (State.Empty))) :> IRaftCallbacks raft { - do! Raft.setStateM Candidate - do! Raft.setTermM (term 5) + do! setState Candidate + do! setCurrentTerm 5 - do! Raft.createEntryM msg2 >>= ignoreM - let! entry = Raft.getEntryAtM (index 1) + do! createEntry msg2 >>= ignoreM + let! entry = entryAt 1 match Option.get entry with | LogEntry(_,_,_,data,_) -> Expect.equal data msg2 "Should have correct contents" | _ -> failwith "Should be a Log" - do! Raft.createEntryM msg3 >>= ignoreM - let! entry = Raft.getEntryAtM (index 2) + do! createEntry msg3 >>= ignoreM + let! entry = entryAt 2 match Option.get entry with | LogEntry(_,_,_,data,_) -> Expect.equal data msg3 "Should have correct contents" @@ -181,12 +181,12 @@ module ServerTests = let server_wont_apply_entry_if_we_dont_have_entry_to_apply = testCase "Raft won't apply entry if we don't have entry to apply" <| fun _ -> raft { - do! Raft.setCommitIndexM (index 0) - do! Raft.setLastAppliedIdxM (index 0) + do! setCommitIndex 0 + do! setLastAppliedIndex 0 do! Raft.applyEntries () - let! lidx = Raft.lastAppliedIdx() - let! cidx = Raft.commitIndexM() + let! lidx = lastAppliedIndex() + let! cidx = commitIndex () expect "Last applied index should be zero" 0 id lidx expect "Last commit index should be zero" 0 id cidx @@ -205,22 +205,22 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.setCommitIndexM (index 0) - do! Raft.setLastAppliedIdxM (index 0) - do! Raft.addMembersM mems + do! setCommitIndex 0 + do! setLastAppliedIndex 0 + do! addMembers mems do! Raft.applyEntries () - let! lidx = Raft.lastAppliedIdx() - let! cidx = Raft.commitIndexM() + let! lidx = lastAppliedIndex() + let! cidx = commitIndex () expect "Should not have incremented last applied index" 0 id lidx expect "Should not have incremented commit index" 0 id cidx - do! Raft.createEntryM (DataSnapshot (State.Empty)) >>= ignoreM + do! createEntry (DataSnapshot (State.Empty)) >>= ignoreM do! Raft.applyEntries () >>= ignoreM - let! lidx = Raft.lastAppliedIdx() - let! cidx = Raft.commitIndexM() + let! lidx = lastAppliedIndex() + let! cidx = commitIndex () expect "Should not have incremented last applied index" 0 id lidx expect "Should not have incremented commit index" 0 id cidx @@ -232,13 +232,13 @@ module ServerTests = let server_increment_lastApplied_when_lastApplied_lt_commitidx = testCase "Raft increment lastApplied when lastApplied lt commitidx" <| fun _ -> raft { - do! Raft.setStateM Follower - do! Raft.setTermM (term 1) - do! Raft.setLastAppliedIdxM (index 0) - do! Raft.createEntryM (DataSnapshot (State.Empty)) >>= ignoreM - do! Raft.setCommitIndexM (index 1) + do! setState Follower + do! setCurrentTerm 1 + do! setLastAppliedIndex 0 + do! createEntry (DataSnapshot (State.Empty)) >>= ignoreM + do! setCommitIndex 1 do! Raft.periodic 1 - let! lidx = Raft.lastAppliedIdx() + let! lidx = lastAppliedIndex() expect "Should have last applied index 1" 1 id lidx } |> runWithDefaults @@ -247,11 +247,11 @@ module ServerTests = let server_apply_entry_increments_last_applied_idx = testCase "Raft applyEntry increments LastAppliedIndex" <| fun _ -> raft { - do! Raft.setLastAppliedIdxM (index 0) - do! Raft.createEntryM (DataSnapshot (State.Empty)) >>= ignoreM - do! Raft.setCommitIndexM (index 1) + do! setLastAppliedIndex 0 + do! createEntry (DataSnapshot (State.Empty)) >>= ignoreM + do! setCommitIndex 1 do! Raft.applyEntries () - let! lidx = Raft.lastAppliedIdx() + let! lidx = lastAppliedIndex() expect "Should have last applied index 1" 1 id lidx } |> runWithDefaults @@ -260,12 +260,12 @@ module ServerTests = let server_periodic_elapses_election_timeout = testCase "Raft Periodic elapses election timeout" <| fun _ -> raft { - do! Raft.setElectionTimeoutM 1000 - do! expectM "Timeout elapsed should be zero" 0 Raft.timeoutElapsed + do! setElectionTimeout 1000 + do! expectM "Timeout elapsed should be zero" 0 RaftState.timeoutElapsed do! Raft.periodic 0 - do! expectM "Timeout elapsed should be zero" 0 Raft.timeoutElapsed + do! expectM "Timeout elapsed should be zero" 0 RaftState.timeoutElapsed do! Raft.periodic 100 - do! expectM "Timeout elapsed should be 100" 100 Raft.timeoutElapsed + do! expectM "Timeout elapsed should be 100" 100 RaftState.timeoutElapsed } |> runWithDefaults |> noError @@ -273,26 +273,26 @@ module ServerTests = let server_election_timeout_does_no_promote_us_to_leader_if_there_is_only_1_mem = testCase "Election timeout does not promote us to leader if there is only 1 mem" <| fun _ -> raft { - do! Raft.addMemberM (Member.create (DiscoId.Create())) - do! Raft.setElectionTimeoutM 1000 + do! addMember (Member.create (DiscoId.Create())) + do! setElectionTimeout 1000 do! Raft.periodic 1001 - do! expectM "Should not be Leader" false Raft.isLeader + do! expectM "Should not be Leader" false RaftState.isLeader } |> runWithDefaults |> noError let server_recv_entry_auto_commits_if_we_are_the_only_mem = testCase "Receive entry auto-commits if we are the only mem" <| fun _ -> - let entry = LogEntry(DiscoId.Create(),index 0,term 0,DataSnapshot (State.Empty),None) + let entry = LogEntry(DiscoId.Create(),0,0,DataSnapshot (State.Empty),None) raft { - do! Raft.setElectionTimeoutM 1000 + do! setElectionTimeout 1000 do! Raft.becomeLeader () - do! expectM "Should have commit idx 0" (index 0) Raft.commitIndex + do! expectM "Should have commit idx 0" 0 RaftState.commitIndex let! result = Raft.receiveEntry entry - do! expectM "Should have log count 1" 1 Raft.numLogs - do! expectM "Should have commit idx 1" (index 1) Raft.commitIndex + do! expectM "Should have log count 1" 1 RaftState.numLogs + do! expectM "Should have commit idx 1" 1 RaftState.commitIndex } |> runWithDefaults |> noError @@ -301,21 +301,21 @@ module ServerTests = testCase "Receive entry fails if there is already a voting change" <| fun _ -> let mem = Member.create (DiscoId.Create()) let mklog term = - JointConsensus(DiscoId.Create(), index 1, term, [| ConfigChange.MemberAdded(mem) |] , None) + JointConsensus(DiscoId.Create(), 1, term, [| ConfigChange.MemberAdded(mem) |] , None) raft { - do! Raft.setElectionTimeoutM 1000 + do! setElectionTimeout 1000 do! Raft.becomeLeader () - do! expectM "Should have commit idx of zero" (index 0) Raft.commitIndex + do! expectM "Should have commit idx of zero" 0 RaftState.commitIndex - let! term = Raft.currentTermM () + let! term = currentTerm () let! result = Raft.receiveEntry (mklog term) do! Raft.periodic 1000 // important, as only now the changes take effect - do! expectM "Should have log count of one" 1 Raft.numLogs + do! expectM "Should have log count of one" 1 RaftState.numLogs - let! term = Raft.currentTermM () + let! term = currentTerm () return! Raft.receiveEntry (mklog term) } |> runWithDefaults @@ -326,17 +326,17 @@ module ServerTests = let mem = Member.create (DiscoId.Create()) let mklog term = - JointConsensus(DiscoId.Create(), index 1, term, [| ConfigChange.MemberAdded(mem) |] , None) + JointConsensus(DiscoId.Create(), 1, term, [| ConfigChange.MemberAdded(mem) |] , None) raft { - do! Raft.setElectionTimeoutM 1000 + do! setElectionTimeout 1000 do! Raft.becomeLeader () - do! expectM "Should have commit idx of zero" (index 0) Raft.commitIndex - do! expectM "Should have mem count of one" 1 Raft.numMembers - let! term = Raft.currentTermM () + do! expectM "Should have commit idx of zero" 0 RaftState.commitIndex + do! expectM "Should have mem count of one" 1 RaftState.numMembers + let! term = currentTerm () let! result = Raft.receiveEntry (mklog term) do! Raft.periodic 10 - do! expectM "Should have mem count of two" 2 Raft.numMembers + do! expectM "Should have mem count of two" 2 RaftState.numMembers } |> runWithDefaults |> noError @@ -346,38 +346,38 @@ module ServerTests = let nid = DiscoId.Create() let mem = Member.create nid let mklog term = - JointConsensus(DiscoId.Create(), index 1, term, [| ConfigChange.MemberAdded(mem) |] , None) + JointConsensus(DiscoId.Create(), 1, term, [| ConfigChange.MemberAdded(mem) |] , None) raft { - do! Raft.setElectionTimeoutM 1000 + do! setElectionTimeout 1000 do! Raft.becomeLeader () - do! expectM "Should have commit idx of zero" (index 0) Raft.commitIndex - do! expectM "Should have mem count of one" 1 Raft.numMembers + do! expectM "Should have commit idx of zero" 0 RaftState.commitIndex + do! expectM "Should have mem count of one" 1 RaftState.numMembers - let! term = Raft.currentTermM () + let! term = currentTerm () let! result = Raft.receiveEntry (mklog term) do! Raft.periodic 10 - do! expectM "Should be non-voting mem for start" false (Raft.getMember nid >> Option.get >> Member.isVoting) + do! expectM "Should be non-voting mem for start" false (RaftState.getMember nid >> Option.get >> Member.isVoting) } |> runWithDefaults |> noError let server_recv_entry_removes_mem_on_removemem = testCase "recv entry removes mem on removemem" <| fun _ -> - let term = ref (term 0) - let ci = ref (index 0) + let term = ref 0 + let ci = ref 0 let mem = Member.create (DiscoId.Create()) let mklog term = - JointConsensus(DiscoId.Create(), index 1, term, [| ConfigChange.MemberRemoved mem |] , None) + JointConsensus(DiscoId.Create(), 1, term, [| ConfigChange.MemberRemoved mem |] , None) raft { - do! Raft.setElectionTimeoutM 1000 - do! Raft.addMemberM mem + do! setElectionTimeout 1000 + do! addMember mem do! Raft.becomeLeader () - do! expectM "Should have mem count of two" 2 Raft.numMembers + do! expectM "Should have mem count of two" 2 RaftState.numMembers ci := 1 @@ -387,7 +387,7 @@ module ServerTests = Term = !term Success = true CurrentIndex = !ci - FirstIndex = index 1 + FirstIndex = 1 } ci := 2 @@ -395,7 +395,7 @@ module ServerTests = do! Raft.periodic 1000 // after entry was applied, we'll see the change - do! expectM "Should have mem count of one" 1 Raft.numMembers + do! expectM "Should have mem count of one" 1 RaftState.numMembers } |> runWithDefaults |> noError @@ -411,30 +411,30 @@ module ServerTests = raft { for mem in mems do - do! Raft.addMemberM mem - do! expectM "Should have 13 mems now" 13 Raft.numMembers + do! addMember mem + do! expectM "Should have 13 mems now" 13 RaftState.numMembers } |> runWithDefaults |> noError let server_votes_are_majority_is_true = testCase "Vote are majority is majority" <| fun _ -> - Raft.majority 3 1 + RaftState.majority 3 1 |> expect "1) Should not be a majority" false id - Raft.majority 3 2 + RaftState.majority 3 2 |> expect "2) Should be a majority" true id - Raft.majority 5 2 + RaftState.majority 5 2 |> expect "3) Should not be a majority" false id - Raft.majority 5 3 + RaftState.majority 5 3 |> expect "4) Should be a majority" true id - Raft.majority 1 2 + RaftState.majority 1 2 |> expect "5) Should not be a majority" false id - Raft.majority 4 2 + RaftState.majority 4 2 |> expect "6) Should not be a majority" false id let recv_requestvote_response_dont_increase_votes_for_me_when_not_granted = @@ -442,15 +442,15 @@ module ServerTests = let mem = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM mem - do! Raft.setTermM (term 1) - do! Raft.setStateM Candidate - do! expectM "Votes for me should be zero" 0 Raft.numVotesForMe + do! addMember mem + do! setCurrentTerm 1 + do! setState Candidate + do! expectM "Votes for me should be zero" 0 RaftState.numVotesForMe - let! term = Raft.currentTermM () + let! term = currentTerm () let response = { Term = term; Granted = false; Reason = Some OK } let! result = Raft.receiveVoteResponse mem.Id response - do! expectM "Votes for me should be zero" 0 Raft.numVotesForMe + do! expectM "Votes for me should be zero" 0 RaftState.numVotesForMe } |> runWithDefaults |> noError @@ -460,12 +460,12 @@ module ServerTests = let mem = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM mem - do! Raft.setTermM (term 3) - do! Raft.setStateM Candidate - do! expectM "Should have zero votes for me" 0 Raft.numVotesForMe + do! addMember mem + do! setCurrentTerm 3 + do! setState Candidate + do! expectM "Should have zero votes for me" 0 RaftState.numVotesForMe - let response = { Term = term 2; Granted = true; Reason = None } + let response = { Term = 2; Granted = true; Reason = None } return! Raft.receiveVoteResponse mem.Id response } |> runWithDefaults @@ -475,12 +475,12 @@ module ServerTests = testCase "Recv requestvote response increase votes for me" <| fun _ -> let mem = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM mem - do! Raft.setTermM (term 1) - do! expectM "Should have zero votes for me" 0 Raft.numVotesForMe + do! addMember mem + do! setCurrentTerm 1 + do! expectM "Should have zero votes for me" 0 RaftState.numVotesForMe do! Raft.becomeCandidate () - do! Raft.receiveVoteResponse mem.Id { Term = term 2; Granted = true; Reason = None } - do! expectM "Should have two votes for me" 2 Raft.numVotesForMe + do! Raft.receiveVoteResponse mem.Id { Term = 2; Granted = true; Reason = None } + do! expectM "Should have two votes for me" 2 RaftState.numVotesForMe } |> runWithDefaults |> noError @@ -494,9 +494,9 @@ module ServerTests = |> Error.asRaftError "Raft.receiveVoteResponse" raft { - do! Raft.addMemberM mem - do! Raft.setTermM (term 1) - let response = { Term = term 1; Granted = true; Reason = None } + do! addMember mem + do! setCurrentTerm 1 + let response = { Term = 1; Granted = true; Reason = None } do! Raft.receiveVoteResponse mem.Id response } |> runWithDefaults @@ -511,15 +511,15 @@ module ServerTests = |> Error.asRaftError "Raft.receiveVoteResponse" raft { - do! Raft.addMemberM mem - do! Raft.setTermM (term 3) + do! addMember mem + do! setCurrentTerm 3 do! Raft.becomeCandidate () let! response = Raft.receiveVoteResponse mem.Id { - Term = term 3 + Term = 3 Granted = true Reason = None } - do! expectM "Should have term 4" (term 4) Raft.currentTerm + do! expectM "Should have term 4" 4 RaftState.currentTerm } |> runWithDefaults |> expectError err @@ -537,14 +537,14 @@ module ServerTests = let mem = Member.create (DiscoId.Create()) let vote = - { Term = term 1 + { Term = 1 ; Candidate = mem - ; LastLogIndex = index 1 - ; LastLogTerm = term 1 + ; LastLogIndex = 1 + ; LastLogTerm = 1 } raft { - do! Raft.setTermM (term 2) + do! setCurrentTerm 2 let! (res,_) = Raft.shouldGrantVote vote expect "Should not grant vote" false id res } @@ -557,15 +557,15 @@ module ServerTests = let mem = Member.create (DiscoId.Create()) let vote = - { Term = term 2 + { Term = 2 ; Candidate = mem - ; LastLogIndex = index 1 - ; LastLogTerm = term 1 + ; LastLogIndex = 1 + ; LastLogTerm = 1 } raft { - do! Raft.setTermM (term 2) - do! Raft.voteForMyself () + do! setCurrentTerm 2 + do! voteForMyself () let! (res,_) = Raft.shouldGrantVote vote expect "Should not grant vote" false id res } @@ -577,18 +577,18 @@ module ServerTests = let mem = Member.create (DiscoId.Create()) let vote = - { Term = term 1 + { Term = 1 ; Candidate = mem - ; LastLogIndex = index 1 - ; LastLogTerm = term 1 + ; LastLogIndex = 1 + ; LastLogTerm = 1 } raft { - do! Raft.addMemberM mem - do! Raft.setTermM (term 1) - do! Raft.voteFor None - do! expectM "Should have currentIndex zero" (index 0) Raft.currentIndex - do! expectM "Should have voted for nobody" None Raft.votedFor + do! addMember mem + do! setCurrentTerm 1 + do! voteFor None + do! expectM "Should have currentIndex zero" 0 RaftState.currentIndex + do! expectM "Should have voted for nobody" None RaftState.votedFor let! (res,_) = Raft.shouldGrantVote vote expect "Should grant vote" true id res } @@ -600,20 +600,20 @@ module ServerTests = let mem = Member.create (DiscoId.Create()) let vote = - { Term = term 2 + { Term = 2 ; Candidate = mem - ; LastLogIndex = index 1 - ; LastLogTerm = term 2 + ; LastLogIndex = 1 + ; LastLogTerm = 2 } raft { - do! Raft.addMemberM mem - do! Raft.setTermM (term 1) - do! Raft.voteFor None - do! expectM "Should have currentIndex zero" (index 0) Raft.currentIndex - do! Raft.createEntryM (DataSnapshot (State.Empty)) >>= ignoreM - do! Raft.createEntryM (DataSnapshot (State.Empty)) >>= ignoreM - do! expectM "Should have currentIndex one" (index 2) Raft.currentIndex + do! addMember mem + do! setCurrentTerm 1 + do! voteFor None + do! expectM "Should have currentIndex zero" 0 RaftState.currentIndex + do! createEntry (DataSnapshot (State.Empty)) >>= ignoreM + do! createEntry (DataSnapshot (State.Empty)) >>= ignoreM + do! expectM "Should have currentIndex one" 2 RaftState.currentIndex let! (res,_) = Raft.shouldGrantVote vote expect "Should grant vote" true id res } @@ -625,20 +625,20 @@ module ServerTests = let mem = Member.create (DiscoId.Create()) let vote = - { Term = term 2 + { Term = 2 ; Candidate = mem - ; LastLogIndex = index 3 - ; LastLogTerm = term 2 + ; LastLogIndex = 3 + ; LastLogTerm = 2 } raft { - do! Raft.addMemberM mem - do! Raft.setTermM (term 2) - do! Raft.voteFor None - do! expectM "Should have currentIndex zero" (index 0) Raft.currentIndex - do! Raft.createEntryM (DataSnapshot (State.Empty)) >>= ignoreM - do! Raft.createEntryM (DataSnapshot (State.Empty)) >>= ignoreM - do! expectM "Should have currentIndex one" (index 2) Raft.currentIndex + do! addMember mem + do! setCurrentTerm 2 + do! voteFor None + do! expectM "Should have currentIndex zero" 0 RaftState.currentIndex + do! createEntry (DataSnapshot (State.Empty)) >>= ignoreM + do! createEntry (DataSnapshot (State.Empty)) >>= ignoreM + do! expectM "Should have currentIndex one" 2 RaftState.currentIndex let! (res,_) = Raft.shouldGrantVote vote expect "Should grant vote" true id res } @@ -650,19 +650,19 @@ module ServerTests = let peer = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM peer - do! Raft.setTermM (term 1) - do! Raft.voteForMyself () + do! addMember peer + do! setCurrentTerm 1 + do! voteForMyself () do! Raft.becomeLeader () - do! expectM "Should be leader" Leader Raft.getState + do! expectM "Should be leader" Leader RaftState.state let request = - { Term = term 1 + { Term = 1 ; Candidate = peer - ; LastLogIndex = index 1 - ; LastLogTerm = term 1 + ; LastLogIndex = 1 + ; LastLogTerm = 1 } let! resp = Raft.receiveVoteRequest peer.Id request - do! expectM "Should be leader" Leader Raft.getState + do! expectM "Should be leader" Leader RaftState.state } |> runWithDefaults |> noError @@ -673,16 +673,16 @@ module ServerTests = let peer = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM peer - do! Raft.setTermM (term 1) + do! addMember peer + do! setCurrentTerm 1 let request = - { Term = term 2 + { Term = 2 ; Candidate = peer - ; LastLogIndex = index 1 - ; LastLogTerm = term 1 + ; LastLogIndex = 1 + ; LastLogTerm = 1 } let! resp = Raft.receiveVoteRequest peer.Id request - expect "Should be granted" true Vote.granted resp + expect "Should be granted" true VoteResponse.granted resp } |> runWithDefaults |> noError @@ -692,19 +692,19 @@ module ServerTests = let peer = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM peer - do! Raft.setTermM (term 1) - do! Raft.setElectionTimeoutM 1000 + do! addMember peer + do! setCurrentTerm 1 + do! setElectionTimeout 1000 do! Raft.periodic 900 let request = - { Term = term 2 + { Term = 2 ; Candidate = peer - ; LastLogIndex = index 1 - ; LastLogTerm = term 1 + ; LastLogIndex = 1 + ; LastLogTerm = 1 } let! resp = Raft.receiveVoteRequest peer.Id request - expect "Vote should be granted" true Vote.granted resp - do! expectM "Timeout Elapsed should be reset" 0 Raft.timeoutElapsed + expect "Vote should be granted" true VoteResponse.granted resp + do! expectM "Timeout Elapsed should be reset" 0 RaftState.timeoutElapsed } |> runWithDefaults |> noError @@ -714,21 +714,21 @@ module ServerTests = let peer = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM peer + do! addMember peer do! Raft.becomeCandidate () - do! Raft.setTermM (term 1) - do! expectM "Should have voted for myself" true Raft.votedForMyself - do! expectM "Should have term 1" (term 1) Raft.currentTerm + do! setCurrentTerm 1 + do! expectM "Should have voted for myself" true RaftState.votedForMyself + do! expectM "Should have term 1" 1 RaftState.currentTerm let request = - { Term = term 2 + { Term = 2 ; Candidate = peer - ; LastLogIndex = index 1 - ; LastLogTerm = term 1 + ; LastLogIndex = 1 + ; LastLogTerm = 1 } let! resp = Raft.receiveVoteRequest peer.Id request - do! expectM "Should now be Follower" Follower Raft.getState - do! expectM "Should have term 2" (term 2) Raft.currentTerm - do! expectM "Should have voted for peer" peer.Id (Raft.votedFor >> Option.get) + do! expectM "Should now be Follower" Follower RaftState.state + do! expectM "Should have term 2" 2 RaftState.currentTerm + do! expectM "Should have voted for peer" peer.Id (RaftState.votedFor >> Option.get) } |> runWithDefaults |> noError @@ -739,19 +739,19 @@ module ServerTests = let other = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM peer + do! addMember peer do! Raft.becomeCandidate () - do! Raft.setTermM (term 1) - do! expectM "Should have voted for myself" true Raft.votedForMyself + do! setCurrentTerm 1 + do! expectM "Should have voted for myself" true RaftState.votedForMyself let request = - { Term = term 2 + { Term = 2 ; Candidate = other - ; LastLogIndex = index 1 - ; LastLogTerm = term 1 + ; LastLogIndex = 1 + ; LastLogTerm = 1 } let! resp = Raft.receiveVoteRequest other.Id request - do! expectM "Should have added mem" None (Raft.getMember other.Id) - expect "Should not have granted vote" false Vote.granted resp + do! expectM "Should have added mem" None (RaftState.getMember other.Id) + expect "Should not have granted vote" false VoteResponse.granted resp } |> runWithDefaults |> noError @@ -761,25 +761,25 @@ module ServerTests = let peer1 = Member.create (DiscoId.Create()) let peer2 = Member.create (DiscoId.Create()) let request = - { Term = term 1 + { Term = 1 ; Candidate = peer1 - ; LastLogIndex = index 1 - ; LastLogTerm = term 1 + ; LastLogIndex = 1 + ; LastLogTerm = 1 } raft { - do! Raft.addMembersM (Map.ofArray [| (peer1.Id, peer1); (peer2.Id, peer2) |]) - do! Raft.setTermM (term 1) - do! Raft.voteForMyself () - do! Raft.setTermM (term 1) - do! expectM "Should have voted for myself" true Raft.votedForMyself - do! expectM "Should have 3 mems" 3 Raft.numMembers + do! addMembers (Map.ofArray [| (peer1.Id, peer1); (peer2.Id, peer2) |]) + do! setCurrentTerm 1 + do! voteForMyself () + do! setCurrentTerm 1 + do! expectM "Should have voted for myself" true RaftState.votedForMyself + do! expectM "Should have 3 mems" 3 RaftState.numMembers let! raft' = get let req1 = { request with Candidate = raft'.Member } let! result = Raft.receiveVoteRequest peer2.Id req1 - expect "Should not have granted vote" false Vote.granted result + expect "Should not have granted vote" false VoteResponse.granted result } |> runWithDefaults |> noError @@ -788,9 +788,9 @@ module ServerTests = testCase "follower becomes follower is follower" <| fun _ -> raft { do! Raft.becomeLeader () - do! expectM "Should be leader now" Leader Raft.getState + do! expectM "Should be leader now" Leader RaftState.state do! Raft.becomeFollower () - do! expectM "Should be follower now" Follower Raft.getState + do! expectM "Should be follower now" Follower RaftState.state } |> runWithDefaults |> noError @@ -798,10 +798,10 @@ module ServerTests = let follower_becomes_follower_does_not_clear_voted_for = testCase "follower becomes follower does not clear voted for" <| fun _ -> raft { - do! Raft.voteForMyself () - do! expectM "Should have voted for myself" true Raft.votedForMyself + do! voteForMyself () + do! expectM "Should have voted for myself" true RaftState.votedForMyself do! Raft.becomeFollower () - do! expectM "Should have voted for myself" true Raft.votedForMyself + do! expectM "Should have voted for myself" true RaftState.votedForMyself } |> runWithDefaults |> noError @@ -810,7 +810,7 @@ module ServerTests = testCase "candidate becomes candidate is candidate" <| fun _ -> raft { do! Raft.becomeCandidate () - do! expectM "Should be Candidate" true Raft.isCandidate + do! expectM "Should be Candidate" true RaftState.isCandidate } |> runWithDefaults |> noError @@ -822,13 +822,13 @@ module ServerTests = // thereby increasing the term again). let peer = Member.create (DiscoId.Create()) raft { - do! Raft.addMemberM peer - do! Raft.setElectionTimeoutM 1000 - do! expectM "Should be at term zero" (term 0) Raft.currentTerm + do! addMember peer + do! setElectionTimeout 1000 + do! expectM "Should be at term zero" 0 RaftState.currentTerm do! Raft.becomeCandidate () - do! expectM "Should be at term one" (term 1) Raft.currentTerm + do! expectM "Should be at term one" 1 RaftState.currentTerm do! Raft.periodic 1001 - do! expectM "Should be at term two" (term 2) Raft.currentTerm + do! expectM "Should be at term two" 2 RaftState.currentTerm } |> runWithDefaults |> noError @@ -839,10 +839,10 @@ module ServerTests = let peer = Member.create (DiscoId.Create()) raft { - do! Raft.setElectionTimeoutM 1000 - do! Raft.addMemberM peer + do! setElectionTimeout 1000 + do! addMember peer do! Raft.periodic 1001 - do! expectM "Should be candidate now" Candidate Raft.getState + do! expectM "Should be candidate now" Candidate RaftState.state } |> runWithDefaults |> noError @@ -851,30 +851,30 @@ module ServerTests = let follower_dont_grant_vote_if_candidate_has_a_less_complete_log = testCase "follower dont grant vote if candidate has a less complete log" <| fun _ -> let peer = Member.create (DiscoId.Create()) - let log1 = LogEntry(DiscoId.Create(), index 0, term 1, (DataSnapshot (State.Empty)), None) - let log2 = LogEntry(DiscoId.Create(), index 0, term 2, (DataSnapshot (State.Empty)), None) + let log1 = LogEntry(DiscoId.Create(), 0, 1, (DataSnapshot (State.Empty)), None) + let log2 = LogEntry(DiscoId.Create(), 0, 2, (DataSnapshot (State.Empty)), None) raft { - do! Raft.addPeerM peer - do! Raft.setTermM (term 1) - do! Raft.appendEntryM log1 >>= ignoreM - do! Raft.appendEntryM log2 >>= ignoreM + do! addMember peer + do! setCurrentTerm 1 + do! appendEntry log1 >>= ignoreM + do! appendEntry log2 >>= ignoreM let! state = get let vote : VoteRequest = - { Term = term 1 + { Term = 1 ; Candidate = state.Member - ; LastLogIndex = index 1 - ; LastLogTerm = term 1 + ; LastLogIndex = 1 + ; LastLogTerm = 1 } let! resp = Raft.receiveVoteRequest peer.Id vote expect "Should have failed" false id resp.Granted - do! Raft.setTermM (term 2) + do! setCurrentTerm 2 - let! resp = Raft.receiveVoteRequest peer.Id { vote with Term = term 2; LastLogTerm = term 3; } - expect "Should be granted" true Vote.granted resp + let! resp = Raft.receiveVoteRequest peer.Id { vote with Term = 2; LastLogTerm = 3; } + expect "Should be granted" true VoteResponse.granted resp } |> runWithDefaults |> noError @@ -882,9 +882,9 @@ module ServerTests = let follower_becoming_candidate_increments_current_term = testCase "follower becoming candidate increments current term" <| fun _ -> raft { - do! expectM "Should have term 0" (term 0) Raft.currentTerm + do! expectM "Should have term 0" 0 RaftState.currentTerm do! Raft.becomeCandidate () - do! expectM "Should have term 1" (term 1) Raft.currentTerm + do! expectM "Should have term 1" 1 RaftState.currentTerm } |> runWithDefaults |> noError @@ -894,11 +894,11 @@ module ServerTests = raft { let peer = Member.create (DiscoId.Create()) let! raft' = get - do! Raft.addMemberM peer - do! expectM "Should have no VotedFor" None Raft.votedFor + do! addMember peer + do! expectM "Should have no VotedFor" None RaftState.votedFor do! Raft.becomeCandidate () - do! expectM "Should have voted for myself" (Some raft'.Member.Id) Raft.votedFor - do! expectM "Should have one vote for me" 1 Raft.numVotesForMe + do! expectM "Should have voted for myself" (Some raft'.Member.Id) RaftState.votedFor + do! expectM "Should have one vote for me" 1 RaftState.numVotesForMe } |> runWithDefaults |> noError @@ -906,12 +906,14 @@ module ServerTests = let follower_becoming_candidate_resets_election_timeout = testCase "follower becoming candidate resets election timeout" <| fun _ -> raft { - do! Raft.setElectionTimeoutM 1000 - do! expectM "Should have zero elapsed timout" 0 Raft.timeoutElapsed + let electionAfter = 1000 + do! setElectionTimeout electionAfter + do! expectM "Should have correct election timeout" electionAfter RaftState.electionTimeout + do! expectM "Should have zero elapsed timout" 0 RaftState.timeoutElapsed do! Raft.periodic 900 - do! expectM "Should have 900 elapsed timout" 900 Raft.timeoutElapsed + do! expectM "Should have 900 elapsed timout" 900 RaftState.timeoutElapsed do! Raft.becomeCandidate () - do! expectM "Should have timeout elapsed below 1000" true (Raft.timeoutElapsed >> ((>) 1000)) + do! expectM "Should have timeout elapsed below 1000" true (RaftState.timeoutElapsed >> ((>) 1000)) } |> runWithDefaults |> noError @@ -922,7 +924,7 @@ module ServerTests = let peer1 = Member.create (DiscoId.Create()) let peer2 = Member.create (DiscoId.Create()) - let state = Raft.create peer0 + let state = RaftState.create peer0 let lokk = new System.Object() let i = ref 0 let cbs = @@ -931,9 +933,9 @@ module ServerTests = :> IRaftCallbacks raft { - do! Raft.addMemberM peer1 - do! Raft.addMemberM peer2 - do! Raft.setTermM (term 2) + do! addMember peer1 + do! addMember peer2 + do! setCurrentTerm 2 do! Raft.becomeCandidate () expect "Should have two vote requests" 2 id !i } @@ -949,16 +951,16 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.addPeersM peers - do! expectM "Should have 5 mems" 5 Raft.numMembers + do! addMembers peers + do! expectM "Should have 5 mems" 5 RaftState.numMembers do! Raft.becomeCandidate () - let! term = Raft.currentTermM () + let! term = currentTerm () for KeyValue(id,_) in peers do do! Raft.receiveVoteResponse id { Term = term; Granted = true; Reason = None } - do! expectM "Should be leader" true Raft.isLeader + do! expectM "Should be leader" true RaftState.isLeader } |> runWithDefaults |> noError @@ -966,17 +968,17 @@ module ServerTests = let candidate_will_not_respond_to_voterequest_if_it_has_already_voted = testCase "candidate will not respond to voterequest if it has already voted" <| fun _ -> raft { - let! raft' = get + let! self = self() let peer = Member.create (DiscoId.Create()) let vote : VoteRequest = - { Term = term 0 // term must be equal or lower that raft's - Candidate = raft'.Member // term for this to work - LastLogIndex = index 0 - LastLogTerm = term 0 } - do! Raft.addPeerM peer - do! Raft.voteFor (Some raft'.Member) + { Term = 0 // term must be equal or lower that raft's + Candidate = self // term for this to work + LastLogIndex = 0 + LastLogTerm = 0 } + do! addMember peer + do! voteFor (Some self) let! resp = Raft.receiveVoteRequest peer.Id vote - expect "Should have failed" true Vote.declined resp + expect "Should have failed" true VoteResponse.declined resp } |> runWithDefaults |> noError @@ -984,9 +986,9 @@ module ServerTests = let candidate_requestvote_includes_logidx = testCase "candidate requestvote includes logidx" <| fun _ -> let self = Member.create (DiscoId.Create()) - let raft' = Raft.create self + let raft' = RaftState.create self let sender = Sender.create - let response = { Term = term 5; Granted = true; Reason = None } + let response = { Term = 5; Granted = true; Reason = None } let cbs = { Callbacks.Create (ref (DataSnapshot (State.Empty))) with SendRequestVote = senderRequestVote sender (Some response) } @@ -1002,14 +1004,14 @@ module ServerTests = |> Map.ofArray let log = - LogEntry(DiscoId.Create(),index 0, term 3, DataSnapshot (State.Empty), - Some <| LogEntry(DiscoId.Create(),index 0, term 1, DataSnapshot (State.Empty), - Some <| LogEntry(DiscoId.Create(),index 0, term 1, DataSnapshot (State.Empty), None))) + LogEntry(DiscoId.Create(),0, 3, DataSnapshot (State.Empty), + Some <| LogEntry(DiscoId.Create(),0, 1, DataSnapshot (State.Empty), + Some <| LogEntry(DiscoId.Create(),0, 1, DataSnapshot (State.Empty), None))) - do! Raft.addPeersM peers - do! Raft.setStateM Candidate - do! Raft.setTermM (term 5) - do! Raft.appendEntryM log >>= ignoreM + do! addMembers peers + do! setState Candidate + do! setCurrentTerm 5 + do! appendEntry log >>= ignoreM let! request = Raft.sendVoteRequest peer1 @@ -1017,10 +1019,10 @@ module ServerTests = let vote = List.head (!sender.Outbox) |> getVote - expect "should have last log index be 3" (index 3) Vote.lastLogIndex vote - expect "should have last term be 5" (term 5) Vote.term vote - expect "should have last log term be 3" (term 3) Vote.lastLogTerm vote - expect "should have candidate id be me" self Vote.candidate vote + expect "should have last log index be 3" 3 VoteRequest.lastLogIndex vote + expect "should have last term be 5" 5 VoteRequest.term vote + expect "should have last log term be 3" 3 VoteRequest.lastLogTerm vote + expect "should have candidate id be me" (Member.id self) (VoteRequest.candidate >> Member.id) vote } |> runWithRaft raft' cbs |> noError @@ -1029,18 +1031,18 @@ module ServerTests = testCase "candidate recv requestvote response becomes follower if current term is less than term" <| fun _ -> raft { let peer = Member.create (DiscoId.Create()) - let response = { Term = term 2 ; Granted = false; Reason = None } - do! Raft.addPeerM peer - do! Raft.setTermM (term 1) - do! Raft.setStateM Candidate - do! Raft.voteFor None - do! expectM "Should not be follower" false Raft.isFollower - do! expectM "Should not *have* a leader" None Raft.currentLeader - do! expectM "Should have term 1" (term 1) Raft.currentTerm + let response = { Term = 2; Granted = false; Reason = None } + do! addMember peer + do! setCurrentTerm 1 + do! setState Candidate + do! voteFor None + do! expectM "Should not be follower" false RaftState.isFollower + do! expectM "Should not *have* a leader" None RaftState.currentLeader + do! expectM "Should have term 1" 1 RaftState.currentTerm do! Raft.receiveVoteResponse peer.Id response - do! expectM "Should be Follower" Follower Raft.getState - do! expectM "Should have term 2" (term 2) Raft.currentTerm - do! expectM "Should have voted for nobody" None Raft.votedFor + do! expectM "Should be Follower" Follower RaftState.state + do! expectM "Should have term 2" 2 RaftState.currentTerm + do! expectM "Should have voted for nobody" None RaftState.votedFor } |> runWithDefaults |> noError @@ -1050,25 +1052,25 @@ module ServerTests = testCase "candidate recv appendentries frm leader results in follower" <| fun _ -> let peer = Member.create (DiscoId.Create()) let ae : AppendEntries = - { Term = term 1 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 0 - ; LeaderCommit = index 0 + { Term = 1 + ; PrevLogIdx = 0 + ; PrevLogTerm = 0 + ; LeaderCommit = 0 ; Entries = None } raft { - do! Raft.addPeerM peer - do! Raft.setStateM Candidate - do! Raft.voteFor None - do! expectM "Should not be follower" false Raft.isFollower - do! expectM "Should have no leader" None Raft.currentLeader - do! expectM "Should have term 0" (term 0) Raft.currentTerm + do! addMember peer + do! setState Candidate + do! voteFor None + do! expectM "Should not be follower" false RaftState.isFollower + do! expectM "Should have no leader" None RaftState.currentLeader + do! expectM "Should have term 0" 0 RaftState.currentTerm let! resp = Raft.receiveAppendEntries (Some peer.Id) ae - do! expectM "Should be follower" Follower Raft.getState - do! expectM "Should have peer as leader" (Some peer.Id) Raft.currentLeader - do! expectM "Should have term 1" (term 1) Raft.currentTerm - do! expectM "Should have voted for noone" None Raft.votedFor + do! expectM "Should be follower" Follower RaftState.state + do! expectM "Should have peer as leader" (Some peer.Id) RaftState.currentLeader + do! expectM "Should have term 1" 1 RaftState.currentTerm + do! expectM "Should have voted for noone" None RaftState.votedFor } |> runWithDefaults |> noError @@ -1077,20 +1079,20 @@ module ServerTests = testCase "candidate recv appendentries from same term results in step down" <| fun _ -> let peer = Member.create (DiscoId.Create()) let ae : AppendEntries = - { Term = term 2 - ; PrevLogIdx = index 1 - ; PrevLogTerm = term 1 - ; LeaderCommit = index 0 + { Term = 2 + ; PrevLogIdx = 1 + ; PrevLogTerm = 1 + ; LeaderCommit = 0 ; Entries = None } raft { - do! Raft.addPeerM peer - do! Raft.setTermM (term 2) - do! Raft.setStateM Candidate - do! expectM "Should not be follower" false Raft.isFollower + do! addMember peer + do! setCurrentTerm 2 + do! setState Candidate + do! expectM "Should not be follower" false RaftState.isFollower let! resp = Raft.receiveAppendEntries (Some peer.Id) ae - do! expectM "Should not be candidate anymore" false Raft.isCandidate + do! expectM "Should not be candidate anymore" false RaftState.isCandidate } |> runWithDefaults |> noError @@ -1099,7 +1101,7 @@ module ServerTests = testCase "leader becomes leader is leader" <| fun _ -> raft { do! Raft.becomeLeader () - do! expectM "Should be leader" Leader Raft.getState + do! expectM "Should be leader" Leader RaftState.state } |> runWithDefaults |> noError @@ -1108,10 +1110,10 @@ module ServerTests = testCase "leader becomes leader does not clear voted for" <| fun _ -> raft { let! raft' = get - do! Raft.voteForMyself () - do! expectM "Should have voted for myself" (Some raft'.Member.Id) Raft.votedFor + do! voteForMyself () + do! expectM "Should have voted for myself" (Some raft'.Member.Id) RaftState.votedFor do! Raft.becomeLeader () - do! expectM "Should still have votedFor" (Some raft'.Member.Id) Raft.votedFor + do! expectM "Should still have votedFor" (Some raft'.Member.Id) RaftState.votedFor } |> runWithDefaults |> noError @@ -1122,12 +1124,12 @@ module ServerTests = let peer2 = Member.create (DiscoId.Create()) raft { - do! Raft.addPeerM peer1 - do! Raft.addPeerM peer2 - do! Raft.setStateM Candidate + do! addMember peer1 + do! addMember peer2 + do! setState Candidate do! Raft.becomeLeader () let! raft' = get - let cidx = Raft.currentIndex raft' + index 1 + let cidx = RaftState.currentIndex raft' + 1 for peer in raft'.Peers do if peer.Value.Id <> raft'.Member.Id then @@ -1151,9 +1153,9 @@ module ServerTests = :> IRaftCallbacks raft { - do! Raft.addPeerM peer1 - do! Raft.addPeerM peer2 - do! Raft.setStateM Candidate + do! addMember peer1 + do! addMember peer2 + do! setState Candidate do! Raft.becomeLeader () expect "Should have two messages" 2 id !count } @@ -1163,16 +1165,16 @@ module ServerTests = let leader_responds_to_entry_msg_when_entry_is_committed = testCase "leader responds to entry msg when entry is committed" <| fun _ -> let peer = Member.create (DiscoId.Create()) - let log = LogEntry(DiscoId.Create(),index 0,term 0,DataSnapshot (State.Empty),None) + let log = LogEntry(DiscoId.Create(),0,0,DataSnapshot (State.Empty),None) raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader - do! expectM "Should have log count 0" 0 Raft.numLogs + do! addMember peer + do! setState Leader + do! expectM "Should have log count 0" 0 RaftState.numLogs let! resp = Raft.receiveEntry log - do! expectM "Should have log count 1" 1 Raft.numLogs + do! expectM "Should have log count 1" 1 RaftState.numLogs do! Raft.applyEntries () - let response = { Term = term 0; Success = true; CurrentIndex = index 1; FirstIndex = index 1 } + let response = { Term = 0; Success = true; CurrentIndex = 1; FirstIndex = 1 } do! Raft.receiveAppendEntriesResponse peer.Id response let! committed = Raft.responseCommitted resp expect "Should be committed" true id committed @@ -1184,15 +1186,15 @@ module ServerTests = let non_leader_recv_entry_msg_fails = testCase "non leader recv entry msg fails" <| fun _ -> let peer = Member.create (DiscoId.Create()) - let log = LogEntry(DiscoId.Create(),index 0,term 0,DataSnapshot (State.Empty),None) + let log = LogEntry(DiscoId.Create(),0,0,DataSnapshot (State.Empty),None) let err = "Not Leader" |> Error.asRaftError "Raft.receiveEntry" raft { - do! Raft.addMemberM peer - do! Raft.setStateM Follower + do! addMember peer + do! setState Follower let! resp = Raft.receiveEntry log return "never reached" } @@ -1201,19 +1203,19 @@ module ServerTests = let leader_sends_appendentries_with_NextIdx_when_PrevIdx_gt_NextIdx = testCase "leader sends appendentries with NextIdx when PrevIdx gt NextIdx" <| fun _ -> - let peer = { Member.create (DiscoId.Create()) with NextIndex = index 4 } + let peer = { Member.create (DiscoId.Create()) with NextIndex = 4 } let raft' : RaftState = defaultServer () let sender = Sender.create - let log = LogEntry(DiscoId.Create(),index 0, term 1, DataSnapshot (State.Empty), None) + let log = LogEntry(DiscoId.Create(),0, 1, DataSnapshot (State.Empty), None) let cbs = { Callbacks.Create (ref (DataSnapshot (State.Empty))) with SendAppendEntries = senderAppendEntries sender None } :> IRaftCallbacks raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader - do! Raft.sendAllAppendEntriesM () + do! addMember peer + do! setState Leader + do! Raft.sendAllAppendEntries () expect "Should have one message in cue" 1 List.length (!sender.Outbox) } |> runWithRaft raft' cbs @@ -1221,7 +1223,7 @@ module ServerTests = let leader_sends_appendentries_with_leader_commit = testCase "leader sends appendentries with leader commit" <| fun _ -> - let peer = { Member.create (DiscoId.Create()) with NextIndex = index 4 } + let peer = { Member.create (DiscoId.Create()) with NextIndex = 4 } let raft' = defaultServer () let sender = Sender.create let cbs = @@ -1230,20 +1232,20 @@ module ServerTests = :> IRaftCallbacks raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader + do! addMember peer + do! setState Leader for n in 0 .. 9 do - let l = LogEntry(DiscoId.Create(), index 0, term 1, DataSnapshot (State.Empty), None) - do! Raft.appendEntryM l >>= ignoreM + let l = LogEntry(DiscoId.Create(), 0, 1, DataSnapshot (State.Empty), None) + do! appendEntry l >>= ignoreM - do! Raft.setCommitIndexM (index 10) - do! Raft.sendAllAppendEntriesM () + do! setCommitIndex 10 + do! Raft.sendAllAppendEntries () (!sender.Outbox) |> List.head |> getAppendEntries - |> expect "Should have leader commit 10" (index 10) (fun ae -> ae.LeaderCommit) + |> expect "Should have leader commit 10" 10 (fun ae -> ae.LeaderCommit) } |> runWithRaft raft' cbs |> noError @@ -1259,43 +1261,43 @@ module ServerTests = :> IRaftCallbacks raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader + do! addMember peer + do! setState Leader let! request = Raft.sendAppendEntry peer (!sender.Outbox) |> List.head |> getAppendEntries - |> expect "Should have PrevLogIndex 0" (index 0) (fun ae -> ae.PrevLogIdx) + |> expect "Should have PrevLogIndex 0" 0 (fun ae -> ae.PrevLogIdx) - let log = LogEntry(DiscoId.Create(),index 0,term 2,DataSnapshot (State.Empty),None) + let log = LogEntry(DiscoId.Create(),0,2,DataSnapshot (State.Empty),None) - do! Raft.appendEntryM log >>= ignoreM - do! Raft.setNextIndexM peer.Id (index 1) + do! appendEntry log >>= ignoreM + do! setNextIndex peer.Id 1 - let! peer = Raft.getMemberM peer.Id >>= (Option.get >> returnM) + let! peer = getMember peer.Id >>= (Option.get >> returnM) let! request = Raft.sendAppendEntry peer (!sender.Outbox) |> List.head |> getAppendEntries - |> assume "Should have PrevLogIdx 0" (index 0) (fun ae -> ae.PrevLogIdx) + |> assume "Should have PrevLogIdx 0" 0 (fun ae -> ae.PrevLogIdx) |> assume "Should have one entry" 1 (fun ae -> ae.Entries |> Option.get |> LogEntry.depth) - |> assume "Should have entry with correct id" (LogEntry.getId log) (fun ae -> ae.Entries |> Option.get |> LogEntry.getId) - |> expect "Should have entry with term" (term 2) (fun ae -> ae.Entries |> Option.get |> LogEntry.getTerm) + |> assume "Should have entry with correct id" (LogEntry.id log) (fun ae -> ae.Entries |> Option.get |> LogEntry.id) + |> expect "Should have entry with term" 2 (fun ae -> ae.Entries |> Option.get |> LogEntry.term) sender.Outbox := List.empty // reset outbox - do! Raft.setNextIndexM peer.Id (index 2) - let! peer = Raft.getMemberM peer.Id >>= (Option.get >> returnM) + do! setNextIndex peer.Id 2 + let! peer = getMember peer.Id >>= (Option.get >> returnM) let! request = Raft.sendAppendEntry peer (!sender.Outbox) |> List.head |> getAppendEntries - |> expect "Should have PrevLogIdx 1" (index 1) (fun ae -> ae.PrevLogIdx) + |> expect "Should have PrevLogIdx 1" 1 (fun ae -> ae.PrevLogIdx) } |> runWithRaft raft' cbs |> noError @@ -1311,27 +1313,27 @@ module ServerTests = :> IRaftCallbacks raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader + do! addMember peer + do! setState Leader let! request = Raft.sendAppendEntry peer (!sender.Outbox) |> List.head |> getAppendEntries - |> expect "Should have PrevLogIdx 0" (index 0) (fun ae -> ae.PrevLogIdx) + |> expect "Should have PrevLogIdx 0" 0 (fun ae -> ae.PrevLogIdx) sender.Outbox := List.empty // reset outbox - let log = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty), None) + let log = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty), None) - do! Raft.setNextIndexM peer.Id (index 1) - do! Raft.appendEntryM log >>= ignoreM + do! setNextIndex peer.Id 1 + do! appendEntry log >>= ignoreM let! request = Raft.sendAppendEntry peer (!sender.Outbox) |> List.head |> getAppendEntries - |> expect "Should have PrevLogIdx 0" (index 0) (fun ae -> ae.PrevLogIdx) + |> expect "Should have PrevLogIdx 0" 0 (fun ae -> ae.PrevLogIdx) } |> runWithRaft raft' cbs |> noError @@ -1347,8 +1349,8 @@ module ServerTests = :> IRaftCallbacks raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader + do! addMember peer + do! setState Leader let! request = Raft.sendAppendEntry peer (!sender.Outbox) |> expect "Should have a message" 1 List.length @@ -1360,17 +1362,17 @@ module ServerTests = let leader_append_entry_to_log_increases_idxno = testCase "leader append entry to log increases idxno" <| fun _ -> let peer = Member.create (DiscoId.Create()) - let log = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) + let log = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) let raft' = defaultServer () let sender = Sender.create let cbs = Callbacks.Create (ref (DataSnapshot (State.Empty))) :> IRaftCallbacks raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader - do! expectM "Should have zero logs" 0 Raft.numLogs + do! addMember peer + do! setState Leader + do! expectM "Should have zero logs" 0 RaftState.numLogs let! resp = Raft.receiveEntry log - do! expectM "Should have on log" 1 Raft.numLogs + do! expectM "Should have on log" 1 RaftState.numLogs } |> runWithRaft raft' cbs |> noError @@ -1389,15 +1391,15 @@ module ServerTests = with SendAppendEntries = senderAppendEntries sender None } :> IRaftCallbacks - let log1 = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) - let log2 = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) - let log3 = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) + let log1 = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) + let log2 = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) + let log3 = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) let response = - { Term = term 1 + { Term = 1 ; Success = true - ; CurrentIndex = index 3 - ; FirstIndex = index 1 + ; CurrentIndex = 3 + ; FirstIndex = 1 } let peers = @@ -1406,14 +1408,14 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.addMembersM peers - do! Raft.setStateM Leader - do! Raft.setTermM (term 1) - do! Raft.setCommitIndexM (index 0) - do! Raft.setLastAppliedIdxM (index 0) - do! Raft.appendEntryM log1 >>= ignoreM - do! Raft.appendEntryM log2 >>= ignoreM - do! Raft.appendEntryM log3 >>= ignoreM + do! addMembers peers + do! setState Leader + do! setCurrentTerm 1 + do! setCommitIndex 0 + do! setLastAppliedIndex 0 + do! appendEntry log1 >>= ignoreM + do! appendEntry log2 >>= ignoreM + do! appendEntry log3 >>= ignoreM // peer 1 let! request = Raft.sendAppendEntry peer1 @@ -1423,18 +1425,18 @@ module ServerTests = do! Raft.receiveAppendEntriesResponse peer1.Id response // first response, no majority yet, will not set commit idx - do! expectM "Should have commit index 0" (index 0) Raft.commitIndex + do! expectM "Should have commit index 0" 0 RaftState.commitIndex do! Raft.receiveAppendEntriesResponse peer2.Id response // leader will now have majority followers who have appended this log - do! expectM "Should have commit index 3" (index 3) Raft.commitIndex + do! expectM "Should have commit index 3" 3 RaftState.commitIndex - let! lidx = Raft.lastAppliedIdx() + let! lidx = lastAppliedIndex() expect "Should have last applied index 0" 0 id lidx do! Raft.periodic 1 - let! lidx = Raft.lastAppliedIdx() + let! lidx = lastAppliedIndex() expect "Should have last applied index 3" 3 id lidx } |> runWithRaft raft' cbs @@ -1447,19 +1449,19 @@ module ServerTests = let peer2 = Member.create (DiscoId.Create()) let response = - { Term = term 1 + { Term = 1 ; Success = true - ; CurrentIndex = index 1 - ; FirstIndex = index 1 + ; CurrentIndex = 1 + ; FirstIndex = 1 } let raft' = defaultServer () let sender = Sender.create let cbs = Callbacks.Create (ref (DataSnapshot (State.Empty))) :> IRaftCallbacks - let log1 = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) - let log2 = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) - let log3 = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) + let log1 = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) + let log2 = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) + let log3 = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) let peers = [| peer1; peer2; |] @@ -1467,20 +1469,20 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.addMembersM peers - do! Raft.setStateM Leader - do! Raft.setTermM (term 1) - do! Raft.setCommitIndexM (index 0) - do! Raft.setLastAppliedIdxM (index 0) - do! Raft.appendEntryM log1 >>= ignoreM - do! Raft.appendEntryM log2 >>= ignoreM - do! Raft.appendEntryM log3 >>= ignoreM - do! Raft.sendAllAppendEntriesM () + do! addMembers peers + do! setState Leader + do! setCurrentTerm 1 + do! setCommitIndex 0 + do! setLastAppliedIndex 0 + do! appendEntry log1 >>= ignoreM + do! appendEntry log2 >>= ignoreM + do! appendEntry log3 >>= ignoreM + do! Raft.sendAllAppendEntries () do! Raft.receiveAppendEntriesResponse peer1.Id response do! Raft.receiveAppendEntriesResponse peer2.Id response - do! expectM "Should have matchIdx 1" (index 1) (Raft.getMember peer1.Id >> Option.get >> Member.matchIndex) + do! expectM "Should have matchIdx 1" 1 (RaftState.getMember peer1.Id >> Option.get >> Member.matchIndex) do! Raft.receiveAppendEntriesResponse peer1.Id response - do! expectM "Should still have matchIdx 1" (index 1) (Raft.getMember peer1.Id >> Option.get >> Member.matchIndex) + do! expectM "Should still have matchIdx 1" 1 (RaftState.getMember peer1.Id >> Option.get >> Member.matchIndex) } |> runWithRaft raft' cbs |> noError @@ -1493,16 +1495,16 @@ module ServerTests = let peer4 = Member.create (DiscoId.Create()) let response = - { Term = term 1 + { Term = 1 ; Success = true - ; CurrentIndex = index 1 - ; FirstIndex = index 1 } + ; CurrentIndex = 1 + ; FirstIndex = 1 } let cbs = Callbacks.Create (ref (DataSnapshot (State.Empty))) :> IRaftCallbacks - let log1 = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) - let log2 = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) - let log3 = LogEntry(DiscoId.Create(),index 0,term 2,DataSnapshot (State.Empty),None) + let log1 = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) + let log2 = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) + let log3 = LogEntry(DiscoId.Create(),0,2,DataSnapshot (State.Empty),None) let peers = [| peer1; peer2; peer3; peer4 |] @@ -1510,58 +1512,58 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.addMembersM peers - do! Raft.setStateM Leader - do! Raft.setTermM (term 2) - do! Raft.setCommitIndexM (index 0) - do! Raft.setLastAppliedIdxM (index 0) - do! Raft.appendEntryM log1 >>= ignoreM - do! Raft.appendEntryM log2 >>= ignoreM - do! Raft.appendEntryM log3 >>= ignoreM + do! addMembers peers + do! setState Leader + do! setCurrentTerm 2 + do! setCommitIndex 0 + do! setLastAppliedIndex 0 + do! appendEntry log1 >>= ignoreM + do! appendEntry log2 >>= ignoreM + do! appendEntry log3 >>= ignoreM let! request = Raft.sendAppendEntry peer1 let! request = Raft.sendAppendEntry peer2 do! Raft.receiveAppendEntriesResponse peer1.Id response - do! expectM "Should have commit index 0" (index 0) Raft.commitIndex + do! expectM "Should have commit index 0" 0 RaftState.commitIndex do! Raft.receiveAppendEntriesResponse peer2.Id response - do! expectM "Should have commit index 0" (index 0) Raft.commitIndex + do! expectM "Should have commit index 0" 0 RaftState.commitIndex do! Raft.periodic 1 - let! lidx = Raft.lastAppliedIdx() + let! lidx = lastAppliedIndex() expect "Should have last applied index 0" 0 id lidx let! request = Raft.sendAppendEntry peer1 let! request = Raft.sendAppendEntry peer2 - do! Raft.receiveAppendEntriesResponse peer1.Id { response with CurrentIndex = index 2; FirstIndex = index 2 } - do! expectM "Should have commit index 0" (index 0) Raft.commitIndex + do! Raft.receiveAppendEntriesResponse peer1.Id { response with CurrentIndex = 2; FirstIndex = 2 } + do! expectM "Should have commit index 0" 0 RaftState.commitIndex - do! Raft.receiveAppendEntriesResponse peer2.Id { response with CurrentIndex = index 2; FirstIndex = index 2 } - do! expectM "Should have commit index 0" (index 0) Raft.commitIndex + do! Raft.receiveAppendEntriesResponse peer2.Id { response with CurrentIndex = 2; FirstIndex = 2 } + do! expectM "Should have commit index 0" 0 RaftState.commitIndex do! Raft.periodic 1 - let! lidx = Raft.lastAppliedIdx() + let! lidx = lastAppliedIndex() expect "Should have last applied index 0" 0 id lidx let! request = Raft.sendAppendEntry peer1 let! request = Raft.sendAppendEntry peer2 - do! Raft.receiveAppendEntriesResponse peer1.Id { response with Term = term 2; CurrentIndex = index 3; FirstIndex = index 3 } - do! expectM "Should have commit index 0" (index 0) Raft.commitIndex + do! Raft.receiveAppendEntriesResponse peer1.Id { response with Term = 2; CurrentIndex = 3; FirstIndex = 3 } + do! expectM "Should have commit index 0" 0 RaftState.commitIndex - do! Raft.receiveAppendEntriesResponse peer2.Id { response with Term = term 2; CurrentIndex = index 3; FirstIndex = index 3 } - do! expectM "Should have commit index 3" (index 3) Raft.commitIndex + do! Raft.receiveAppendEntriesResponse peer2.Id { response with Term = 2; CurrentIndex = 3; FirstIndex = 3 } + do! expectM "Should have commit index 3" 3 RaftState.commitIndex do! Raft.periodic 1 - let! lidx = Raft.lastAppliedIdx() + let! lidx = lastAppliedIndex() expect "Should have last applied index 3" 3 id lidx } |> runWithCBS cbs @@ -1582,52 +1584,52 @@ module ServerTests = appendReq := Some ae } :> IRaftCallbacks - let log1 = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) - let log2 = LogEntry(DiscoId.Create(),index 0,term 2,DataSnapshot (State.Empty),None) - let log3 = LogEntry(DiscoId.Create(),index 0,term 3,DataSnapshot (State.Empty),None) - let log4 = LogEntry(DiscoId.Create(),index 0,term 4,DataSnapshot (State.Empty),None) + let log1 = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) + let log2 = LogEntry(DiscoId.Create(),0,2,DataSnapshot (State.Empty),None) + let log3 = LogEntry(DiscoId.Create(),0,3,DataSnapshot (State.Empty),None) + let log4 = LogEntry(DiscoId.Create(),0,4,DataSnapshot (State.Empty),None) let response = - { Term = term 1 + { Term = 1 ; Success = true - ; CurrentIndex = index 1 - ; FirstIndex = index 1 } - - raft { - do! Raft.addMemberM peer - do! Raft.setStateM Leader - do! Raft.setTermM (term 2) - do! Raft.setCommitIndexM (index 0) - do! Raft.setLastAppliedIdxM (index 0) - do! Raft.appendEntryM log1 >>= ignoreM - do! Raft.appendEntryM log2 >>= ignoreM - do! Raft.appendEntryM log3 >>= ignoreM - do! Raft.appendEntryM log4 >>= ignoreM + ; CurrentIndex = 1 + ; FirstIndex = 1 } + + raft { + do! addMember peer + do! setState Leader + do! setCurrentTerm 2 + do! setCommitIndex 0 + do! setLastAppliedIndex 0 + do! appendEntry log1 >>= ignoreM + do! appendEntry log2 >>= ignoreM + do! appendEntry log3 >>= ignoreM + do! appendEntry log4 >>= ignoreM do! Raft.becomeLeader () - do! expectM "Should have nextIdx 5" (index 5) (Raft.getMember peer.Id >> Option.get >> Member.nextIndex) + do! expectM "Should have nextIdx 5" 5 (RaftState.getMember peer.Id >> Option.get >> Member.nextIndex) do! expectM "Should have a msg 1" 1 (konst !count) // need to get an up-to-date version of the peer, because its nextIdx // will have been bumped when becoming leader! - let! peer = Raft.getMemberM peer.Id >>= (Option.get >> returnM) + let! peer = getMember peer.Id >>= (Option.get >> returnM) - do! Raft.sendAllAppendEntriesM () + do! Raft.sendAllAppendEntries () - expect "Should have prevLogIdx 4" (index 4) AppendRequest.prevLogIdx (!appendReq |> Option.get) - expect "Should have prevLogTerm 4" (term 4) AppendRequest.prevLogTerm (!appendReq |> Option.get) + expect "Should have prevLogIdx 4" 4 AppendEntries.prevLogIdx (!appendReq |> Option.get) + expect "Should have prevLogTerm 4" 4 AppendEntries.prevLogTerm (!appendReq |> Option.get) - let! trm = Raft.currentTermM () - do! Raft.receiveAppendEntriesResponse peer.Id { response with Term = trm; Success = false; CurrentIndex = index 1 } + let! trm = currentTerm () + do! Raft.receiveAppendEntriesResponse peer.Id { response with Term = trm; Success = false; CurrentIndex = 1 } - do! expectM "Should have NextIdx 2" (index 2) (Raft.getMember peer.Id >> Option.get >> Member.nextIndex) - do! expectM "Should have MatchIdx 2" (index 1) (Raft.getMember peer.Id >> Option.get >> Member.matchIndex) + do! expectM "Should have NextIdx 2" 2 (RaftState.getMember peer.Id >> Option.get >> Member.nextIndex) + do! expectM "Should have MatchIdx 2" 1 (RaftState.getMember peer.Id >> Option.get >> Member.matchIndex) do! expectM "Should have 2 msgs" 2 (konst !count) - do! Raft.sendAllAppendEntriesM () + do! Raft.sendAllAppendEntries () - expect "Should have prevLogIdx 1" (index 1) AppendRequest.prevLogIdx (!appendReq |> Option.get) - expect "Should have prevLogTerm 1" (term 1) AppendRequest.prevLogTerm (!appendReq |> Option.get) + expect "Should have prevLogIdx 1" 1 AppendEntries.prevLogIdx (!appendReq |> Option.get) + expect "Should have prevLogTerm 1" 1 AppendEntries.prevLogTerm (!appendReq |> Option.get) } |> runWithCBS cbs |> noError @@ -1638,8 +1640,8 @@ module ServerTests = let peer = Member.create (DiscoId.Create()) let lokk = new System.Object() - let ci = ref (index 0) - let trm = ref (term 2) + let ci = ref 0 + let trm = ref 2 let result = ref false let count = ref 0 @@ -1652,16 +1654,16 @@ module ServerTests = { Term = !trm Success = !result CurrentIndex = !ci - FirstIndex = index 0 } + FirstIndex = 0 } raft { - do! Raft.addMemberM peer - do! Raft.setTermM !trm - do! Raft.setCommitIndexM (index 0) + do! addMember peer + do! setCurrentTerm !trm + do! setCommitIndex 0 for n in 1 .. 4 do - do! LogEntry(DiscoId.Create(),0,term n,DataSnapshot(State.Empty),None) - |> Raft.appendEntryM + do! LogEntry(DiscoId.Create(),0,1 * n,DataSnapshot(State.Empty),None) + |> appendEntry >>= ignoreM ci := 0 @@ -1670,26 +1672,26 @@ module ServerTests = do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "Should have correct NextIndex" (index 1) (Raft.getMember peer.Id >> Option.get >> Member.nextIndex) - do! expectM "Should have correct MatchIndex" (index 0) (Raft.getMember peer.Id >> Option.get >> Member.matchIndex) + do! expectM "Should have correct NextIndex" 1 (RaftState.getMember peer.Id >> Option.get >> Member.nextIndex) + do! expectM "Should have correct MatchIndex" 0 (RaftState.getMember peer.Id >> Option.get >> Member.matchIndex) do! expectM "Should have been called once" 1 (konst !count) // need to get updated peer, because nextIdx will be bumped when // becoming leader! - let! peer = Raft.getMemberM peer.Id >>= (Option.get >> returnM) + let! peer = getMember peer.Id >>= (Option.get >> returnM) // we pretend that the follower `peer` has now successfully appended those logs - let! t = Raft.currentTermM () + let! t = currentTerm () trm := t - ci := (index 4) + ci := 4 result := true // send again and process responses - do! Raft.sendAllAppendEntriesM () + do! Raft.sendAllAppendEntries () do! makeResponse() |> Raft.receiveAppendEntriesResponse peer.Id - do! expectM "Should finally have NextIndex 5" (index 5) (Raft.getMember peer.Id >> Option.get >> Member.nextIndex) - do! expectM "Should finally have MatchIndex 4" (index 4) (Raft.getMember peer.Id >> Option.get >> Member.matchIndex) + do! expectM "Should finally have NextIndex 5" 5 (RaftState.getMember peer.Id >> Option.get >> Member.nextIndex) + do! expectM "Should finally have MatchIndex 4" 4 (RaftState.getMember peer.Id >> Option.get >> Member.matchIndex) do! expectM "Should have been called twice" 2 (konst !count) } |> runWithCBS cbs @@ -1707,13 +1709,13 @@ module ServerTests = with SendAppendEntries = senderAppendEntries sender None } :> IRaftCallbacks - let log = LogEntry(DiscoId.Create(),index 0,term 1,DataSnapshot (State.Empty),None) + let log = LogEntry(DiscoId.Create(),0,1,DataSnapshot (State.Empty),None) let response = - { Term = term 1 + { Term = 1 ; Success = true - ; CurrentIndex = index 1 - ; FirstIndex = index 1 + ; CurrentIndex = 1 + ; FirstIndex = 1 } let err = @@ -1726,13 +1728,13 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.addMembersM peers - do! Raft.setTermM (term 1) - do! Raft.setCommitIndexM (index 0) - do! Raft.setStateM Leader - do! Raft.setLastAppliedIdxM (index 0) + do! addMembers peers + do! setCurrentTerm 1 + do! setCommitIndex 0 + do! setState Leader + do! setLastAppliedIndex 0 - do! Raft.appendEntryM log >>= ignoreM + do! appendEntry log >>= ignoreM let! request = Raft.sendAppendEntry peer1 @@ -1747,13 +1749,13 @@ module ServerTests = let leader_recv_entry_resets_election_timeout = testCase "leader recv entry resets election timeout" <| fun _ -> - let log = LogEntry(DiscoId.Create(), index 0, term 1, DataSnapshot (State.Empty), None) + let log = LogEntry(DiscoId.Create(), 0, 1, DataSnapshot (State.Empty), None) raft { - do! Raft.setElectionTimeoutM 1000 - do! Raft.setStateM Leader + do! setElectionTimeout 1000 + do! setState Leader do! Raft.periodic 1000 let! response = Raft.receiveEntry log - do! expectM "Should have reset timeout elapsed" 0 Raft.timeoutElapsed + do! expectM "Should have reset timeout elapsed" 0 RaftState.timeoutElapsed } |> runWithDefaults |> noError @@ -1761,18 +1763,18 @@ module ServerTests = let leader_recv_entry_is_committed_returns_0_if_not_committed = testCase "leader recv entry is committed returns 0 if not committed" <| fun _ -> let peer = Member.create (DiscoId.Create()) - let log = LogEntry(DiscoId.Create(), index 0, term 1, DataSnapshot (State.Empty), None) + let log = LogEntry(DiscoId.Create(), 0, 1, DataSnapshot (State.Empty), None) raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader + do! addMember peer + do! setState Leader - do! Raft.setCommitIndexM (index 0) + do! setCommitIndex 0 let! response = Raft.receiveEntry log let! committed = Raft.responseCommitted response expect "Should not have committed" false id committed - do! Raft.setCommitIndexM (index 1) + do! setCommitIndex 1 let! response = Raft.receiveEntry log let! committed = Raft.responseCommitted response expect "Should have committed" true id committed @@ -1783,14 +1785,14 @@ module ServerTests = let leader_recv_entry_is_committed_returns_neg_1_if_invalidated = testCase "leader recv entry is committed returns neg 1 if invalidated" <| fun _ -> let peer = Member.create (DiscoId.Create()) - let log = Log.make (term 1) (DataSnapshot (State.Empty)) + let log = Log.make 1 (DataSnapshot (State.Empty)) let ae = - { LeaderCommit = index 1 - ; Term = term 2 - ; PrevLogIdx = index 0 - ; PrevLogTerm = term 0 - ; Entries = Log.make (term 2) defSM |> Some + { LeaderCommit = 1 + ; Term = 2 + ; PrevLogIdx = 0 + ; PrevLogTerm = 0 + ; Entries = Log.make 2 defSM |> Some } let err = @@ -1798,29 +1800,29 @@ module ServerTests = |> Error.asRaftError "Raft.responseCommitted" raft { - do! Raft.addMemberM peer - do! Raft.setStateM Leader - do! Raft.setCommitIndexM (index 0) - do! Raft.setTermM (term 1) + do! addMember peer + do! setState Leader + do! setCommitIndex 0 + do! setCurrentTerm 1 - do! expectM "Should have current idx 0" (index 0) Raft.currentIndex + do! expectM "Should have current idx 0" 0 RaftState.currentIndex let! response = Raft.receiveEntry log let! committed = Raft.responseCommitted response expect "Should not have committed entry" false id committed - expect "Should have term 1" (term 1) Entry.term response - expect "Should have index 1" (index 1) Entry.index response + expect "Should have term 1" 1 EntryResponse.term response + expect "Should have index 1" 1 EntryResponse.index response - do! expectM "(1) Should have current idx 1" (index 1) Raft.currentIndex - do! expectM "Should have commit idx 0" (index 0) Raft.commitIndex + do! expectM "(1) Should have current idx 1" 1 RaftState.currentIndex + do! expectM "Should have commit idx 0" 0 RaftState.commitIndex let! resp = Raft.receiveAppendEntries (Some peer.Id) ae expect "Should have succeeded" true AppendResponse.succeeded resp - do! expectM "(2) Should have current idx 1" (index 1) Raft.currentIndex - do! expectM "Should have commit idx 1" (index 1) Raft.commitIndex + do! expectM "(2) Should have current idx 1" 1 RaftState.currentIndex + do! expectM "Should have commit idx 1" 1 RaftState.commitIndex return! Raft.responseCommitted response } @@ -1840,15 +1842,15 @@ module ServerTests = SendAppendEntries = senderAppendEntries sender None } :> IRaftCallbacks - let log = Log.make (term 1) defSM + let log = Log.make 1 defSM raft { - do! Raft.addMemberM peer - do! Raft.setStateM Leader - do! Raft.setTermM (term 1) - do! Raft.setCommitIndexM (index 0) - do! Raft.setNextIndexM peer.Id (index 1) - do! Raft.appendEntryM log >>= ignoreM + do! addMember peer + do! setState Leader + do! setCurrentTerm 1 + do! setCommitIndex 0 + do! setNextIndex peer.Id 1 + do! appendEntry log >>= ignoreM let! response = Raft.receiveEntry log !sender.Outbox @@ -1868,27 +1870,27 @@ module ServerTests = with SendAppendEntries = senderAppendEntries sender None } :> IRaftCallbacks - let log = Log.make (term 1) defSM + let log = Log.make 1 defSM let resp = - { Term = term 1 + { Term = 1 ; Success = false - ; CurrentIndex = index 0 - ; FirstIndex = index 0 + ; CurrentIndex = 0 + ; FirstIndex = 0 } raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader - do! Raft.setTermM (term 1) - do! Raft.setCommitIndexM (index 0) - do! Raft.appendEntryM log >>= ignoreM + do! addMember peer + do! setState Leader + do! setCurrentTerm 1 + do! setCommitIndex 0 + do! appendEntry log >>= ignoreM let! request = Raft.sendAppendEntry peer do! Raft.receiveAppendEntriesResponse peer.Id resp - do! expectM "Should have nextIdx Works 1" (index 1) (Raft.getMember peer.Id >> Option.get >> Member.nextIndex) + do! expectM "Should have nextIdx Works 1" 1 (RaftState.getMember peer.Id >> Option.get >> Member.nextIndex) do! Raft.receiveAppendEntriesResponse peer.Id resp - do! expectM "Should have nextIdx Dont work 1" (index 1) (Raft.getMember peer.Id >> Option.get >> Member.nextIndex) + do! expectM "Should have nextIdx Dont work 1" 1 (RaftState.getMember peer.Id >> Option.get >> Member.nextIndex) } |> runWithRaft raft' cbs |> noError @@ -1904,19 +1906,19 @@ module ServerTests = :> IRaftCallbacks let resp = - { Term = term 1 + { Term = 1 ; Success = true - ; CurrentIndex = index 0 - ; FirstIndex = index 0 + ; CurrentIndex = 0 + ; FirstIndex = 0 } raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader - do! Raft.setTermM (term 1) - do! expectM "Should have nextIdx 1" (index 1) (Raft.getMember peer.Id >> Option.get >> Member.nextIndex) + do! addMember peer + do! setState Leader + do! setCurrentTerm 1 + do! expectM "Should have nextIdx 1" 1 (RaftState.getMember peer.Id >> Option.get >> Member.nextIndex) do! Raft.receiveAppendEntriesResponse peer.Id resp - do! expectM "Should have nextIdx 1" (index 1) (Raft.getMember peer.Id >> Option.get >> Member.nextIndex) + do! expectM "Should have nextIdx 1" 1 (RaftState.getMember peer.Id >> Option.get >> Member.nextIndex) } |> runWithRaft raft' cbs |> noError @@ -1933,18 +1935,18 @@ module ServerTests = :> IRaftCallbacks let resp = - { Term = term 1 + { Term = 1 ; Success = true - ; CurrentIndex = index 1 - ; FirstIndex = index 1 + ; CurrentIndex = 1 + ; FirstIndex = 1 } raft { - do! Raft.addPeerM peer - do! Raft.setStateM Leader - do! Raft.setTermM (term 2) - do! expectM "Should have nextIdx 1" (index 1) (Raft.getMember peer.Id >> Option.get >> Member.nextIndex) + do! addMember peer + do! setState Leader + do! setCurrentTerm 2 + do! expectM "Should have nextIdx 1" 1 (RaftState.getMember peer.Id >> Option.get >> Member.nextIndex) do! Raft.receiveAppendEntriesResponse peer.Id resp - do! expectM "Should have nextIdx 1" (index 1) (Raft.getMember peer.Id >> Option.get >> Member.nextIndex) + do! expectM "Should have nextIdx 1" 1 (RaftState.getMember peer.Id >> Option.get >> Member.nextIndex) } |> runWithRaft raft' cbs |> noError @@ -1953,25 +1955,25 @@ module ServerTests = testCase "leader recv appendentries steps down if newer" <| fun _ -> let peer = Member.create (DiscoId.Create()) let ae = - { Term = term 6 - PrevLogIdx = index 6 - PrevLogTerm = term 5 - LeaderCommit = index 0 + { Term = 6 + PrevLogIdx = 6 + PrevLogTerm = 5 + LeaderCommit = 0 Entries = None } raft { let! raft' = get - let nid = Some raft'.Member.Id + let nid = Some raft'.MemberId let pid = Some peer.Id - do! Raft.addMemberM peer - do! Raft.setStateM Leader - do! Raft.setLeaderM (Some raft'.Member.Id) - do! Raft.setTermM (term 5) - do! expectM "Should be leader" true Raft.isLeader - do! expectM "Should be leader" true (Raft.currentLeader >> ((=) nid)) + do! addMember peer + do! setState Leader + do! setLeader (Some raft'.Member.Id) + do! setCurrentTerm 5 + do! expectM "Should be leader" true RaftState.isLeader + do! expectM "Should be leader" true (RaftState.currentLeader >> ((=) nid)) let! response = Raft.receiveAppendEntries (Some peer.Id) ae - do! expectM "Should be follower" true Raft.isFollower - do! expectM "Should follow peer" true (Raft.currentLeader >> ((=) pid)) + do! expectM "Should be follower" true RaftState.isFollower + do! expectM "Should follow peer" true (RaftState.currentLeader >> ((=) pid)) } |> runWithDefaults |> noError @@ -1980,18 +1982,18 @@ module ServerTests = testCase "leader recv appendentries steps down if newer term" <| fun _ -> let peer = Member.create (DiscoId.Create()) let resp = - { Term = term 6 - ; PrevLogIdx = index 5 - ; PrevLogTerm = term 5 - ; LeaderCommit = index 0 + { Term = 6 + ; PrevLogIdx = 5 + ; PrevLogTerm = 5 + ; LeaderCommit = 0 ; Entries = None } raft { - do! Raft.addMemberM peer - do! Raft.setStateM Leader - do! Raft.setTermM (term 5) + do! addMember peer + do! setState Leader + do! setCurrentTerm 5 let! response = Raft.receiveAppendEntries (Some peer.Id) resp - do! expectM "Should be follower" true Raft.isFollower + do! expectM "Should be follower" true RaftState.isFollower } |> runWithDefaults |> noError @@ -2007,10 +2009,10 @@ module ServerTests = let count = ref 0 let response = - ref { Term = term 0 + ref { Term = 0 Success = true - CurrentIndex = index 1 - FirstIndex = index 1 } + CurrentIndex = 1 + FirstIndex = 1 } let cbs = { Callbacks.Create (ref defSM) @@ -2023,21 +2025,21 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.addMembersM peers - do! Raft.setElectionTimeoutM 1000 - do! Raft.setRequestTimeoutM 500 - do! expectM "Should have timout elapsed 0" 0 Raft.timeoutElapsed + do! addMembers peers + do! setElectionTimeout 1000 + do! setRequestTimeout 500 + do! expectM "Should have timout elapsed 0" 0 RaftState.timeoutElapsed - do! Raft.setStateM Candidate + do! setState Candidate do! Raft.becomeLeader () do! expectM "Should have 2 messages " 2 (konst !count) // update CurrentIndex to latest memIdx to prevent StaleResponse error - let! mem1 = Raft.getMemberM peer1.Id + let! mem1 = getMember peer1.Id response := { !response with - CurrentIndex = Option.get mem1 |> Member.nextIndex |> ((+) (index 1)) } + CurrentIndex = Option.get mem1 |> Member.nextIndex |> ((+) 1) } do! Raft.periodic 501 @@ -2051,13 +2053,13 @@ module ServerTests = let peer1 = Member.create (DiscoId.Create()) let peer2 = Member.create (DiscoId.Create()) let sender = Sender.create - let resp = { Term = term 1; Granted = true; Reason = None } + let resp = { Term = 1; Granted = true; Reason = None } let vote = - { Term = term 1 + { Term = 1 ; Candidate = peer2 - ; LastLogIndex = index 0 - ; LastLogTerm = term 0 } + ; LastLogIndex = 0 + ; LastLogTerm = 0 } let peers = [| peer1; peer2 |] @@ -2065,15 +2067,15 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.addMembersM peers - do! Raft.setElectionTimeoutM 1000 - do! Raft.setRequestTimeoutM 500 - do! expectM "Should have timout elapsed 0" 0 Raft.timeoutElapsed + do! addMembers peers + do! setElectionTimeout 1000 + do! setRequestTimeout 500 + do! expectM "Should have timout elapsed 0" 0 RaftState.timeoutElapsed do! Raft.startElection () do! Raft.receiveVoteResponse peer1.Id resp - do! expectM "Should be leader" Leader Raft.getState + do! expectM "Should be leader" Leader RaftState.state let! resp = Raft.receiveVoteRequest peer2.Id vote - expect "Should have declined vote" true Vote.declined resp + expect "Should have declined vote" true VoteResponse.declined resp } |> runWithDefaults |> noError @@ -2085,13 +2087,13 @@ module ServerTests = let peer1 = Member.create (DiscoId.Create()) let peer2 = Member.create (DiscoId.Create()) let sender = Sender.create - let resp = { Term = term 1; Granted = true; Reason = None } + let resp = { Term = 1; Granted = true; Reason = None } let vote = - { Term = term 2 + { Term = 2 ; Candidate = peer2 - ; LastLogIndex = index 0 - ; LastLogTerm = term 0 } + ; LastLogIndex = 0 + ; LastLogTerm = 0 } let peers = [| peer1; peer2 |] @@ -2099,16 +2101,16 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.addMembersM peers - do! Raft.setElectionTimeoutM 1000 - do! Raft.setRequestTimeoutM 500 - do! expectM "Should have timout elapsed 0" 0 Raft.timeoutElapsed + do! addMembers peers + do! setElectionTimeout 1000 + do! setRequestTimeout 500 + do! expectM "Should have timout elapsed 0" 0 RaftState.timeoutElapsed do! Raft.startElection () do! Raft.receiveVoteResponse peer1.Id resp - do! expectM "Should be Leader" true Raft.isLeader + do! expectM "Should be Leader" true RaftState.isLeader let! resp = Raft.receiveVoteRequest peer2.Id vote - do! expectM "Should be Follower" true Raft.isFollower + do! expectM "Should be Follower" true RaftState.isFollower } |> runWithDefaults |> noError @@ -2123,7 +2125,7 @@ module ServerTests = let mutable i = 0 - let raft' = Raft.create mem1 + let raft' = RaftState.create mem1 let cbs = { Callbacks.Create (ref defSM) with SendRequestVote = fun _ _ -> i <- i + 1 } :> IRaftCallbacks @@ -2134,8 +2136,8 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.addPeersM peers - do! Raft.setElectionTimeoutM 1000 + do! addMembers peers + do! setElectionTimeout 1000 do! Raft.periodic 1001 expect "Should have sent 3 requests" 3 id i } @@ -2150,7 +2152,7 @@ module ServerTests = let mem3 = { Member.create (DiscoId.Create()) with Status = MemberStatus.Failed } let mem4 = { Member.create (DiscoId.Create()) with Status = MemberStatus.Failed } - let resp = { Term = term 1; Granted = true; Reason = None } + let resp = { Term = 1; Granted = true; Reason = None } let peers = [| mem1; mem2; mem3; mem4 |] @@ -2158,11 +2160,11 @@ module ServerTests = |> Map.ofArray raft { - do! Raft.addPeersM peers - do! Raft.setElectionTimeoutM 1000 + do! addMembers peers + do! setElectionTimeout 1000 do! Raft.periodic 1001 do! Raft.receiveVoteResponse mem1.Id resp - do! expectM "Should be leader now" Leader Raft.getState + do! expectM "Should be leader now" Leader RaftState.state } |> runWithDefaults |> noError @@ -2171,28 +2173,28 @@ module ServerTests = let server_periodic_should_trigger_snapshotting = testCase "periodic should trigger snapshotting when MaxLogDepth is reached" <| fun _ -> raft { - let trm = term 1 + let trm = 1 let depth = 40 - let! me = Raft.selfM () + let! me = self () - do! Raft.setMaxLogDepthM depth - do! Raft.setTermM trm + do! setMaxLogDepth depth + do! setCurrentTerm trm for n in 0 .. depth do - do! Raft.appendEntryM (Log.make trm defSM) >>= ignoreM + do! appendEntry (Log.make trm defSM) >>= ignoreM - do! Raft.setLeaderM (Some me.Id) - do! expectM "Should have correct number of entries" (depth + 1) Raft.numLogs + do! setLeader (Some me.Id) + do! expectM "Should have correct number of entries" (depth + 1) RaftState.numLogs do! Raft.periodic 10 - do! expectM "Should have correct number of entries" 1 Raft.numLogs + do! expectM "Should have correct number of entries" 1 RaftState.numLogs } |> runWithDefaults |> noError let server_should_apply_each_log_when_receiving_a_snapshot = testCase "should apply each log when receiving a snapshot" <| fun _ -> - let idx = index 9 - let trm = term 1 + let idx = 9 + let trm = 1 let count = ref 0 let init = defaultServer () @@ -2212,10 +2214,10 @@ module ServerTests = ; Data = Snapshot(DiscoId.Create(), idx, trm, idx, trm, mems, defSM) } raft { - do! Raft.setTermM trm + do! setCurrentTerm trm let! response = Raft.receiveInstallSnapshot is - do! expectM "Should have correct number of mems" 4 Raft.numMembers // including our own mem - do! expectM "Should have correct number of log entries" 1 Raft.numLogs + do! expectM "Should have correct number of mems" 4 RaftState.numMembers // including our own mem + do! expectM "Should have correct number of log entries" 1 RaftState.numLogs expect "Should have called ApplyLog once" 1 id !count } |> runWithRaft init cbs @@ -2223,9 +2225,9 @@ module ServerTests = let server_should_merge_snaphot_and_existing_log_when_receiving_a_snapshot = testCase "should merge snaphot and existing log when receiving a snapshot" <| fun _ -> - let idx = index 9 + let idx = 9 let num = 5 - let trm = term 1 + let trm = 1 let count = ref 0 let init = defaultServer () @@ -2246,16 +2248,16 @@ module ServerTests = } raft { - do! Raft.setTermM trm + do! setCurrentTerm trm for n in 0 .. (int idx + num) do - do! Raft.appendEntryM (Log.make trm (DataSnapshot (State.Empty))) >>= ignoreM + do! appendEntry (Log.make trm (DataSnapshot (State.Empty))) >>= ignoreM do! Raft.applyEntries () let! response = Raft.receiveInstallSnapshot is - do! expectM "Should have correct number of mems" 4 Raft.numMembers // including our own mem - do! expectM "Should have correct number of log entries" 7 Raft.numLogs + do! expectM "Should have correct number of mems" 4 RaftState.numMembers // including our own mem + do! expectM "Should have correct number of log entries" 7 RaftState.numLogs expect "Should have called ApplyLog once" 7 id !count } |> runWithRaft init cbs @@ -2280,16 +2282,16 @@ module ServerTests = raft { let mem = Member.create (DiscoId.Create()) - do! Raft.setStateM Leader + do! setState Leader - do! Raft.appendEntryM (JointConsensus(DiscoId.Create(), index 0, term 0, [| ConfigChange.MemberAdded(mem)|] ,None)) >>= ignoreM - do! Raft.setCommitIndexM (index 1) + do! appendEntry (JointConsensus(DiscoId.Create(), 0, 0, [| ConfigChange.MemberAdded(mem)|] ,None)) >>= ignoreM + do! setCommitIndex 1 do! Raft.applyEntries () expect "Should have count 1" 1 id !count - do! Raft.appendEntryM (JointConsensus(DiscoId.Create(), index 0, term 0, [| ConfigChange.MemberRemoved mem |] ,None)) >>= ignoreM - do! Raft.setCommitIndexM (index 3) + do! appendEntry (JointConsensus(DiscoId.Create(), 0, 0, [| ConfigChange.MemberRemoved mem |] ,None)) >>= ignoreM + do! setCommitIndex 3 do! Raft.applyEntries () expect "Should have count 2" 2 id !count @@ -2303,7 +2305,7 @@ module ServerTests = let init = defaultServer () - let cb l = count := LogEntry.getId l :: !count + let cb l = count := LogEntry.id l :: !count let cbs = { Callbacks.Create (ref defSM) with @@ -2311,19 +2313,19 @@ module ServerTests = } :> IRaftCallbacks raft { - let log1 = Log.make (term 0) defSM - let log2 = Log.make (term 0) defSM - let log3 = Log.make (term 0) defSM + let log1 = Log.make 0 defSM + let log2 = Log.make 0 defSM + let log3 = Log.make 0 defSM let ids = [ log3; log2; log1; ] - |> List.map LogEntry.getId + |> List.map LogEntry.id - do! Raft.setStateM Leader + do! setState Leader - do! Raft.appendEntryM log1 >>= ignoreM - do! Raft.appendEntryM log2 >>= ignoreM - do! Raft.appendEntryM log3 >>= ignoreM + do! appendEntry log1 >>= ignoreM + do! appendEntry log2 >>= ignoreM + do! appendEntry log3 >>= ignoreM expect "should have correct ids" ids id !count } @@ -2332,16 +2334,16 @@ module ServerTests = let server_should_call_delete_callback_for_each_deleted_log = testCase "should call delete callback for each deleted log" <| fun _ -> - let log1 = Log.make (term 0) defSM - let log2 = Log.make (term 0) defSM - let log3 = Log.make (term 0) defSM + let log1 = Log.make 0 defSM + let log2 = Log.make 0 defSM + let log3 = Log.make 0 defSM let count = ref [ log3; log2; log1; ] let init = defaultServer () let cb l = - let fltr l r = LogEntry.getId l <> LogEntry.getId r + let fltr l r = LogEntry.id l <> LogEntry.id r in count := List.filter (fltr l) !count let cbs = @@ -2350,20 +2352,20 @@ module ServerTests = } :> IRaftCallbacks raft { - do! Raft.setStateM Leader + do! setState Leader - do! Raft.appendEntryM log1 >>= ignoreM - do! Raft.appendEntryM log2 >>= ignoreM - do! Raft.appendEntryM log3 >>= ignoreM + do! appendEntry log1 >>= ignoreM + do! appendEntry log2 >>= ignoreM + do! appendEntry log3 >>= ignoreM - do! Raft.removeEntryM (index 3) - do! expectM "Should have only 2 entries" 2 Raft.numLogs + do! removeEntry 3 + do! expectM "Should have only 2 entries" 2 RaftState.numLogs - do! Raft.removeEntryM (index 2) - do! expectM "Should have only 1 entry" 1 Raft.numLogs + do! removeEntry 2 + do! expectM "Should have only 1 entry" 1 RaftState.numLogs - do! Raft.removeEntryM (index 1) - do! expectM "Should have zero entries" 0 Raft.numLogs + do! removeEntry 1 + do! expectM "Should have zero entries" 0 RaftState.numLogs expect "should have deleted all logs" List.empty id !count } @@ -2381,10 +2383,10 @@ module ServerTests = raft { let mem = Member.create (DiscoId.Create()) - do! Raft.addMemberM mem - do! Raft.updateMemberM { mem with Status = MemberStatus.Joining } - do! Raft.updateMemberM { mem with Status = MemberStatus.Running } - do! Raft.updateMemberM { mem with Status = MemberStatus.Failed } + do! addMember mem + do! updateMember { mem with Status = MemberStatus.Joining } + do! updateMember { mem with Status = MemberStatus.Running } + do! updateMember { mem with Status = MemberStatus.Failed } expect "Should have called once" 3 id !count } @@ -2410,10 +2412,10 @@ module ServerTests = let should_respond_to_appendentries_with_correct_next_idx = testCase "respond to appendentries with correct next idx" <| fun _ -> - let trm = term 1 + let trm = 1 raft { - do! Raft.setTermM trm + do! setCurrentTerm trm do! Raft.becomeLeader () let! response = Log.make trm defSM |> Raft.receiveEntry @@ -2428,18 +2430,18 @@ module ServerTests = let peer = Member.create (DiscoId.Create()) do! Raft.becomeFollower () - do! Raft.addMemberM peer + do! addMember peer - let! trm = Raft.currentTermM () - let! ci = Raft.currentIndexM () - let! fi = Raft.firstIndexM trm + let! trm = currentTerm () + let! ci = currentIndex () + let! fi = firstIndex trm let ping : AppendEntries = { Term = trm - ; PrevLogIdx = ci - ; PrevLogTerm = trm - ; LeaderCommit = ci - ; Entries = None } + PrevLogIdx = ci + PrevLogTerm = trm + LeaderCommit = ci + Entries = None } let! response = Raft.receiveAppendEntries (Some peer.Id) ping @@ -2460,10 +2462,10 @@ module ServerTests = :> IRaftCallbacks raft { - do! Raft.setTermM (term 1) + do! setCurrentTerm 1 do! Raft.becomeLeader () - let! term = Raft.currentTermM () + let! term = currentTerm () let log = Log.make term defSM let! result = Raft.receiveEntry log diff --git a/src/Disco/Disco/Tests/Raft/Tests.fs b/src/Disco/Disco/Tests/Raft/Tests.fs index 762f8bf7..a477db5c 100644 --- a/src/Disco/Disco/Tests/Raft/Tests.fs +++ b/src/Disco/Disco/Tests/Raft/Tests.fs @@ -16,8 +16,7 @@ module RaftTests = [] let raftTests = testList "Raft tests" - [ - // Continue + [ // Continue validation_dsl_validation // Node diff --git a/src/Disco/Disco/Tests/TestUtilities.fs b/src/Disco/Disco/Tests/TestUtilities.fs index aa2e672b..d2cb6363 100644 --- a/src/Disco/Disco/Tests/TestUtilities.fs +++ b/src/Disco/Disco/Tests/TestUtilities.fs @@ -42,11 +42,11 @@ module TestUtilities = let waitFor (tag: string) (we: WaitEvent) = if we.WaitOne(TimeSpan.FromMilliseconds DISCO_EVENT_TIMEOUT) - then Either.succeed() + then Result.succeed() else sprintf "Timout after %f waiting for %s" DISCO_EVENT_TIMEOUT tag |> Error.asOther "test" - |> Either.fail + |> Result.fail /// abstract over Assert.Equal to create pipe-lineable assertions let expect (msg : string) (a : 'a) (b : 't -> 'a) (t : 't) = @@ -63,15 +63,15 @@ module TestUtilities = let uuid = Guid.NewGuid() string uuid - let inline expectE (msg: string) (exp: 'b) (f: 'a -> 'b) (input: Either) = - either { + let inline expectE (msg: string) (exp: 'b) (f: 'a -> 'b) (input: DiscoResult<'a>) = + result { let! value = input let result = f value if result <> exp then return! sprintf "Expected %A but got %A in %A" exp result msg |> Error.asOther "expectE" - |> Either.fail + |> Result.fail else return () } @@ -79,10 +79,10 @@ module TestUtilities = let inline count< ^a when ^a : (member Count: int)> (thing: ^a) : int = (^a : (member Count: int) thing) - let inline noError (input: Either) = + let inline noError (input: DiscoResult<'a>) = match input with - | Right _ -> () - | Left error -> + | Ok _ -> () + | Error error -> error |> Error.toMessage |> Tests.failtest @@ -242,7 +242,7 @@ module TestData = Locked = rndbool () Active = rndbool () CueListId = rndopt() - Selected = index (rand.Next(0,1000)) + Selected = 1 * (rand.Next(0,1000)) CallId = DiscoId.Create() NextId = DiscoId.Create() PreviousId = DiscoId.Create() @@ -371,8 +371,8 @@ module TestData = [| for n in 0 .. rand.Next(1,10) do yield FsTreeTesting.makeTree (rand.Next(1,3)) (rand.Next(1,10)) |] - let mkState path : Either = - either { + let mkState path : DiscoResult = + result { let! project = mkProject path return { Project = project @@ -399,15 +399,15 @@ module TestData = [| for _ in 0 .. n do yield mkChange () |] - let mkLog _ : Either = - either { - let! state = mkTmpDir() |> Project.ofFilePath |> mkState + let mkLog _ : DiscoResult = + result { + let! state = mkTmpDir() |> mkState return - LogEntry(DiscoId.Create(), index 7, term 1, DataSnapshot(state), - Some <| LogEntry(DiscoId.Create(), index 6, term 1, DataSnapshot(state), - Some <| Configuration(DiscoId.Create(), index 5, term 1, [| mkMember () |], - Some <| JointConsensus(DiscoId.Create(), index 4, term 1, mkChanges (), - Some <| Snapshot(DiscoId.Create(), index 3, term 1, index 2, term 1, mkMembers (), DataSnapshot(state)))))) + LogEntry(DiscoId.Create(),7,1, DataSnapshot(state), + Some <| LogEntry(DiscoId.Create(),6,1, DataSnapshot(state), + Some <| Configuration(DiscoId.Create(),5,1, [| mkMember () |], + Some <| JointConsensus(DiscoId.Create(), 4, 1, mkChanges (), + Some <| Snapshot(DiscoId.Create(), 3, 1, 2, 1, mkMembers (), DataSnapshot(state)))))) |> Log.fromEntries } @@ -418,15 +418,15 @@ module TestData = new LibGit2Sharp.Repository(unwrap path) let inline binaryEncDec< ^t when ^t : (member ToBytes: unit -> byte[]) - and ^t : (static member FromBytes: byte[] -> Either) + and ^t : (static member FromBytes: byte[] -> DiscoResult< ^t >) and ^t : equality> (thing: ^t) = - let rething: ^t = thing |> Binary.encode |> Binary.decode |> Either.get + let rething: ^t = thing |> Binary.encode |> Binary.decode |> Result.get expect "Should be equal" thing id rething let inline yamlEncDec< ^i, ^t when ^t : (member ToYaml: unit -> ^i) - and ^t : (static member FromYaml: ^i -> Either) + and ^t : (static member FromYaml: ^i -> DiscoResult< ^t >) and ^t : equality> (thing: ^t) = - let rething: ^t = thing |> Yaml.encode |> Yaml.decode |> Either.get + let rething: ^t = thing |> Yaml.encode |> Yaml.decode |> Result.get expect "Should be equal" thing id rething diff --git a/src/Disco/Projects/Core/Core.fsproj b/src/Disco/Projects/Core/Core.fsproj index 0964ab25..744d34df 100644 --- a/src/Disco/Projects/Core/Core.fsproj +++ b/src/Disco/Projects/Core/Core.fsproj @@ -184,6 +184,12 @@ Types.fs + + RaftState.fs + + + RaftMonad.fs + Raft.fs diff --git a/src/Disco/Projects/Sdk/Sdk.fsproj b/src/Disco/Projects/Sdk/Sdk.fsproj index 9715a496..34d7464a 100644 --- a/src/Disco/Projects/Sdk/Sdk.fsproj +++ b/src/Disco/Projects/Sdk/Sdk.fsproj @@ -406,4 +406,4 @@ - \ No newline at end of file + diff --git a/src/Disco/Projects/Tests/Tests.fsproj b/src/Disco/Projects/Tests/Tests.fsproj index 1b66c150..cac1f139 100644 --- a/src/Disco/Projects/Tests/Tests.fsproj +++ b/src/Disco/Projects/Tests/Tests.fsproj @@ -112,6 +112,9 @@ ClonesFromLeader.fs + + AddedMemberShouldHaveCorrectState.fs + RemoveMemberShouldSplitCluster.fs diff --git a/src/Disco/Schema/Api.fbs b/src/Disco/Schema/Api.fbs index 19460ac7..1ec57bac 100644 --- a/src/Disco/Schema/Api.fbs +++ b/src/Disco/Schema/Api.fbs @@ -38,6 +38,7 @@ union ParameterFB { StateFB, ProjectFB, RaftMemberFB, + ClusterMemberFB, PinGroupFB, PinMappingFB, PinWidgetFB, diff --git a/src/Disco/Schema/Core.fbs b/src/Disco/Schema/Core.fbs index c194e188..9f14286d 100644 --- a/src/Disco/Schema/Core.fbs +++ b/src/Disco/Schema/Core.fbs @@ -675,10 +675,25 @@ table HostGroupFB { Members: [ string ]; } +table ClusterMemberFB { + Id: [ubyte]; + HostName: string; + IpAddress: string; + MulticastAddress: string; + MulticastPort: ushort; + HttpPort: ushort; + RaftPort: ushort; + WsPort: ushort; + GitPort: ushort; + ApiPort: ushort; + State: MemberStateFB; + Status: MemberStatusFB; +} + table ClusterConfigFB { Id: [ubyte]; Name: string; - Members: [ RaftMemberFB ]; + Members: [ ClusterMemberFB ]; Groups: [ HostGroupFB ]; } @@ -815,6 +830,7 @@ union StateMachinePayloadFB { PinGroupMapFB, DiscoClientFB, RaftMemberFB, + ClusterMemberFB, UserFB, SessionFB, LogEventFB, diff --git a/src/Disco/Serialization.csproj b/src/Disco/Serialization.csproj index 311a028f..4b689f0b 100644 --- a/src/Disco/Serialization.csproj +++ b/src/Disco/Serialization.csproj @@ -63,6 +63,7 @@ + diff --git a/src/Frontend/lib/react-ui-tree/node.js b/src/Frontend/lib/react-ui-tree/node.js index 38323864..9f59be59 100644 --- a/src/Frontend/lib/react-ui-tree/node.js +++ b/src/Frontend/lib/react-ui-tree/node.js @@ -92,4 +92,4 @@ var Node = React.createClass({ } }); -module.exports = Node; \ No newline at end of file +module.exports = Node; diff --git a/src/Frontend/lib/react-ui-tree/react-ui-tree.js b/src/Frontend/lib/react-ui-tree/react-ui-tree.js index 5fea5266..8aa3f7a1 100644 --- a/src/Frontend/lib/react-ui-tree/react-ui-tree.js +++ b/src/Frontend/lib/react-ui-tree/react-ui-tree.js @@ -230,4 +230,4 @@ module.exports = React.createClass({ this.change(tree); } -}); \ No newline at end of file +}); diff --git a/src/Frontend/src/Core.Frontend/FlatBufferTypes.fs b/src/Frontend/src/Core.Frontend/FlatBufferTypes.fs index d8372200..495bf170 100644 --- a/src/Frontend/src/Core.Frontend/FlatBufferTypes.fs +++ b/src/Frontend/src/Core.Frontend/FlatBufferTypes.fs @@ -1588,13 +1588,52 @@ type HostGroupFBConstructor = let HostGroupFB: HostGroupFBConstructor = failwith "JS only" +// CLUSTER MEMBER + +type ClusterMemberFB = + abstract Id: int -> byte + abstract IdLength: int + abstract HostName: string + abstract IpAddress: string + abstract MulticastAddress: string + abstract MulticastPort: uint16 + abstract RaftPort: uint16 + abstract HttpPort: uint16 + abstract WsPort: uint16 + abstract GitPort: uint16 + abstract ApiPort: uint16 + abstract State: MemberStateFB + abstract Status: MemberStatusFB + +type ClusterMemberFBConstructor = + abstract prototype: ClusterMemberFB with get, set + abstract StartClusterMemberFB: builder: FlatBufferBuilder -> unit + abstract AddId: builder: FlatBufferBuilder * id: VectorOffset -> unit + abstract AddHostName: builder: FlatBufferBuilder * hostname: Offset -> unit + abstract AddIpAddress: builder: FlatBufferBuilder * ip: Offset -> unit + abstract AddMulticastAddress: builder: FlatBufferBuilder * addr: Offset -> unit + abstract AddMulticastPort: builder: FlatBufferBuilder * port: uint16 -> unit + abstract AddRaftPort: builder: FlatBufferBuilder * port: uint16 -> unit + abstract AddHttpPort: builder: FlatBufferBuilder * port: uint16 -> unit + abstract AddWsPort: builder: FlatBufferBuilder * port: uint16 -> unit + abstract AddGitPort: builder: FlatBufferBuilder * port: uint16 -> unit + abstract AddApiPort: builder: FlatBufferBuilder * port: uint16 -> unit + abstract AddState: builder: FlatBufferBuilder * state: MemberStateFB -> unit + abstract AddStatus: builder: FlatBufferBuilder * state: MemberStatusFB -> unit + abstract EndClusterMemberFB: builder: FlatBufferBuilder -> Offset + abstract GetRootAsClusterMemberFB: bytes: ByteBuffer -> ClusterMemberFB + abstract CreateIdVector: builder: FlatBufferBuilder * id:byte array -> VectorOffset + abstract Create: unit -> ClusterMemberFB + +let ClusterMemberFB: ClusterMemberFBConstructor = failwith "JS only" + // CLUSTER CONFIG type ClusterConfigFB = abstract Id: int -> byte abstract IdLength: int abstract Name: string - abstract Members: int -> RaftMemberFB + abstract Members: int -> ClusterMemberFB abstract MembersLength: int abstract Groups: int -> HostGroupFB abstract GroupsLength: int @@ -1605,7 +1644,7 @@ type ClusterConfigFBConstructor = abstract AddId: builder: FlatBufferBuilder * id:VectorOffset -> unit abstract AddName: builder: FlatBufferBuilder * name:Offset -> unit abstract AddMembers: builder: FlatBufferBuilder * mems:Offset<'a> -> unit - abstract CreateMembersVector: FlatBufferBuilder * Offset array -> Offset<'a> + abstract CreateMembersVector: FlatBufferBuilder * Offset array -> Offset<'a> abstract AddGroups: builder: FlatBufferBuilder * mems:Offset<'a> -> unit abstract CreateIdVector: FlatBufferBuilder * id:byte array -> VectorOffset abstract CreateGroupsVector: FlatBufferBuilder * Offset array -> Offset<'a> @@ -2138,6 +2177,7 @@ type StateMachinePayloadFBConstructor = abstract PinMappingFB: StateMachinePayloadFB abstract PinWidgetFB: StateMachinePayloadFB abstract RaftMemberFB: StateMachinePayloadFB + abstract ClusterMemberFB: StateMachinePayloadFB abstract UserFB: StateMachinePayloadFB abstract SessionFB: StateMachinePayloadFB abstract LogEventFB: StateMachinePayloadFB @@ -2166,6 +2206,7 @@ type StateMachineFB = abstract PinMappingFB: PinMappingFB abstract PinWidgetFB: PinWidgetFB abstract RaftMemberFB: RaftMemberFB + abstract ClusterMemberFB: ClusterMemberFB abstract UserFB: UserFB abstract SessionFB: SessionFB abstract LogEventFB: LogEventFB diff --git a/src/Frontend/src/Frontend/Elmish/AssetBrowserView.fs b/src/Frontend/src/Frontend/Elmish/AssetBrowserView.fs index be4b4bca..6d222043 100644 --- a/src/Frontend/src/Frontend/Elmish/AssetBrowserView.fs +++ b/src/Frontend/src/Frontend/Elmish/AssetBrowserView.fs @@ -255,13 +255,13 @@ type AssetBrowserView(props) = // ** renderMachine - member this.renderMachine trees (node:RaftMember) = + member this.renderMachine trees (node:ClusterMember) = let isOpen = match this.state.Machine with | Some id when id = node.Id -> true | _ -> false - let nodeId = Member.id node + let nodeId = ClusterMember.id node let directories = if isOpen then @@ -292,7 +292,7 @@ type AssetBrowserView(props) = member this.renderMachineBrowser trees = let sites = this.props.Model.state - |> Option.map (State.sites >> Array.toList) + |> Option.map (State.sites >> Map.toList >> List.map snd) |> Option.defaultValue List.empty let members = @@ -301,7 +301,7 @@ type AssetBrowserView(props) = |> Option.bind (fun id -> List.tryFind (fun site -> ClusterConfig.id site = id) sites) |> Option.map (ClusterConfig.members >> Map.toList) |> Option.defaultValue List.empty - |> List.sortBy (snd >> Member.hostName) + |> List.sortBy (snd >> ClusterMember.hostName) |> List.map (snd >> this.renderMachine trees) div [ Class "machines" ] members diff --git a/src/Frontend/src/Frontend/Elmish/ClusterView.fs b/src/Frontend/src/Frontend/Elmish/ClusterView.fs index 306de5d0..df98916d 100644 --- a/src/Frontend/src/Frontend/Elmish/ClusterView.fs +++ b/src/Frontend/src/Frontend/Elmish/ClusterView.fs @@ -27,8 +27,8 @@ let activeConfig dispatch state = let config = state.Project.Config let current = state.Project.Config.Machine let members = - config.ActiveSite |> Option.bind (fun activeSite -> - config.Sites |> Seq.tryFind (fun site -> site.Id = activeSite)) + config.ActiveSite + |> Option.bind (flip Map.tryFind config.Sites) |> Option.map (fun site -> site.Members) |> Option.defaultValue Map.empty table [Class "disco-table"] [ @@ -91,8 +91,12 @@ let activeConfig dispatch state = OnClick (fun ev -> ev.stopPropagation() match Config.findMember config kv.Key with - | Right mem -> RemoveMember mem |> ClientContext.Singleton.Post - | Left error -> printfn "Cannot find member in config: %O" error) + | Ok mem -> + mem + |> ClusterMember.toRaftMember + |> RemoveMachine + |> ClientContext.Singleton.Post + | Error error -> printfn "Cannot find member in config: %O" error) ] [] ] ] diff --git a/src/Frontend/src/Frontend/Elmish/Cues/CuePlayerView.fs b/src/Frontend/src/Frontend/Elmish/Cues/CuePlayerView.fs index 4906e413..9a438bc7 100644 --- a/src/Frontend/src/Frontend/Elmish/Cues/CuePlayerView.fs +++ b/src/Frontend/src/Frontend/Elmish/Cues/CuePlayerView.fs @@ -70,11 +70,11 @@ let private updateCueList (player: CuePlayer option) (str:string) = | None -> () | Some player -> str |> DiscoId.TryParse |> function - | Either.Left _ -> + | Error _ -> CuePlayer.unsetCueList player |> UpdateCuePlayer |> ClientContext.Singleton.Post - | Either.Right id -> + | Ok id -> CuePlayer.setCueList id player |> UpdateCuePlayer |> ClientContext.Singleton.Post diff --git a/src/Frontend/src/Frontend/Elmish/Helpers.fs b/src/Frontend/src/Frontend/Elmish/Helpers.fs index b4c029dc..5568b8af 100644 --- a/src/Frontend/src/Frontend/Elmish/Helpers.fs +++ b/src/Frontend/src/Frontend/Elmish/Helpers.fs @@ -140,7 +140,7 @@ module Select = |> Msg.SelectElement |> dispatch - let clusterMember dispatch (mem: RaftMember) = + let clusterMember dispatch (mem: ClusterMember) = (mem.HostName, mem.Id) |> InspectorSelection.Member |> Msg.SelectElement diff --git a/src/Frontend/src/Frontend/Elmish/Inspectors/MemberInspector.fs b/src/Frontend/src/Frontend/Elmish/Inspectors/MemberInspector.fs index a01640d8..9ecc27a9 100644 --- a/src/Frontend/src/Frontend/Elmish/Inspectors/MemberInspector.fs +++ b/src/Frontend/src/Frontend/Elmish/Inspectors/MemberInspector.fs @@ -23,7 +23,7 @@ module MemberInspector = (string client.Name) (fun _ -> Select.client dispatch client) - let private renderClients tag dispatch (model: Model) (mem: RaftMember) = + let private renderClients tag dispatch (model: Model) (mem: ClusterMember) = match model.state with | None -> Common.row tag [] | Some state -> diff --git a/src/Frontend/src/Frontend/Elmish/PinView.fs b/src/Frontend/src/Frontend/Elmish/PinView.fs index b399fceb..369c217d 100644 --- a/src/Frontend/src/Frontend/Elmish/PinView.fs +++ b/src/Frontend/src/Frontend/Elmish/PinView.fs @@ -58,8 +58,8 @@ type PinView(props) = member this.valueAt(i) = match this.props.slices with - | Some slices -> slices.[index i].Value - | None -> this.props.pin.Slices.[index i].Value + | Some slices -> slices.[i].Value + | None -> this.props.pin.Slices.[i].Value // ** renderRows @@ -112,11 +112,11 @@ type PinView(props) = } if rowCount > 1 then td [ClassName "disco-flex-row"] [ - createElement("div", options, this.valueAt(0)) + createElement("div", options, this.valueAt(0)) this.renderArrow() ] else - td [] [createElement("div", options, this.valueAt(0))] + td [] [createElement("div", options, this.valueAt(0))] let head = tr [ClassName "disco-pin-child"] [ td [ @@ -175,7 +175,7 @@ type PinView(props) = } yield tr [Key (string i); ClassName "disco-pin-child"] [ td [] [str label] - td [] [createElement("div", options, this.valueAt(i))] + td [] [createElement("div", options, this.valueAt(1 * i))] ] ] else tbody [] [head] diff --git a/src/Frontend/src/Frontend/Elmish/PlayerListView.fs b/src/Frontend/src/Frontend/Elmish/PlayerListView.fs index 9661b882..7195e437 100644 --- a/src/Frontend/src/Frontend/Elmish/PlayerListView.fs +++ b/src/Frontend/src/Frontend/Elmish/PlayerListView.fs @@ -75,11 +75,11 @@ let private updateName (player:CuePlayer) (value:string) = let private updateCueList (player:CuePlayer) = function | Some id -> match DiscoId.TryParse id with - | Left _ -> + | Error _ -> CuePlayer.unsetCueList player |> UpdateCuePlayer |> ClientContext.Singleton.Post - | Right id -> + | Ok id -> CuePlayer.setCueList id player |> UpdateCuePlayer |> ClientContext.Singleton.Post diff --git a/src/Frontend/src/Frontend/Elmish/ProjectView.fs b/src/Frontend/src/Frontend/Elmish/ProjectView.fs index d11a3cef..ab7c1c96 100644 --- a/src/Frontend/src/Frontend/Elmish/ProjectView.fs +++ b/src/Frontend/src/Frontend/Elmish/ProjectView.fs @@ -47,7 +47,7 @@ let project2tree (p: DiscoProject) = ; obj2tree "Raft" c.Raft ; obj2tree "Timing" c.Timing ; leaf ("ActiveSite" + string c.ActiveSite) - ; arr2tree "Sites" (Array.map box c.Sites) + ; arr2tree "Sites" (c.Sites |> Map.toArray |> Array.map (snd >> box)) |] |> node "Config" [| leaf ("Id: " + string p.Id) ; leaf ("Name: " + unwrap p.Name) diff --git a/src/Frontend/src/Frontend/Elmish/Types.fs b/src/Frontend/src/Frontend/Elmish/Types.fs index 20a7da9f..f8c1d1fd 100644 --- a/src/Frontend/src/Frontend/Elmish/Types.fs +++ b/src/Frontend/src/Frontend/Elmish/Types.fs @@ -154,6 +154,7 @@ and UserConfig = logColumns: Map useRightClick: bool } + static member Create() = { logTextFilter = None logLevelFilter = None diff --git a/src/Frontend/src/Frontend/Lib.fs b/src/Frontend/src/Frontend/Lib.fs index d8d8c0c9..f6f32153 100644 --- a/src/Frontend/src/Frontend/Lib.fs +++ b/src/Frontend/src/Frontend/Lib.fs @@ -166,16 +166,9 @@ let addMember(memberIpAddr: string, memberHttpPort: uint16) = // Add member B to the leader (A) cluster { Member.create machine.MachineId with - HostName = machine.HostName - MulticastAddress = machine.MulticastAddress - MulticastPort = machine.MulticastPort - IpAddress = machine.BindAddress - HttpPort = machine.WebPort - RaftPort = machine.RaftPort - WsPort = machine.WsPort - GitPort = machine.GitPort - ApiPort = machine.ApiPort } - |> AddMember + IpAddress = machine.BindAddress + RaftPort = machine.RaftPort } + |> AddMachine |> ClientContext.Singleton.Post with | exn -> @@ -333,7 +326,7 @@ let updatePinValue(pin: Pin, index: int, value: obj) = | _ -> None | ColorPin pin -> match ColorSpace.TryParse(unbox value) with - | Right color -> + | Ok color -> tryUpdateArray index color pin.Values |> Option.map (fun values -> ColorSlices(pin.Id, client, values)) | _ -> None diff --git a/src/Frontend/src/Frontend/Main.fs b/src/Frontend/src/Frontend/Main.fs index a4aec330..d8dd5353 100644 --- a/src/Frontend/src/Frontend/Main.fs +++ b/src/Frontend/src/Frontend/Main.fs @@ -32,7 +32,7 @@ let findPinByName(model: Model, name: string) = if unwrap p.Name = pinName then Some p else None))) let getPinValueAt(pin: Pin, idx: int): obj = - let slice = pin.Slices.At(index idx) + let slice = pin.Slices.At(1 * idx) slice.Value let renderWidget(id, name, headFn, bodyFn, dispatch, model): React.ReactElement = diff --git a/src/Frontend/src/Frontend/MockData.fs b/src/Frontend/src/Frontend/MockData.fs index bdab0a40..9162b354 100644 --- a/src/Frontend/src/Frontend/MockData.fs +++ b/src/Frontend/src/Frontend/MockData.fs @@ -206,7 +206,7 @@ let project = List.map (fun (machine: DiscoMachine) -> let mem = - { Disco.Raft.Member.create machine.MachineId with + { ClusterMember.create machine.MachineId with HostName = machine.HostName Status = rndState() } (mem.Id, mem)) @@ -226,7 +226,7 @@ let project = Clients = ClientConfig.Default Raft = RaftConfig.Default Timing = TimingConfig.Default - Sites = [| clusterConfig |] } + Sites = Map [ clusterConfig.Id, clusterConfig ] } { Id = DiscoId.Create() Name = name "mockproject" Path = filepath "/Disco/mockproject" diff --git a/src/Frontend/src/Frontend/Worker.fs b/src/Frontend/src/Frontend/Worker.fs index 85f99fe8..f8980e82 100644 --- a/src/Frontend/src/Frontend/Worker.fs +++ b/src/Frontend/src/Frontend/Worker.fs @@ -176,8 +176,8 @@ type WorkerContext() = sock.OnMessage <- fun (ev: MessageEvent) -> match toBytes ev.Data |> Binary.decode with - | Right sm -> self.OnSocketMessage sm - | Left error -> + | Ok sm -> self.OnSocketMessage sm + | Error error -> sprintf "Unable to parse received message. %A" error |> self.Log LogLevel.Err diff --git a/src/Frontend/src/Tests.Frontend/SerializationTests.fs b/src/Frontend/src/Tests.Frontend/SerializationTests.fs index 61d77c20..9603ed24 100644 --- a/src/Frontend/src/Tests.Frontend/SerializationTests.fs +++ b/src/Frontend/src/Tests.Frontend/SerializationTests.fs @@ -171,12 +171,24 @@ module SerializationTests = [| for n in 0 .. rand.Next(1,20) do yield mkClient() |] - let mkMember _ = DiscoId.Create() |> Member.create + let mkMember _ : ClusterMember = + { Id = DiscoId.Create() + HostName = rndname () + IpAddress = IPv4Address "127.0.0.1" + MulticastAddress = IPv4Address "224.0.0.1" + MulticastPort = rndport() + HttpPort = rndport() + RaftPort = rndport() + WsPort = rndport() + GitPort = rndport() + ApiPort = rndport() + State = Follower + Status = Running } let mkSession _ = { Id = DiscoId.Create() - ; IpAddress = IPv4Address "127.0.0.1" - ; UserAgent = "Oh my goodness" } + IpAddress = IPv4Address "127.0.0.1" + UserAgent = "Oh my goodness" } let mkPinMapping _ = { Id = DiscoId.Create() @@ -199,7 +211,7 @@ module SerializationTests = Name = rndname () Locked = false Active = false - Selected = index (rand.Next(0,1000)) + Selected = 1 * (rand.Next(0,1000)) RemainingWait = rand.Next(0,1000) CueListId = rndopt () CallId = DiscoId.Create() @@ -267,7 +279,7 @@ module SerializationTests = DiscoveredServices = let ser = mkDiscoveredService() in Map.ofArray [| (ser.Id, ser) |] } let inline check thing = - let thong = thing |> Binary.encode |> Binary.decode |> Either.get + let thong = thing |> Binary.encode |> Binary.decode |> Result.get equals thing thong let main () = @@ -314,9 +326,12 @@ module SerializationTests = RemoveFsEntry (DiscoId.Create(), mkFsPath ()) AddFsTree <| mkFsTree() RemoveFsTree <| DiscoId.Create() - AddMember <| Member.create (DiscoId.Create()) - UpdateMember <| Member.create (DiscoId.Create()) - RemoveMember <| Member.create (DiscoId.Create()) + AddMachine <| Member.create (DiscoId.Create()) + UpdateMachine <| Member.create (DiscoId.Create()) + RemoveMachine <| Member.create (DiscoId.Create()) + AddMember <| mkMember() + UpdateMember <| mkMember() + RemoveMember <| mkMember() AddDiscoveredService <| mkDiscoveredService () UpdateDiscoveredService <| mkDiscoveredService () RemoveDiscoveredService <| mkDiscoveredService () @@ -328,57 +343,56 @@ module SerializationTests = finish() test "should serialize/deserialize cue correctly" <| fun finish -> - [| for i in 0 .. 20 do - yield mkCue () |] + [| for _ in 0 .. 20 -> mkCue () |] |> Array.iter check finish() testSync "Validate PinWidget Serialization" <| fun () -> let widget : PinWidget = mkPinWidget () - let rewidget = widget |> Binary.encode |> Binary.decode |> Either.get + let rewidget = widget |> Binary.encode |> Binary.decode |> Result.get equals widget rewidget testSync "Validate PinMapping Serialization" <| fun () -> let mapping : PinMapping = mkPinMapping () - let remapping = mapping |> Binary.encode |> Binary.decode |> Either.get + let remapping = mapping |> Binary.encode |> Binary.decode |> Result.get equals mapping remapping testSync "Validate Cue Serialization" <| fun () -> let cue : Cue = mkCue () - let recue = cue |> Binary.encode |> Binary.decode |> Either.get + let recue = cue |> Binary.encode |> Binary.decode |> Result.get equals cue recue testSync "Validate CueReference Serialization" <| fun () -> let cueReference : CueReference = mkCueRef () - let recueReference = cueReference |> Binary.encode |> Binary.decode |> Either.get + let recueReference = cueReference |> Binary.encode |> Binary.decode |> Result.get equals cueReference recueReference testSync "Validate CueGroup Serialization" <| fun () -> let cueGroup : CueGroup = mkCueGroup () - let recueGroup = cueGroup |> Binary.encode |> Binary.decode |> Either.get + let recueGroup = cueGroup |> Binary.encode |> Binary.decode |> Result.get equals cueGroup recueGroup test "Validate CueList Serialization" <| fun finish -> let cuelist : CueList = mkCueList () - let recuelist = cuelist |> Binary.encode |> Binary.decode |> Either.get + let recuelist = cuelist |> Binary.encode |> Binary.decode |> Result.get equals cuelist recuelist finish() test "Validate PinGroup Serialization" <| fun finish -> let group : PinGroup = mkPinGroup () - let regroup = group |> Binary.encode |> Binary.decode |> Either.get + let regroup = group |> Binary.encode |> Binary.decode |> Result.get equals group regroup finish() test "Validate Session Serialization" <| fun finish -> let session : Session = mkSession () - let resession = session |> Binary.encode |> Binary.decode |> Either.get + let resession = session |> Binary.encode |> Binary.decode |> Result.get equals session resession finish() test "Validate User Serialization" <| fun finish -> let user : User = mkUser () - let reuser = user |> Binary.encode |> Binary.decode |> Either.get + let reuser = user |> Binary.encode |> Binary.decode |> Result.get equals user reuser finish() @@ -422,7 +436,7 @@ module SerializationTests = test "Validate DiscoProject Binary Serializaton" <| fun finish -> mkProject() |> (fun project -> - let reproject = project |> Binary.encode |> Binary.decode |> Either.get + let reproject = project |> Binary.encode |> Binary.decode |> Result.get if project <> reproject then printfn "project: %O" project printfn "reproject: %O" reproject @@ -431,50 +445,53 @@ module SerializationTests = test "Validate StateMachine Serialization" <| fun finish -> [ AddCue <| mkCue () - ; UpdateCue <| mkCue () - ; RemoveCue <| mkCue () - ; AddCueList <| mkCueList () - ; UpdateCueList <| mkCueList () - ; RemoveCueList <| mkCueList () - ; AddCuePlayer <| mkCuePlayer () - ; UpdateCuePlayer <| mkCuePlayer () - ; RemoveCuePlayer <| mkCuePlayer () - ; AddSession <| mkSession () - ; UpdateSession <| mkSession () - ; RemoveSession <| mkSession () - ; AddUser <| mkUser () - ; UpdateUser <| mkUser () - ; RemoveUser <| mkUser () - ; AddPinGroup <| mkPinGroup () - ; UpdatePinGroup <| mkPinGroup () - ; RemovePinGroup <| mkPinGroup () - ; AddPinMapping <| mkPinMapping () - ; UpdatePinMapping <| mkPinMapping () - ; RemovePinMapping <| mkPinMapping () - ; AddPinWidget <| mkPinWidget () - ; UpdatePinWidget <| mkPinWidget () - ; RemovePinWidget <| mkPinWidget () - ; AddClient <| mkClient () - ; UpdateSlices <| mkSlicesMap () - ; UpdateClient <| mkClient () - ; RemoveClient <| mkClient () - ; AddPin <| mkPin () - ; UpdatePin <| mkPin () - ; RemovePin <| mkPin () - ; AddMember <| Member.create (DiscoId.Create()) - ; UpdateMember <| Member.create (DiscoId.Create()) - ; RemoveMember <| Member.create (DiscoId.Create()) - ; AddDiscoveredService <| mkDiscoveredService () - ; UpdateDiscoveredService <| mkDiscoveredService () - ; RemoveDiscoveredService <| mkDiscoveredService () - ; DataSnapshot <| mkState () - ; Command AppCommand.Undo - ; LogMsg(Logger.create Debug "bla" "ohai") - ; SetLogLevel Warn + UpdateCue <| mkCue () + RemoveCue <| mkCue () + AddCueList <| mkCueList () + UpdateCueList <| mkCueList () + RemoveCueList <| mkCueList () + AddCuePlayer <| mkCuePlayer () + UpdateCuePlayer <| mkCuePlayer () + RemoveCuePlayer <| mkCuePlayer () + AddSession <| mkSession () + UpdateSession <| mkSession () + RemoveSession <| mkSession () + AddUser <| mkUser () + UpdateUser <| mkUser () + RemoveUser <| mkUser () + AddPinGroup <| mkPinGroup () + UpdatePinGroup <| mkPinGroup () + RemovePinGroup <| mkPinGroup () + AddPinMapping <| mkPinMapping () + UpdatePinMapping <| mkPinMapping () + RemovePinMapping <| mkPinMapping () + AddPinWidget <| mkPinWidget () + UpdatePinWidget <| mkPinWidget () + RemovePinWidget <| mkPinWidget () + AddClient <| mkClient () + UpdateSlices <| mkSlicesMap () + UpdateClient <| mkClient () + RemoveClient <| mkClient () + AddPin <| mkPin () + UpdatePin <| mkPin () + RemovePin <| mkPin () + AddMachine <| Member.create (DiscoId.Create()) + UpdateMachine <| Member.create (DiscoId.Create()) + RemoveMachine <| Member.create (DiscoId.Create()) + AddMember <| mkMember() + UpdateMember <| mkMember() + RemoveMember <| mkMember() + AddDiscoveredService <| mkDiscoveredService () + UpdateDiscoveredService <| mkDiscoveredService () + RemoveDiscoveredService <| mkDiscoveredService () + DataSnapshot <| mkState () + Command AppCommand.Undo + LogMsg(Logger.create Debug "bla" "ohai") + SetLogLevel Warn ] |> List.iter (fun ting -> - let reting = ting |> Binary.encode |> Binary.decode |> Either.get + let reting = ting |> Binary.encode |> Binary.decode |> Result.get if ting <> reting then printfn "ting: %O" ting printfn "reting: %O" reting @@ -501,7 +518,7 @@ module SerializationTests = |> Binary.createBuffer |> ErrorFB.GetRootAsErrorFB |> DiscoError.FromFB - |> Either.get + |> Result.get equals error reerror) finish() diff --git a/src/Unity/Main.fs b/src/Unity/Main.fs index c4e61be6..b0405ae3 100644 --- a/src/Unity/Main.fs +++ b/src/Unity/Main.fs @@ -118,11 +118,11 @@ let startActor(state, client: IApiClient, clientId, print: string->unit) = // Subscribe to API client events apiobs <- client.Subscribe(DiscoEvent >> actor.Post) |> Some match client.Start() with - | Right () -> + | Ok () -> Logger.info "startClient" "Successfully started Unity ApiClient" print(sprintf "Successfully started Disco Client (status %A)" client.Status) actor - | Left error -> + | Error error -> let msg = string error Logger.err "startClient" msg print ("Couldn't start Disco Client: " + msg)