diff --git a/src/Q/Home.hs b/src/Q/Home.hs index bbdae8cde09cc5bb3dfbc6f112fb986cad245126..ef76ba2a4222d012c98f6cb1fccbf14c85536000 100644 --- a/src/Q/Home.hs +++ b/src/Q/Home.hs @@ -10,6 +10,7 @@ import Data.ByteString.Lazy qualified as BSL import Data.HashMap.Strict qualified as HM import Data.Text import Q.Mqtt +import Q.Mqtt.Zigbee2Mqtt import Quasar import Quasar.Prelude import Network.MQTT.Client diff --git a/src/Q/Mqtt.hs b/src/Q/Mqtt.hs index 9f65c668152262f4abee7e77babe416ea295d51e..d317edb87cb73fd573b5baccd52549f2a2ff4841 100644 --- a/src/Q/Mqtt.hs +++ b/src/Q/Mqtt.hs @@ -1,14 +1,8 @@ module Q.Mqtt ( - Mqtt, + Mqtt(Mqtt, mqttClient), connectMqtt, subscribeCallback, subscribeJson, - - IkeaDimmerCallbacks(..), - ikeaDimmerCallbacks, - subscribeIkeaDimmer, - - setHueState, ) where import Control.Concurrent.STM @@ -26,7 +20,7 @@ import Network.MQTT.Topic import Network.URI data Mqtt = Mqtt { - client :: MQTTClient, + mqttClient :: MQTTClient, callbacks :: TVar [Callback], awaitable :: Awaitable () } @@ -41,24 +35,22 @@ data Callback = Callback { type JsonCallback = forall a. FromJSON a => Mqtt -> Topic -> a -> [Property] -> IO () -zigbee2mqtt :: Text -> Topic -zigbee2mqtt name = "zigbee2mqtt/" <> name connectMqtt :: String -> Topic -> IO Mqtt connectMqtt mqttUri statusTopic = mfix \handle -> do uri <- case parseURI mqttUri of Just uri -> pure uri Nothing -> fail "Invalid URI" - client <- connectURI (config handle statusTopic) uri + mqttClient <- connectURI (config handle statusTopic) uri callbacks <- newTVarIO [] - publish client statusTopic "online" True + publish mqttClient statusTopic "online" True - awaitable <- toAwaitable <$> unmanagedAsync (waitForClient client) + awaitable <- toAwaitable <$> unmanagedAsync (waitForClient mqttClient) pure Mqtt { - client, + mqttClient, callbacks, awaitable } @@ -92,9 +84,9 @@ subscribeSingle client switchTopic = do subscribeCallback :: Mqtt -> Filter -> CallbackFn -> IO () -subscribeCallback Mqtt{client, callbacks} topicFilter fn = do +subscribeCallback Mqtt{mqttClient, callbacks} topicFilter fn = do atomically $ modifyTVar callbacks (newCallback : ) - subscribeSingle client topicFilter + subscribeSingle mqttClient topicFilter where newCallback = Callback { topicFilter, @@ -110,45 +102,3 @@ subscribeJson handle topicFilter fn = do case eitherDecode msg of Left err -> traceIO $ mconcat ["Failed to decode json message on topic ", show topic, ": ", err] Right json -> fn handle' topic json props - - -data IkeaDimmerCallbacks = IkeaDimmerCallbacks { - on :: IO (), - off :: IO (), - onLongPress :: IO (), - offLongPress :: IO (), - endLongPress :: IO () -} - -ikeaDimmerCallbacks :: IkeaDimmerCallbacks -ikeaDimmerCallbacks = - IkeaDimmerCallbacks { - on = pure (), - off = pure (), - onLongPress = pure (), - offLongPress = pure (), - endLongPress = pure () - } - -subscribeIkeaDimmer :: Mqtt -> Text -> IkeaDimmerCallbacks -> IO () -subscribeIkeaDimmer handle switchName callbacks = do - subscribeJson handle (zigbee2mqtt switchName) cb - where - cb :: Mqtt -> Topic -> Object -> [Property] -> IO () - cb _ _ event _ = - case HM.lookup "action" event of - Just (String "on") -> on callbacks - Just (String "off") -> off callbacks - Just (String "brightness_move_up") -> onLongPress callbacks - Just (String "brightness_move_down") -> offLongPress callbacks - Just (String "brightness_stop") -> endLongPress callbacks - Just (String action) -> traceIO $ "Unknown switch .action: " <> show action - Just action -> traceIO $ "Switch event .action should be a string but is " <> show action - Nothing -> traceIO "Switch event has no .action key" - -setHueState :: Mqtt -> Topic -> Bool -> IO () -setHueState Mqtt{client} hueTopic state = publish client (hueTopic <> "/set") (stateMessage state) False - where - stateMessage :: Bool -> BSL.ByteString - stateMessage False = "{\"state\":\"off\"}" - stateMessage True = "{\"state\":\"on\"}" diff --git a/src/Q/Mqtt/Zigbee2Mqtt.hs b/src/Q/Mqtt/Zigbee2Mqtt.hs new file mode 100644 index 0000000000000000000000000000000000000000..ac0adf011251a884b6e033c158a14b6f1cfd99b6 --- /dev/null +++ b/src/Q/Mqtt/Zigbee2Mqtt.hs @@ -0,0 +1,67 @@ +module Q.Mqtt.Zigbee2Mqtt ( + IkeaDimmerCallbacks(..), + ikeaDimmerCallbacks, + subscribeIkeaDimmer, + + setHueState, +) where + +import Control.Concurrent.STM +import Data.Aeson +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.HashMap.Strict qualified as HM +import Data.Text +import Q.Mqtt +import Quasar +import Quasar.Async.Unmanaged +import Quasar.Prelude +import Network.MQTT.Client as MQTT +import Network.MQTT.Topic +import Network.URI + +zigbee2mqtt :: Text -> Topic +zigbee2mqtt name = "zigbee2mqtt/" <> name + + +data IkeaDimmerCallbacks = IkeaDimmerCallbacks { + on :: IO (), + off :: IO (), + onLongPress :: IO (), + offLongPress :: IO (), + endLongPress :: IO () +} + +ikeaDimmerCallbacks :: IkeaDimmerCallbacks +ikeaDimmerCallbacks = + IkeaDimmerCallbacks { + on = pure (), + off = pure (), + onLongPress = pure (), + offLongPress = pure (), + endLongPress = pure () + } + +subscribeIkeaDimmer :: Mqtt -> Text -> IkeaDimmerCallbacks -> IO () +subscribeIkeaDimmer handle switchName callbacks = do + subscribeJson handle (zigbee2mqtt switchName) cb + where + cb :: Mqtt -> Topic -> Object -> [Property] -> IO () + cb _ _ event _ = + case HM.lookup "action" event of + Just (String "on") -> on callbacks + Just (String "off") -> off callbacks + Just (String "brightness_move_up") -> onLongPress callbacks + Just (String "brightness_move_down") -> offLongPress callbacks + Just (String "brightness_stop") -> endLongPress callbacks + Just (String action) -> traceIO $ "Unknown switch .action: " <> show action + Just action -> traceIO $ "Switch event .action should be a string but is " <> show action + Nothing -> traceIO "Switch event has no .action key" + +setHueState :: Mqtt -> Topic -> Bool -> IO () +setHueState Mqtt{mqttClient} hueTopic state = publish mqttClient (hueTopic <> "/set") (stateMessage state) False + where + stateMessage :: Bool -> BSL.ByteString + stateMessage False = "{\"state\":\"off\"}" + stateMessage True = "{\"state\":\"on\"}"