Merge pull request #6 from svenvanheugten/add-remote-control

Add remote control

NightLight.Core.Tests/ArbitraryInteractionLists.fs

@@ -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<DateTime>
-        |> Gen.filter isDay
-        |> Gen.bind genInteractionsListThatEndsAtTime
-        |> Arb.fromGen
-
-type ArbitraryInteractionsListThatEndsDuringTheNight =
-    static member InteractionsList() =
-        ArbMap.defaults
-        |> ArbMap.generate<DateTime>
-        |> Gen.filter (not << isDay)
-        |> Gen.bind genInteractionsListThatEndsAtTime
-        |> Arb.fromGen

NightLight.Core.Tests/FakeHome.fs

@@ -7,8 +7,10 @@ open FsToolkit.ErrorHandling
 open FSharp.Data
 
 type HumanInteraction =
-    | LightTurnedOn of Light
+    | LightPoweredOn of Light
-    | LightTurnedOff 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) ->
+        | HumanInteraction(LightPoweredOn light) ->
-            friendlyNameToFakeLight[light.FriendlyName].TurnOn()
+            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

NightLight.Core.Tests/InteractionListGenerators.fs

@@ -8,34 +8,39 @@ let private genTimeChangedInteraction =
     ArbMap.defaults |> ArbMap.generate<DateTime> |> Gen.map Interaction.TimeChanged
 
 let private genHumanInteraction =
-    Gen.elements lights
+    let genLightInteraction =
-    |> Gen.bind (fun light ->
+        Gen.elements lights
-        [ LightTurnedOn light; LightTurnedOff light ]
+        |> Gen.bind (fun light -> Gen.elements [ LightPoweredOn light; LightPoweredOff light ])
-        |> Gen.elements
+
-        |> Gen.map Interaction.HumanInteraction)
+    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 =
+let genInteractionListContaining containingInteraction disqualifiedAfter =
-    Gen.listOf (genInteraction |> Gen.filter condition)
+    gen {
+        let genNonTrivialList =
+            gen {
+                let! before = genInteractionsListThatStartsWithTimeChanged
+                let! after = Gen.listOf (genInteraction |> Gen.filter (not << disqualifiedAfter))
+                return before @ containingInteraction :: after
+            }
 
-let genInteractionsListThatEndsAtTime time =
+        return!
-    let genTrivialList = Gen.constant <| List.singleton (Interaction.TimeChanged time)
+            match containingInteraction with
-
+            | Interaction.TimeChanged _ ->
-    let genNonTrivialList =
+                let genTrivialList = Gen.constant <| List.singleton containingInteraction
-        gen {
+                Gen.frequency [ 1, genTrivialList; 9, genNonTrivialList ]
-            let! before = genInteractionsListThatStartsWithTimeChange
+            | _ -> genNonTrivialList
-            let interactionThatSetsEndTime = Interaction.TimeChanged time
+    }
-            let! after = genInteractionsListWhere (not << _.IsTimeChanged)
-            return before @ interactionThatSetsEndTime :: after
-        }
-
-    Gen.frequency [ 1, genTrivialList; 9, genNonTrivialList ]

NightLight.Core.Tests/NightLight.Core.Tests.fsproj

@@ -9,7 +9,7 @@
     <ItemGroup>
         <Compile Include="FakeHome.fs" />
         <Compile Include="InteractionListGenerators.fs" />
-        <Compile Include="ArbitraryInteractionLists.fs" />
+        <Compile Include="TimeChangedGenerators.fs" />
         <Compile Include="NightLightTests.fs" />
     </ItemGroup>
 

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
 
-    [<Property(Arbitrary = [| typeof<ArbitraryInteractionsListThatEndsDuringTheDay> |])>]
+    [<Property>]
-    let ``Lights should be white or yellow during the day`` (interactions: Interaction list) =
+    let ``All lights that are on should be white or yellow during the day`` () =
-        let fakeHome = createFakeHomeWithNightLightAndInteract interactions
+        genTimeChangedToDay
-        fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = White || color = Yellow)
+        |> 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)
 
