diff --git a/NightLight.Core.Tests/ArbitraryInteractionLists.fs b/NightLight.Core.Tests/ArbitraryInteractionLists.fs deleted file mode 100644 index 9098db1..0000000 --- a/NightLight.Core.Tests/ArbitraryInteractionLists.fs +++ /dev/null @@ -1,25 +0,0 @@ -module NightLight.Core.Tests.ArbitraryInteractionLists - -open System -open FsCheck.FSharp -open NightLight.Core.Tests.InteractionListGenerators - -let private isDay (time: DateTime) = - time.TimeOfDay >= TimeSpan.FromHours 5.5 - && time.TimeOfDay < TimeSpan.FromHours 20.5 - -type ArbitraryInteractionsListThatEndsDuringTheDay = - static member InteractionsList() = - ArbMap.defaults - |> ArbMap.generate - |> Gen.filter isDay - |> Gen.bind genInteractionsListThatEndsAtTime - |> Arb.fromGen - -type ArbitraryInteractionsListThatEndsDuringTheNight = - static member InteractionsList() = - ArbMap.defaults - |> ArbMap.generate - |> Gen.filter (not << isDay) - |> Gen.bind genInteractionsListThatEndsAtTime - |> Arb.fromGen diff --git a/NightLight.Core.Tests/FakeHome.fs b/NightLight.Core.Tests/FakeHome.fs index 3facd72..bf1b919 100644 --- a/NightLight.Core.Tests/FakeHome.fs +++ b/NightLight.Core.Tests/FakeHome.fs @@ -7,8 +7,10 @@ open FsToolkit.ErrorHandling open FSharp.Data type HumanInteraction = - | LightTurnedOn of Light - | LightTurnedOff of Light + | LightPoweredOn of Light + | LightPoweredOff of Light + | RemotePressedOnButton + | RemotePressedOffButton type Interaction = | HumanInteraction of HumanInteraction @@ -25,19 +27,28 @@ type LightState = type FakeLight(light: Light) = let mutable hasPower = false + let mutable state = true let mutable brightness: byte = 255uy let mutable color: Color = White - member _.LightWithState = light, if hasPower then On(brightness, color) else Off + member _.LightWithState = + light, if hasPower && state then On(brightness, color) else Off - member _.TurnOn() = hasPower <- true + member _.PowerOn() = hasPower <- true - member _.TurnOff() = hasPower <- false + member _.PowerOff() = hasPower <- false + + member _.SetState(newState: bool) = + if hasPower then + state <- newState member _.SetBrightness(newBrightness: byte) = if hasPower then brightness <- newBrightness + if light.Bulb = IkeaBulb then + state <- true + member _.SetColor(newColor: Color) = if hasPower then color <- newColor @@ -69,6 +80,12 @@ type FakeHome() = let parsedPayload = JsonValue.Parse command.Payload + match parsedPayload.TryGetProperty "state" with + | Some(JsonValue.String "ON") -> fakeLight.SetState true + | Some(JsonValue.String "OFF") -> fakeLight.SetState false + | None -> () + | value -> failwith $"Unexpected state value {value}" + match parsedPayload.TryGetProperty "brightness" with | Some(JsonValue.Number newBrightness) -> fakeLight.SetBrightness(byte newBrightness) | None -> () @@ -91,8 +108,8 @@ type FakeHome() = member _.Interact(interaction: Interaction) = match interaction with - | HumanInteraction(LightTurnedOn light) -> - friendlyNameToFakeLight[light.FriendlyName].TurnOn() + | HumanInteraction(LightPoweredOn light) -> + friendlyNameToFakeLight[light.FriendlyName].PowerOn() { Topic = "zigbee2mqtt/bridge/event" Payload = @@ -102,7 +119,17 @@ type FakeHome() = }}" } |> ReceivedZigbeeEvent |> onEventPublished.Trigger - | HumanInteraction(LightTurnedOff light) -> friendlyNameToFakeLight[light.FriendlyName].TurnOff() + | HumanInteraction(LightPoweredOff light) -> friendlyNameToFakeLight[light.FriendlyName].PowerOff() + | HumanInteraction RemotePressedOnButton -> + { Topic = $"zigbee2mqtt/{remoteControlFriendlyName.Get}" + Payload = @"{ ""action"": ""on"" }" } + |> ReceivedZigbeeEvent + |> onEventPublished.Trigger + | HumanInteraction RemotePressedOffButton -> + { Topic = $"zigbee2mqtt/{remoteControlFriendlyName.Get}" + Payload = @"{ ""action"": ""off"" }" } + |> ReceivedZigbeeEvent + |> onEventPublished.Trigger | TimeChanged newTime -> newTime |> Event.TimeChanged |> onEventPublished.Trigger type FakeHome with @@ -115,3 +142,8 @@ type FakeHome with | On(brightness, color) -> Some(light, brightness, color) | Off -> None) |> Seq.forall condition + + member this.ForAllRemotelyControlledLights condition = + this.LightStates + |> Seq.filter (fst >> _.ControlledWithRemote) + |> Seq.forall condition diff --git a/NightLight.Core.Tests/InteractionListGenerators.fs b/NightLight.Core.Tests/InteractionListGenerators.fs index d1e1925..269c94e 100644 --- a/NightLight.Core.Tests/InteractionListGenerators.fs +++ b/NightLight.Core.Tests/InteractionListGenerators.fs @@ -8,34 +8,39 @@ let private genTimeChangedInteraction = ArbMap.defaults |> ArbMap.generate |> Gen.map Interaction.TimeChanged let private genHumanInteraction = - Gen.elements lights - |> Gen.bind (fun light -> - [ LightTurnedOn light; LightTurnedOff light ] - |> Gen.elements - |> Gen.map Interaction.HumanInteraction) + let genLightInteraction = + Gen.elements lights + |> Gen.bind (fun light -> Gen.elements [ LightPoweredOn light; LightPoweredOff light ]) + + let genRemoteInteraction = + Gen.elements [ RemotePressedOnButton; RemotePressedOffButton ] + + Gen.oneof [ genLightInteraction; genRemoteInteraction ] + |> Gen.map Interaction.HumanInteraction let private genInteraction = Gen.oneof [ genTimeChangedInteraction; genHumanInteraction ] -let private genInteractionsListThatStartsWithTimeChange = +let private genInteractionsListThatStartsWithTimeChanged = gen { let! firstInteraction = genTimeChangedInteraction let! remainingInteractions = Gen.listOf genInteraction return firstInteraction :: remainingInteractions } -let private genInteractionsListWhere condition = - Gen.listOf (genInteraction |> Gen.filter condition) +let genInteractionListContaining containingInteraction disqualifiedAfter = + gen { + let genNonTrivialList = + gen { + let! before = genInteractionsListThatStartsWithTimeChanged + let! after = Gen.listOf (genInteraction |> Gen.filter (not << disqualifiedAfter)) + return before @ containingInteraction :: after + } -let genInteractionsListThatEndsAtTime time = - let genTrivialList = Gen.constant <| List.singleton (Interaction.TimeChanged time) - - let genNonTrivialList = - gen { - let! before = genInteractionsListThatStartsWithTimeChange - let interactionThatSetsEndTime = Interaction.TimeChanged time - let! after = genInteractionsListWhere (not << _.IsTimeChanged) - return before @ interactionThatSetsEndTime :: after - } - - Gen.frequency [ 1, genTrivialList; 9, genNonTrivialList ] + return! + match containingInteraction with + | Interaction.TimeChanged _ -> + let genTrivialList = Gen.constant <| List.singleton containingInteraction + Gen.frequency [ 1, genTrivialList; 9, genNonTrivialList ] + | _ -> genNonTrivialList + } diff --git a/NightLight.Core.Tests/NightLight.Core.Tests.fsproj b/NightLight.Core.Tests/NightLight.Core.Tests.fsproj index 66f25e0..8dbe2c5 100644 --- a/NightLight.Core.Tests/NightLight.Core.Tests.fsproj +++ b/NightLight.Core.Tests/NightLight.Core.Tests.fsproj @@ -9,7 +9,7 @@ - + diff --git a/NightLight.Core.Tests/NightLightTests.fs b/NightLight.Core.Tests/NightLightTests.fs index 6423a68..57ed0f4 100644 --- a/NightLight.Core.Tests/NightLightTests.fs +++ b/NightLight.Core.Tests/NightLightTests.fs @@ -1,8 +1,10 @@ namespace NightLight.Core.Tests open NightLight.Core.Core -open NightLight.Core.Tests.ArbitraryInteractionLists +open NightLight.Core.Tests.TimeChangedGenerators +open NightLight.Core.Tests.InteractionListGenerators open FsCheck.Xunit +open FsCheck.FSharp type NightLightTests() = let createFakeHomeWithNightLightAndInteract (interactions: Interaction list) = @@ -21,12 +23,35 @@ type NightLightTests() = fakeHome - [ |])>] - let ``Lights should be white or yellow during the day`` (interactions: Interaction list) = - let fakeHome = createFakeHomeWithNightLightAndInteract interactions - fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = White || color = Yellow) + [] + let ``All lights that are on should be white or yellow during the day`` () = + genTimeChangedToDay + |> Gen.bind (fun timeChangedToDay -> genInteractionListContaining timeChangedToDay _.IsTimeChanged) + |> Arb.fromGen + |> Prop.forAll + <| fun interactions -> + let fakeHome = createFakeHomeWithNightLightAndInteract interactions + fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = White || color = Yellow) - [ |])>] - let ``Lights should be red during the night`` (interactions: Interaction list) = - let fakeHome = createFakeHomeWithNightLightAndInteract interactions - fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = Red) + [] + let ``All lights that are on should be red during the night`` () = + genTimeChangedToNight + |> Gen.bind (fun timeChangedToNight -> genInteractionListContaining timeChangedToNight _.IsTimeChanged) + |> Arb.fromGen + |> Prop.forAll + <| fun interactions -> + let fakeHome = createFakeHomeWithNightLightAndInteract interactions + fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = Red) + + [] + let ``After pressing 'Off' on the remote, the remotely controlled lights should stay off until 'On' is pressed`` + () + = + genInteractionListContaining + (HumanInteraction RemotePressedOffButton) + ((=) (HumanInteraction RemotePressedOnButton)) + |> Arb.fromGen + |> Prop.forAll + <| fun interactions -> + let fakeHome = createFakeHomeWithNightLightAndInteract interactions + fakeHome.ForAllRemotelyControlledLights(fun (_, state) -> state = Off) diff --git a/NightLight.Core.Tests/TimeChangedGenerators.fs b/NightLight.Core.Tests/TimeChangedGenerators.fs new file mode 100644 index 0000000..6f1300d --- /dev/null +++ b/NightLight.Core.Tests/TimeChangedGenerators.fs @@ -0,0 +1,20 @@ +module NightLight.Core.Tests.TimeChangedGenerators + +open System +open FsCheck.FSharp + +let private isDay (time: DateTime) = + time.TimeOfDay >= TimeSpan.FromHours 5.5 + && time.TimeOfDay < TimeSpan.FromHours 20.5 + +let genTimeChangedToDay = + ArbMap.defaults + |> ArbMap.generate + |> Gen.filter isDay + |> Gen.map Interaction.TimeChanged + +let genTimeChangedToNight = + ArbMap.defaults + |> ArbMap.generate + |> Gen.filter (not << isDay) + |> Gen.map Interaction.TimeChanged diff --git a/NightLight.Core/Models.fs b/NightLight.Core/Models.fs index b9fa8db..5243bcb 100644 --- a/NightLight.Core/Models.fs +++ b/NightLight.Core/Models.fs @@ -9,6 +9,7 @@ type Event = | TimeChanged of DateTime type ParseZigbeeEventError = + | UnknownTopic of string | InvalidJson | MissingTypeField | MissingDataField @@ -16,6 +17,8 @@ type ParseZigbeeEventError = | InvalidTypeField | InvalidFriendlyNameField | UnknownType + | MissingActionField + | InvalidActionField type OnEventReceivedError = | ParseZigbeeEventError of ParseZigbeeEventError @@ -40,21 +43,29 @@ type DeviceFriendlyName = type Light = { FriendlyName: DeviceFriendlyName Room: Room - Bulb: Bulb } + Bulb: Bulb + ControlledWithRemote: bool } let lights = [ { FriendlyName = DeviceFriendlyName "Vardagsrum - Fönsterlampa" Room = LivingRoom - Bulb = IkeaBulb } + Bulb = IkeaBulb + ControlledWithRemote = true } { FriendlyName = DeviceFriendlyName "Vardagsrum - Vägglampa" Room = LivingRoom - Bulb = PaulmannBulb } + Bulb = PaulmannBulb + ControlledWithRemote = false } { FriendlyName = DeviceFriendlyName "Vardagsrum - Golvlampa" Room = LivingRoom - Bulb = PaulmannBulb } + Bulb = PaulmannBulb + ControlledWithRemote = false } { FriendlyName = DeviceFriendlyName "Badrum - Taklampa" Room = Bathroom - Bulb = IkeaBulb } + Bulb = IkeaBulb + ControlledWithRemote = false } { FriendlyName = DeviceFriendlyName "Sovrum - Nattduksbordlampa" Room = Bedroom - Bulb = IkeaBulb } ] + Bulb = IkeaBulb + ControlledWithRemote = true } ] + +let remoteControlFriendlyName = DeviceFriendlyName "Fjärrkontroll" diff --git a/NightLight.Core/NightLightStateMachine.fs b/NightLight.Core/NightLightStateMachine.fs index f1d5d54..6068de5 100644 --- a/NightLight.Core/NightLightStateMachine.fs +++ b/NightLight.Core/NightLightStateMachine.fs @@ -11,14 +11,19 @@ open FsToolkit.ErrorHandling let internal tryFindLight friendlyName = Seq.tryFind (fun light -> light.FriendlyName = friendlyName) lights -let internal generateZigbeeCommandToFixLight partOfDay light = - let color, brightness = - getDesiredMood light.Room partOfDay |> getDesiredColorAndBrightness light.Bulb +let internal generateZigbeeCommandsToFixLight state partOfDay light = + seq { + yield generateStateCommand state light - generateZigbeeCommand light.FriendlyName color brightness + if state = On then + let color, brightness = + getDesiredMood light.Room partOfDay |> getDesiredColorAndBrightness light.Bulb -type NightLightStateMachine private (maybeTime: DateTime option) = - new() = NightLightStateMachine None + yield generateZigbeeCommand color brightness light + } + +type NightLightStateMachine private (maybeTime: DateTime option, lightToState: Map) = + new() = NightLightStateMachine(None, lights |> Seq.map (fun light -> light, On) |> Map.ofSeq) member this.OnEventReceived(event: Event) : Result = result { @@ -29,22 +34,39 @@ type NightLightStateMachine private (maybeTime: DateTime option) = let! zigbeeEvent = parseZigbeeEvent payload |> Result.mapError ParseZigbeeEventError return - this, match zigbeeEvent with | DeviceAnnounce friendlyName -> let maybeLight = tryFindLight friendlyName + this, match maybeLight with - | Some light -> generateZigbeeCommandToFixLight partOfDay light |> Seq.singleton + | Some light -> generateZigbeeCommandsToFixLight lightToState[light] partOfDay light | None -> Seq.empty + | ButtonPress action -> + let desiredLightState = + match action with + | PressedOn -> On + | PressedOff -> Off + + let remoteControlledLights = lights |> Seq.filter _.ControlledWithRemote + + let newLightToState = + remoteControlledLights + |> Seq.fold (fun acc key -> Map.add key desiredLightState acc) lightToState + + NightLightStateMachine(maybeTime, newLightToState), + remoteControlledLights + |> Seq.collect (fun light -> generateZigbeeCommandsToFixLight desiredLightState partOfDay light) | TimeChanged newTime, maybePartOfDay -> - let newState = NightLightStateMachine(Some newTime) + let newState = NightLightStateMachine(Some newTime, lightToState) let newPartOfDay = getPartOfDay newTime return newState, if maybePartOfDay <> Some newPartOfDay then - lights |> Seq.map (generateZigbeeCommandToFixLight newPartOfDay) + lights + |> Seq.collect (fun light -> + generateZigbeeCommandsToFixLight lightToState[light] newPartOfDay light) else Seq.empty | _, None -> return! Error TimeIsUnknown diff --git a/NightLight.Core/ZigbeeCommands.fs b/NightLight.Core/ZigbeeCommands.fs index 2d25c04..955c041 100644 --- a/NightLight.Core/ZigbeeCommands.fs +++ b/NightLight.Core/ZigbeeCommands.fs @@ -4,7 +4,28 @@ open System.Text.Json.Nodes open NightLight.Core.Models open NightLight.Core.Moods -let generateZigbeeCommand (friendlyName: DeviceFriendlyName) targetColor targetBrightness = +type State = + | On + | Off + +let toZigbeeCommand light payload = + let topic = $"zigbee2mqtt/{light.FriendlyName.Get}/set" + { Topic = topic; Payload = payload } + +let generateStateCommand state light = + let commandObj = JsonObject() + + commandObj["state"] <- + match state with + | On -> "ON" + | Off -> "OFF" + + if light.Bulb = IkeaBulb then + commandObj["transition"] <- 0 + + commandObj.ToJsonString() |> toZigbeeCommand light + +let generateZigbeeCommand targetColor targetBrightness light = let commandObj = JsonObject() match targetColor with @@ -19,7 +40,4 @@ let generateZigbeeCommand (friendlyName: DeviceFriendlyName) targetColor targetB match targetBrightness with | Brightness b -> b - let topic = $"zigbee2mqtt/{friendlyName.Get}/set" - let payload = commandObj.ToJsonString() - - { Topic = topic; Payload = payload } + commandObj.ToJsonString() |> toZigbeeCommand light diff --git a/NightLight.Core/ZigbeeEvents.fs b/NightLight.Core/ZigbeeEvents.fs index e6a9769..632c6b1 100644 --- a/NightLight.Core/ZigbeeEvents.fs +++ b/NightLight.Core/ZigbeeEvents.fs @@ -4,22 +4,38 @@ open NightLight.Core.Models open FsToolkit.ErrorHandling open FSharp.Data -type ZigbeeEvent = DeviceAnnounce of DeviceFriendlyName +type Action = + | PressedOn + | PressedOff + +type ZigbeeEvent = + | DeviceAnnounce of DeviceFriendlyName + | ButtonPress of Action let parseZigbeeEvent (message: Message) = result { let! jsonValue = JsonValue.TryParse message.Payload |> Result.requireSome InvalidJson - let! messageType = jsonValue.TryGetProperty "type" |> Result.requireSome MissingTypeField - let! messageData = jsonValue.TryGetProperty "data" |> Result.requireSome MissingDataField + match message.Topic with + | "zigbee2mqtt/bridge/event" -> + let! messageType = jsonValue.TryGetProperty "type" |> Result.requireSome MissingTypeField + let! messageData = jsonValue.TryGetProperty "data" |> Result.requireSome MissingDataField - return! - match messageType with - | JsonValue.String "device_announce" -> - match messageData.TryGetProperty "friendly_name" with - | Some(JsonValue.String friendlyName) -> Ok <| DeviceAnnounce(DeviceFriendlyName friendlyName) - | Some _ -> Error InvalidFriendlyNameField - | None -> Error MissingFriendlyNameField - | JsonValue.String _ -> Error UnknownType - | _ -> Error InvalidTypeField + return! + match messageType with + | JsonValue.String "device_announce" -> + match messageData.TryGetProperty "friendly_name" with + | Some(JsonValue.String friendlyName) -> Ok <| DeviceAnnounce(DeviceFriendlyName friendlyName) + | Some _ -> Error InvalidFriendlyNameField + | None -> Error MissingFriendlyNameField + | JsonValue.String _ -> Error UnknownType + | _ -> Error InvalidTypeField + | "zigbee2mqtt/Fjärrkontroll" -> + return! + match jsonValue.TryGetProperty "action" with + | Some(JsonValue.String "on") -> Ok(ButtonPress PressedOn) + | Some(JsonValue.String "off") -> Ok(ButtonPress PressedOff) + | Some _ -> Error InvalidActionField + | None -> Error MissingActionField + | _ -> return! Error <| UnknownTopic message.Topic } diff --git a/NightLight/Program.fs b/NightLight/Program.fs index 04b900f..08739ca 100644 --- a/NightLight/Program.fs +++ b/NightLight/Program.fs @@ -104,8 +104,9 @@ let mainAsync _ = do! mqttClient.ConnectAsync mqttClientOptions |> Async.AwaitTask |> Async.Ignore do! - mqttClient.SubscribeAsync "zigbee2mqtt/bridge/event" - |> Async.AwaitTask + [ "zigbee2mqtt/bridge/event"; $"zigbee2mqtt/{remoteControlFriendlyName.Get}" ] + |> Seq.map (fun topic -> async { return! mqttClient.SubscribeAsync topic |> Async.AwaitTask }) + |> Async.Sequential |> Async.Ignore while true do