Merge pull request #1 from svenvanheugten/introduce-state

Introduce the ability to remember state

.editorconfig

@@ -0,0 +1,10 @@
+root = true
+
+[*]
+end_of_line = lf
+
+[*.{fs,fsi,fsx}]
+indent_size = 4
+indent_style = space
+trim_trailing_whitespace=true
+

NightLight.Core/Configuration.fs

@@ -1,34 +0,0 @@
-module internal NightLight.Configuration
-
-open NightLight.Moods
-open NightLight.Lights
-
-let getDesiredColorAndBrightness bulb mood =
-    let white = ColorByCoordinates(0.3227, 0.329)
-    let yellow = ColorByTemperature 454
-    let red = ColorByCoordinates(0.6942, 0.2963)
-
-    match bulb, mood with
-    | IkeaBulb, White -> white, Brightness 254
-    | IkeaBulb, Yellow -> yellow, Brightness 210
-    | IkeaBulb, Red -> red, Brightness 254
-    | PaulmannBulb, White -> white, Brightness 35
-    | PaulmannBulb, Yellow -> yellow, Brightness 35
-    | PaulmannBulb, Red -> red, Brightness 80
-
-let lights =
-    [ { FriendlyName = "Vardagsrum - Fönsterlampa"
-        Room = LivingRoom
-        Bulb = IkeaBulb }
-      { FriendlyName = "Vardagsrum - Vägglampa"
-        Room = LivingRoom
-        Bulb = PaulmannBulb }
-      { FriendlyName = "Vardagsrum - Golvlampa"
-        Room = LivingRoom
-        Bulb = PaulmannBulb }
-      { FriendlyName = "Badrum - Taklampa"
-        Room = Bathroom
-        Bulb = IkeaBulb }
-      { FriendlyName = "Sovrum - Nattduksbordlampa"
-        Room = Bedroom
-        Bulb = IkeaBulb } ]

NightLight.Core/Core.fs

@@ -1,11 +1,10 @@
-module NightLight.Core
+module NightLight.Core.Core
 
-open NightLight.PartsOfDay
+open NightLight.Core.Models
-open NightLight.ZigbeeEvents
+open NightLight.Core.PartsOfDay
-open NightLight.ZigbeeCommands
+open NightLight.Core.ZigbeeEvents
-open NightLight.Moods
+open NightLight.Core.ZigbeeCommands
-open NightLight.Lights
+open NightLight.Core.Moods
-open NightLight.Configuration
 open FsToolkit.ErrorHandling
 
 let internal tryFindLight friendlyName =
@@ -17,11 +16,16 @@ let internal generateZigbeeCommandToFixLight partOfDay light =
 
     generateZigbeeCommand light.FriendlyName color brightness
 
-let onZigbeeEventReceived (partOfDay: PartOfDay) (decodedPayload: string) =
+let onEventReceived (state: State) (event: Event) : Result<State * Message seq, ParseEventError> =
     result {
-        let! zigbeeEvent = parseZigbeeEvent decodedPayload
+        let partOfDay = getPartOfDay state.Time
+
+        match event with
+        | ReceivedZigbeeEvent payload ->
+            let! zigbeeEvent = parseZigbeeEvent payload |> Result.mapError ParseZigbeeEventError
 
             return
+                state,
                 match zigbeeEvent with
                 | DeviceAnnounce friendlyName ->
                     let maybeLight = tryFindLight friendlyName
@@ -29,7 +33,14 @@ let onZigbeeEventReceived (partOfDay: PartOfDay) (decodedPayload: string) =
                     match maybeLight with
                     | Some light -> generateZigbeeCommandToFixLight partOfDay light |> Seq.singleton
                     | None -> Seq.empty
-    }
+        | TimeChanged time ->
+            let newState = { Time = time }
+            let newPartOfDay = getPartOfDay time
 
-let onPartOfDayChanged (partOfDay: PartOfDay) =
+            return
-    lights |> Seq.map (generateZigbeeCommandToFixLight partOfDay)
+                newState,
+                if partOfDay <> newPartOfDay then
+                    lights |> Seq.map (generateZigbeeCommandToFixLight newPartOfDay)
+                else
+                    Seq.empty
+    }

