svenvanheugten/night-light
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
Add remote control
This commit is contained in:
Sven van Heugten 2026-01-05 23:24:47 +01:00 • committed by GitHub
commit bb7e6d18ce
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
11 changed files with 223 additions and 98 deletions
Download patch file Download diff file Expand all files Collapse all files

25
NightLight.Core.Tests/ArbitraryInteractionLists.fs
View file

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

48
NightLight.Core.Tests/FakeHome.fs
View file

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

35
NightLight.Core.Tests/InteractionListGenerators.fs
View file

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

2
NightLight.Core.Tests/NightLight.Core.Tests.fsproj
View file

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

35
NightLight.Core.Tests/NightLightTests.fs
View file

@ -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> |])>]
let ``Lights should be white or yellow during the day`` (interactions: Interaction list) =
[<Property>]
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)
[<Property(Arbitrary = [| typeof<ArbitraryInteractionsListThatEndsDuringTheNight> |])>]
let ``Lights should be red during the night`` (interactions: Interaction list) =
[<Property>]
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)
[<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)

20
NightLight.Core.Tests/TimeChangedGenerators.fs Normal file
View file

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

23
NightLight.Core/Models.fs
View file

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

38
NightLight.Core/NightLightStateMachine.fs
View file

@ -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 =
seq {
yield generateStateCommand state light
if state = On then
let color, brightness =
getDesiredMood light.Room partOfDay |> getDesiredColorAndBrightness light.Bulb
generateZigbeeCommand light.FriendlyName color brightness
yield generateZigbeeCommand color brightness light
}
type NightLightStateMachine private (maybeTime: DateTime option) =
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

28
NightLight.Core/ZigbeeCommands.fs
View file

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

18
NightLight.Core/ZigbeeEvents.fs
View file

@ -4,12 +4,20 @@ 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
match message.Topic with
| "zigbee2mqtt/bridge/event" ->
let! messageType = jsonValue.TryGetProperty "type" |> Result.requireSome MissingTypeField
let! messageData = jsonValue.TryGetProperty "data" |> Result.requireSome MissingDataField
@ -22,4 +30,12 @@ let parseZigbeeEvent (message: Message) =
| 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
}

5
NightLight/Program.fs
View file

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