-    [<Property(Arbitrary = [| typeof<ArbitraryInteractionsListThatEndsDuringTheNight> |])>]
+    [<Property>]
-    let ``Lights should be red during the night`` (interactions: Interaction list) =
+    let ``All lights that are on should be red during the night`` () =
-        let fakeHome = createFakeHomeWithNightLightAndInteract interactions
+        genTimeChangedToNight
-        fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = Red)
+        |> Gen.bind (fun timeChangedToNight -> genInteractionListContaining timeChangedToNight _.IsTimeChanged)
+        |> Arb.fromGen
+        |> Prop.forAll
+        <| fun interactions ->
+            let fakeHome = createFakeHomeWithNightLightAndInteract interactions
+            fakeHome.ForAllLightsThatAreOn(fun (_, _, color) -> color = Red)
+
+    [<Property>]
+    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)

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<DateTime>
+    |> Gen.filter isDay
+    |> Gen.map Interaction.TimeChanged
+
+let genTimeChangedToNight =
+    ArbMap.defaults
+    |> ArbMap.generate<DateTime>
+    |> Gen.filter (not << isDay)
+    |> Gen.map Interaction.TimeChanged

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"

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 internal generateZigbeeCommandsToFixLight state partOfDay light =
-    let color, brightness =
+    seq {
-        getDesiredMood light.Room partOfDay |> getDesiredColorAndBrightness light.Bulb
+        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) =
+            yield generateZigbeeCommand color brightness light
-    new() = NightLightStateMachine None
+    }
+
+type NightLightStateMachine private (maybeTime: DateTime option, lightToState: Map<Light, State>) =
+    new() = NightLightStateMachine(None, lights |> Seq.map (fun light -> light, On) |> Map.ofSeq)
 
     member this.OnEventReceived(event: Event) : Result<NightLightStateMachine * Message seq, OnEventReceivedError> =
         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

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"
+    commandObj.ToJsonString() |> toZigbeeCommand light
-    let payload = commandObj.ToJsonString()
-
-    { Topic = topic; Payload = payload }

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
+        match message.Topic with
-        let! messageData = jsonValue.TryGetProperty "data" |> Result.requireSome MissingDataField
+        | "zigbee2mqtt/bridge/event" ->
+            let! messageType = jsonValue.TryGetProperty "type" |> Result.requireSome MissingTypeField
+            let! messageData = jsonValue.TryGetProperty "data" |> Result.requireSome MissingDataField
 
-        return!
+            return!
-            match messageType with
+                match messageType with
-            | JsonValue.String "device_announce" ->
+                | JsonValue.String "device_announce" ->
-                match messageData.TryGetProperty "friendly_name" with
+                    match messageData.TryGetProperty "friendly_name" with
-                | Some(JsonValue.String friendlyName) -> Ok <| DeviceAnnounce(DeviceFriendlyName friendlyName)
+                    | Some(JsonValue.String friendlyName) -> Ok <| DeviceAnnounce(DeviceFriendlyName friendlyName)
-                | Some _ -> Error InvalidFriendlyNameField
+                    | Some _ -> Error InvalidFriendlyNameField
-                | None -> Error MissingFriendlyNameField
+                    | None -> Error MissingFriendlyNameField
-            | JsonValue.String _ -> Error UnknownType
+                | JsonValue.String _ -> Error UnknownType
-            | _ -> Error InvalidTypeField
+                | _ -> 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
     }

NightLight/Program.fs

@@ -104,8 +104,9 @@ let mainAsync _ =
         do! mqttClient.ConnectAsync mqttClientOptions |> Async.AwaitTask |> Async.Ignore
 
         do!
-            mqttClient.SubscribeAsync "zigbee2mqtt/bridge/event"
+            [ "zigbee2mqtt/bridge/event"; $"zigbee2mqtt/{remoteControlFriendlyName.Get}" ]
-            |> Async.AwaitTask
+            |> Seq.map (fun topic -> async { return! mqttClient.SubscribeAsync topic |> Async.AwaitTask })
+            |> Async.Sequential
             |> Async.Ignore
 
         while true do