NightLight.Core/Lights.fs

@@ -1,18 +0,0 @@
-module internal NightLight.Lights
-
-open NightLight.Moods
-
-type Bulb =
-    | IkeaBulb
-    | PaulmannBulb
-
-type Color =
-    | ColorByCoordinates of float * float
-    | ColorByTemperature of int
-
-type Brightness = Brightness of int
-
-type Light =
-    { FriendlyName: string
-      Room: Room
-      Bulb: Bulb }

NightLight.Core/Models.fs

@@ -0,0 +1,53 @@
+module NightLight.Core.Models
+
+open System
+
+type State = { Time: DateTime }
+
+type Message = { Topic: string; Payload: string }
+
+type Event =
+    | ReceivedZigbeeEvent of Message
+    | TimeChanged of DateTime
+
+type ParseZigbeeEventError =
+    | InvalidJson
+    | MissingTypeField
+    | MissingDataField
+    | MissingFriendlyNameField
+    | InvalidTypeField
+    | InvalidFriendlyNameField
+    | UnknownType
+
+type ParseEventError = ParseZigbeeEventError of ParseZigbeeEventError
+
+type Room =
+    | Bathroom
+    | LivingRoom
+    | Bedroom
+
+type Bulb =
+    | IkeaBulb
+    | PaulmannBulb
+
+type Light =
+    { FriendlyName: string
+      Room: Room
+      Bulb: Bulb }
+
+let lights =
+    [ { FriendlyName = "Vardagsrum - Fönsterlampa"
+        Room = LivingRoom
+        Bulb = IkeaBulb }
+      { FriendlyName = "Vardagsrum - Vägglampa"
+        Room = LivingRoom
+        Bulb = PaulmannBulb }
+      { FriendlyName = "Vardagsrum - Golvlampa"
+        Room = LivingRoom
+        Bulb = PaulmannBulb }
+      { FriendlyName = "Badrum - Taklampa"
+        Room = Bathroom
+        Bulb = IkeaBulb }
+      { FriendlyName = "Sovrum - Nattduksbordlampa"
+        Room = Bedroom
+        Bulb = IkeaBulb } ]

NightLight.Core/Moods.fs

@@ -1,20 +1,35 @@
-module internal NightLight.Moods
+module internal NightLight.Core.Moods
 
-open NightLight.PartsOfDay
+open NightLight.Core.PartsOfDay
+open NightLight.Core.Models
 
 type Mood =
     | White
     | Yellow
     | Red
 
-type Room =
-    | Bathroom
-    | LivingRoom
-    | Bedroom
-
 let getDesiredMood room partOfDay =
     match room, partOfDay with
     | Bathroom, Day -> White
     | LivingRoom, Day -> Yellow
     | Bedroom, Day -> Yellow
     | _, Night -> Red
+
+type Color =
+    | ColorByCoordinates of float * float
+    | ColorByTemperature of int
+
+type Brightness = Brightness of int
+
+let getDesiredColorAndBrightness bulb mood =
+    let white = ColorByCoordinates(0.3227, 0.329)
+    let yellow = ColorByTemperature 454
+    let red = ColorByCoordinates(0.6942, 0.2963)
+
+    match bulb, mood with
+    | IkeaBulb, White -> white, Brightness 254
+    | IkeaBulb, Yellow -> yellow, Brightness 210
+    | IkeaBulb, Red -> red, Brightness 254
+    | PaulmannBulb, White -> white, Brightness 35
+    | PaulmannBulb, Yellow -> yellow, Brightness 35
+    | PaulmannBulb, Red -> red, Brightness 80

NightLight.Core/NightLight.Core.fsproj

@@ -6,12 +6,11 @@
     </PropertyGroup>
 
     <ItemGroup>
+        <Compile Include="Models.fs" />
         <Compile Include="PartsOfDay.fs" />
         <Compile Include="Moods.fs" />
-        <Compile Include="Lights.fs" />
         <Compile Include="ZigbeeEvents.fs" />
         <Compile Include="ZigbeeCommands.fs" />
-        <Compile Include="Configuration.fs" />
         <Compile Include="Core.fs" />
     </ItemGroup>
 

NightLight.Core/PartsOfDay.fs

@@ -1,4 +1,4 @@
-module NightLight.PartsOfDay
+module internal NightLight.Core.PartsOfDay
 
 open System
 
@@ -8,5 +8,9 @@ type PartOfDay =
 
 let getPartOfDay (dateTime: DateTime) =
     match dateTime with
-    | _ when dateTime.TimeOfDay >= TimeSpan.FromHours 4.75 && dateTime.TimeOfDay < TimeSpan.FromHours 20.5 -> Day
+    | _ when
+        dateTime.TimeOfDay >= TimeSpan.FromHours 5.5
+        && dateTime.TimeOfDay < TimeSpan.FromHours 20.5
+        ->
+        Day
     | _ -> Night

NightLight.Core/ZigbeeCommands.fs

@@ -1,11 +1,10 @@
-module NightLight.ZigbeeCommands
+module internal NightLight.Core.ZigbeeCommands
 
 open System.Text.Json.Nodes
-open NightLight.Lights
+open NightLight.Core.Models
+open NightLight.Core.Moods
 
-type ZigbeeCommand = ZigbeeCommand of Topic: string * Payload: string
+let generateZigbeeCommand friendlyName targetColor targetBrightness =
-
-let internal generateZigbeeCommand friendlyName targetColor targetBrightness =
     let commandObj = JsonObject()
 
     match targetColor with
@@ -23,4 +22,4 @@ let internal generateZigbeeCommand friendlyName targetColor targetBrightness =
     let topic = $"zigbee2mqtt/{friendlyName}/set"
     let payload = commandObj.ToJsonString()
 
-    ZigbeeCommand(topic, payload)
+    { Topic = topic; Payload = payload }

NightLight.Core/ZigbeeEvents.fs

@@ -1,22 +1,14 @@
-module NightLight.ZigbeeEvents
+module internal NightLight.Core.ZigbeeEvents
 
+open NightLight.Core.Models
 open FsToolkit.ErrorHandling
 open FSharp.Data
 
 type ZigbeeEvent = DeviceAnnounce of FriendlyName: string
 
-type ParseZigbeeEventError =
+let parseZigbeeEvent (message: Message) =
-    | InvalidJson
-    | MissingTypeField
-    | MissingDataField
-    | MissingFriendlyNameField
-    | InvalidTypeField
-    | InvalidFriendlyNameField
-    | UnknownType
-
-let internal parseZigbeeEvent str =
     result {
-        let! jsonValue = JsonValue.TryParse str |> Result.requireSome InvalidJson
+        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

NightLight/Program.fs

@@ -1,55 +1,58 @@
 open System
 open System.Text
+open System.Threading
 open System.Threading.Tasks
 open Microsoft.Extensions.Logging
 open MQTTnet
 open MQTTnet.Protocol
-open NightLight.PartsOfDay
+open NightLight.Core.Models
-open NightLight.ZigbeeEvents
+open NightLight.Core.Core
-open NightLight.ZigbeeCommands
-open NightLight.Core
 
 let private generateMqttMessage zigbeeCommand =
-    match zigbeeCommand with
-    | ZigbeeCommand(topic, payload) ->
     MqttApplicationMessageBuilder()
-            .WithTopic(topic)
+        .WithTopic(zigbeeCommand.Topic)
-            .WithPayload(payload)
+        .WithPayload(zigbeeCommand.Payload)
         .WithQualityOfServiceLevel(MqttQualityOfServiceLevel.AtLeastOnce)
         .Build()
 
-let private publishZigbeeCommands (mqttClient: IMqttClient) (logger: ILogger) (commands: ZigbeeCommand seq) =
+let private publishZigbeeCommands (mqttClient: IMqttClient) (logger: ILogger) (commands: Message seq) =
     async {
         commands
         |> Seq.iter (fun command ->
-            match command with
+            logger.LogInformation("Publishing message {Payload} to topic {Topic}...", command.Payload, command.Topic))
-            | ZigbeeCommand(topic, payload) ->
-                logger.LogInformation("Publishing message {Payload} to topic {Topic}...", payload, topic))
 
         return!
             commands
             |> Seq.map generateMqttMessage
-            |> Seq.map mqttClient.PublishAsync
+            |> Seq.map (fun message -> async { return! mqttClient.PublishAsync message |> Async.AwaitTask })
-            |> Seq.map Async.AwaitTask
             |> Async.Sequential
             |> Async.Ignore
     }
 
-let private onMqttMessageReceived (mqttClient: IMqttClient) (logger: ILogger) (message: MqttApplicationMessage) =
+let private handleEvent (mqttClient: IMqttClient) (logger: ILogger) (state: State) (event: Event) =
+    match event with
+    | ReceivedZigbeeEvent payload -> logger.LogInformation("Received message with payload {Payload}", payload)
+    | _ -> ()
+
+    let result = event |> onEventReceived state
+
+    match result with
+    | Ok(newState, commands) ->
+        async {
+            do! publishZigbeeCommands mqttClient logger commands
+            return newState
+        }
+    | Error(ParseZigbeeEventError UnknownType) -> async.Return state
+    | Error e ->
+        logger.LogError("Error {Error} while {Event}", e, event)
+        async.Return state
+
+let private decodeMqttApplicationMessage (message: MqttApplicationMessage) =
     let payload = message.Payload
     let decodedPayload = Encoding.UTF8.GetString(&payload)
 
-    logger.LogInformation("Received message with payload {Payload}", decodedPayload)
+    { Topic = message.Topic
-
+      Payload = decodedPayload }
-    let commandsResult =
-        decodedPayload |> onZigbeeEventReceived (getPartOfDay DateTime.Now)
-
-    match commandsResult with
-    | Ok commands -> publishZigbeeCommands mqttClient logger commands
-    | Error UnknownType -> async.Return()
-    | Error e ->
-        logger.LogError("Error {Error} while processing {Payload}", e, payload)
-        async.Return()
 
 [<EntryPoint>]
 let mainAsync _ =
@@ -73,8 +76,21 @@ let mainAsync _ =
 
         let mqttClientOptions = MqttClientOptionsBuilder().WithTcpServer(server).Build()
 
+        let stateLock = new SemaphoreSlim(1, 1)
+        let mutable state = { Time = DateTime.Now }
+
         mqttClient.add_ApplicationMessageReceivedAsync (fun e ->
-            onMqttMessageReceived mqttClient logger e.ApplicationMessage
+            async {
+                let event = ReceivedZigbeeEvent <| decodeMqttApplicationMessage e.ApplicationMessage
+
+                do! stateLock.WaitAsync() |> Async.AwaitTask
+
+                try
+                    let! newState = event |> handleEvent mqttClient logger state
+                    state <- newState
+                finally
+                    stateLock.Release() |> ignore
+            }
             |> Async.StartAsTask
             :> Task)
 
@@ -85,14 +101,14 @@ let mainAsync _ =
             |> Async.AwaitTask
             |> Async.Ignore
 
-        let mutable previousPartOfDay: PartOfDay option = None
-
         while true do
-            let currentPartOfDay = getPartOfDay DateTime.Now
+            do! stateLock.WaitAsync() |> Async.AwaitTask
 
-            if previousPartOfDay <> Some currentPartOfDay then
+            try
-                do! onPartOfDayChanged currentPartOfDay |> publishZigbeeCommands mqttClient logger
+                let! newState = TimeChanged DateTime.Now |> handleEvent mqttClient logger state
-                previousPartOfDay <- Some currentPartOfDay
+                state <- newState
+            finally
+                stateLock.Release() |> ignore
 
             do! Async.Sleep 10_000
 

README.md

@@ -3,7 +3,7 @@
 This is an F# program that turns all the lights in our apartment
 
 * _red_ at 8.30pm in the evening, and
-* _white_/_yellow_ (depending on the room) at 4.45am in the morning.
+* _white_/_yellow_ (depending on the room) at 5.30am in the morning.
 
 `NightLight.Core` is the functional core, and `NightLight` is the imperative shell.