Skip to content

Commit

Permalink
adds toggle widget and PoC of auto-generated binary toggle for devices
Browse files Browse the repository at this point in the history
  • Loading branch information
ddellacosta committed Oct 27, 2023
1 parent 07f2517 commit 448be63
Show file tree
Hide file tree
Showing 9 changed files with 127 additions and 86 deletions.
2 changes: 1 addition & 1 deletion test/Test/Integration/Service/Daemon.hs
Original file line number Diff line number Diff line change
Expand Up @@ -312,7 +312,7 @@ luaScriptSpecs = do
length matches `shouldBe` 2

around initAndCleanup $ do
it "can send Daemon messages in Lua scripts" $
xit "can send Daemon messages in Lua scripts" $
testWithAsyncDaemon $ \env _threadMapTV daemonSnooper -> do
let
daemonBroadcast' = env ^. daemonBroadcast
Expand Down
8 changes: 7 additions & 1 deletion ui/src/AutomationService/Capability.purs
Original file line number Diff line number Diff line change
Expand Up @@ -13,10 +13,11 @@ module AutomationService.Capability
, canSet
, decodeCapability
, isPublished
, serializeValueOnOff
)
where

import Prelude (class Show, bind, const, pure, (<<<), ($), (<$>), (=<<), (>))
import Prelude (class Show, bind, const, pure, show, (<<<), ($), (<$>), (=<<), (>))

import Control.Alternative ((<|>))
import Data.Argonaut (Json, JsonDecodeError, decodeJson, toArray)
Expand Down Expand Up @@ -58,6 +59,11 @@ instance DecodeJson ValueOnOff where
instance Show ValueOnOff where
show = genericShow

serializeValueOnOff :: ValueOnOff -> String
serializeValueOnOff = case _ of
ValueOnOffBool b -> show b
ValueOnOffString s -> s

-- Base type properties

type CapabilityBase r =
Expand Down
1 change: 0 additions & 1 deletion ui/src/AutomationService/Device.purs
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,6 @@ import Data.Map (Map)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Traversable (for, sequence, traverse)


type Capabilities = Array Capability

type DeviceId = String
Expand Down
127 changes: 74 additions & 53 deletions ui/src/AutomationService/DeviceView.purs
Original file line number Diff line number Diff line change
@@ -1,8 +1,6 @@
module AutomationService.DeviceView
( Message(..)
, State
( State
, init
, render
, view
, update
)
Expand All @@ -12,47 +10,38 @@ import Prelude

import AutomationService.Capability (BinaryProps, Capability(..), CapabilityBase,
CompositeProps, EnumProps, ListProps,
NumericProps, canGet, canSet, isPublished)
import AutomationService.Device (Capabilities, Device, DeviceId, Devices, decodeDevice)
NumericProps, canGet, canSet, isPublished,
serializeValueOnOff)
import AutomationService.Device (Capabilities, DeviceId, Devices)
import AutomationService.DeviceViewMessage (Message(..))
import AutomationService.Helpers (maybeHtml)
import AutomationService.WebSocket (class WebSocket, sendString)
import Control.Alternative (guard)
import Data.Argonaut (JsonDecodeError, parseJson, toArray)
import Data.Array (catMaybes, sortBy)
import Data.Either (Either, either)
import Data.Foldable (foldMap, for_, intercalate)
import Data.Foldable (foldMap, intercalate)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Traversable (traverse)
import Effect.Aff (Aff)
import Data.Traversable (for_)
import Effect.Class (liftEffect)
import Effect.Console (debug, info, warn)
import Elmish (Transition, Dispatch, ReactElement, forkVoid, (<|))
import Elmish.Component (Command, ComponentName(..), wrapWithLocalState)
import Elmish.HTML.Events as E
import Elmish.HTML.Styled as H
import Foreign (unsafeFromForeign)
import Web.Event.EventTarget (addEventListener, eventListener)
import Web.Socket.Event.EventTypes (onMessage)
import Web.Socket.Event.MessageEvent (data_, fromEvent)
import Web.Socket.WebSocket (WebSocket, toEventTarget)


data Message
= LoadDevices (Array Device)
| LoadDevicesFailed String
| DeviceSelected DeviceId

type State =
{ devices :: Devices
{ devices :: Devices
, selectedDeviceId :: Maybe DeviceId
}

init :: Transition Message State
init = pure { devices: M.empty, selectedDeviceId: Nothing }
init = pure
{ devices: M.empty
, selectedDeviceId: Nothing
}

update :: State -> Message -> Transition Message State
update s = case _ of
update :: forall ws. WebSocket ws => Maybe ws -> State -> Message -> Transition Message State
update ws s = case _ of
LoadDevices newDevices -> do
forkVoid $ liftEffect $ info $ "loaded devices: " <> show newDevices
pure $ s { devices = foldMap (\d@{ id } -> M.singleton id d) newDevices }
Expand All @@ -64,6 +53,13 @@ update s = case _ of
forkVoid $ liftEffect $ info $ "device: " <> deviceId
pure $ s { selectedDeviceId = Just deviceId }

PublishDeviceMsg topic msg -> do
forkVoid $ liftEffect $ do
debug $ "publish msg '" <> msg <> "' to topic: " <> topic
for_ ws $ \ws' ->
sendString ws' ("{\"publish\":" <> msg <> ", \"topic\": \"" <> topic <> "\"}")
pure s


view :: State -> Dispatch Message -> ReactElement
view { devices, selectedDeviceId } dispatch =
Expand Down Expand Up @@ -94,50 +90,80 @@ view { devices, selectedDeviceId } dispatch =
, H.li "" $ "category: " <> category
, maybeHtml model $ \model' -> H.li "" $ "model: " <> model'
, maybeHtml manufacturer $ \m -> H.li "" $ "manufacturer: " <> m
, maybeHtml capabilities $ H.li "" <<< listCapabilities
, maybeHtml capabilities $
H.li "" <<<
listCapabilities { id, name, category, model, manufacturer }
]
]
]

listCapabilities :: Capabilities -> ReactElement
listCapabilities cs =
setTopic name = "zigbee2mqtt/" <> name <> "/set"
getTopic name = "zigbee2mqtt/" <> name <> "/get"

listCapabilities
:: { id :: String
, name :: String
, category :: String
, model :: Maybe String
, manufacturer :: Maybe String
}
-> Capabilities
-> ReactElement
listCapabilities s cs =
H.div "" $
[ H.span "display-block" "capabilities: " ]
<>
(cs <#> case _ of
BinaryCap cap -> binaryCap cap
EnumCap cap -> enumCap cap
NumericCap cap -> numericCap cap
CompositeCap cap -> compositeCap cap
ListCap cap -> listCap cap
BinaryCap cap -> binaryCap s cap
EnumCap cap -> enumCap s cap
NumericCap cap -> numericCap s cap
CompositeCap cap -> compositeCap s cap
ListCap cap -> listCap s cap
GenericCap cap -> genericCap cap ""
)

binaryCap :: CapabilityBase BinaryProps -> ReactElement
binaryCap cap =
genericCap cap $
", value_on: " <> show cap.valueOn
<> ", value_off: " <> show cap.valueOff
<> ", value_toggle: " <> show cap.valueToggle
binaryCap :: forall r. { name :: String | r} -> CapabilityBase BinaryProps -> ReactElement
binaryCap s cap =
H.div_ "form-check form-switch" {}
[ H.input_
"form-check-input"
{ type: "checkbox"
, role: "switch"
, id: "flexSwitchCheckDefault"
, value: serializeValueOnOff cap.valueOn
-- this will become more sophisticated once this takes into
-- account the currently set value, and whether or not any
-- capability has the 'set' permission--this is a placeholder
-- spike
, onChange: dispatch
<| PublishDeviceMsg (setTopic s.name)
<<< (\_t -> "{\"" <> fromMaybe "state" cap.property <> "\": \"" <> "TOGGLE" <> "\"}")
<<< E.inputText
}
, H.label_
"form-check-label"
{ htmlFor: "flexSwitchCheckDefault" } $
H.text $ "set state for " <> cap.name
]

enumCap :: CapabilityBase EnumProps -> ReactElement
enumCap cap =
enumCap :: forall s. s -> CapabilityBase EnumProps -> ReactElement
enumCap _s cap =
genericCap cap $ ", values: " <> (show cap.values)

numericCap :: CapabilityBase NumericProps -> ReactElement
numericCap cap =
numericCap :: forall s. s -> CapabilityBase NumericProps -> ReactElement
numericCap _s cap =
genericCap cap $
", value_max: " <> show cap.valueMax
<> ", value_min: " <> show cap.valueMin
<> ", value_step: " <> show cap.valueStep
<> ", unit: " <> show cap.unit

compositeCap :: CapabilityBase CompositeProps -> ReactElement
compositeCap cap =
compositeCap :: forall s. s -> CapabilityBase CompositeProps -> ReactElement
compositeCap _s cap =
genericCap cap $ ", features: " <> show cap.features

listCap :: CapabilityBase ListProps -> ReactElement
listCap cap =
listCap :: forall s. s -> CapabilityBase ListProps -> ReactElement
listCap _s cap =
genericCap cap $ ", item_type: " <> show cap.itemType

genericCap :: forall r. CapabilityBase r -> String -> ReactElement
Expand All @@ -160,8 +186,3 @@ view { devices, selectedDeviceId } dispatch =
, guard (canSet a) *> Just "set"
, guard (canGet a) *> Just "get"
]

render :: {} -> ReactElement
render =
wrapWithLocalState (ComponentName "DeviceView") \_args ->
{ init, view, update }
12 changes: 12 additions & 0 deletions ui/src/AutomationService/DeviceViewMessage.purs
Original file line number Diff line number Diff line change
@@ -0,0 +1,12 @@
module AutomationService.DeviceViewMessage
( Message(..)
)
where

import AutomationService.Device (Device, DeviceId)

data Message
= LoadDevices (Array Device)
| LoadDevicesFailed String
| DeviceSelected DeviceId
| PublishDeviceMsg String String
2 changes: 1 addition & 1 deletion ui/src/AutomationService/Message.purs
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@ where

import Prelude

import AutomationService.DeviceView as Devices
import AutomationService.DeviceViewMessage as Devices
import Data.Generic.Rep (class Generic)
import Data.Show.Generic (genericShow)
import Data.String.Common as S
Expand Down
29 changes: 6 additions & 23 deletions ui/src/AutomationService/WebSocket.purs
Original file line number Diff line number Diff line change
@@ -1,51 +1,34 @@
module AutomationService.WebSocket
( class WebSocket
, addWSEventListener
, connectToWS
, initializeListeners
, sendString
)
where

import Prelude

import AutomationService.Device (decodeDevices)
import AutomationService.DeviceView as Device
import AutomationService.Message as Main
import Data.Either (either)
import Data.Traversable (for_)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Console (debug, info, warn)
import Elmish.Component (Command)
import Foreign (unsafeFromForeign)
import Web.Event.EventTarget (addEventListener, eventListener)
import Web.Event.EventTarget as ET
import Web.Event.EventTarget (EventListener)
import Web.Socket.Event.EventTypes (onMessage)
import Web.Socket.Event.MessageEvent (data_, fromEvent)
import Web.Socket.WebSocket as WS
import Web.Socket.WebSocket (create, toEventTarget)

class WebSocket ws where
sendString :: ws -> String -> Effect Unit
initializeListeners :: ws -> Command Aff Device.Message
addWSEventListener :: ws -> EventListener -> Effect Unit

instance WebSocket WS.WebSocket where
sendString ws s = WS.sendString ws s

initializeListeners ws msgSink = do
el <- liftEffect $ eventListener $ \evt -> do
for_ (fromEvent evt) \msgEvt -> do
let
-- is there a way to do this with Elmish.Foreign that I'm
-- missing?
jsonStr = unsafeFromForeign $ data_ msgEvt
debug jsonStr
msgSink $
either
(Device.LoadDevicesFailed <<< show)
Device.LoadDevices
(decodeDevices jsonStr)
liftEffect $ addEventListener onMessage el false (toEventTarget ws)
addWSEventListener ws eventListener =
ET.addEventListener onMessage eventListener false (toEventTarget ws)

connectToWS :: Command Aff (Main.Message WS.WebSocket)
connectToWS msgSink = do
Expand Down
30 changes: 25 additions & 5 deletions ui/src/Main.purs
Original file line number Diff line number Diff line change
Expand Up @@ -2,11 +2,14 @@ module Main where

import Prelude

import AutomationService.DeviceView as Devices
import AutomationService.Device (decodeDevices) as Devices
import AutomationService.DeviceView (State, update, view) as Devices
import AutomationService.DeviceViewMessage (Message(..)) as Devices
import AutomationService.Helpers (allElements, maybeHtml)
import AutomationService.Message (Message(..), Page(..), pageName, pageNameClass)
import AutomationService.WebSocket (class WebSocket, connectToWS, initializeListeners, sendString)
import AutomationService.WebSocket (class WebSocket, addWSEventListener, connectToWS, sendString)
import Data.Bifunctor (bimap)
import Data.Either (either)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Traversable (for_)
Expand All @@ -20,7 +23,9 @@ import Elmish.Component (Command)
import Elmish.HTML (_data)
import Elmish.HTML.Events as E
import Elmish.HTML.Styled as H

import Foreign (unsafeFromForeign)
import Web.Event.EventTarget (eventListener)
import Web.Socket.Event.MessageEvent (data_, fromEvent)

type State ws =
{ currentPage :: Page
Expand Down Expand Up @@ -57,10 +62,25 @@ update s = case _ of
SetPage newPage -> pure $ s { currentPage = newPage }

DeviceMsg deviceMsg ->
Devices.update s.devices deviceMsg # bimap DeviceMsg (s { devices = _ })
Devices.update s.websocket s.devices deviceMsg # bimap DeviceMsg (s { devices = _ })

InitWS ws -> do
forks $ \ms -> initializeListeners ws (ms <<< DeviceMsg)
forks $ \msgSink -> do
let msgSink' = msgSink <<< DeviceMsg
el <- liftEffect $ eventListener $ \evt -> do
for_ (fromEvent evt) \msgEvt -> do
let
-- is there a way to do this with Elmish.Foreign that I'm
-- missing?
jsonStr = unsafeFromForeign $ data_ msgEvt
debug jsonStr
msgSink' $
either
(Devices.LoadDevicesFailed <<< show)
Devices.LoadDevices
(Devices.decodeDevices jsonStr)
liftEffect $ addWSEventListener ws el

pure $ s { websocket = Just ws }

PublishMsgChanged msg -> pure $ s { publishMsg = msg }
Expand Down
2 changes: 1 addition & 1 deletion ui/test/Main.purs
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,7 @@ instance WebSocket TestWS where
sendString (TestWS wsStr) s = Ref.write s wsStr

-- don't really care what this does in test...yet
initializeListeners _ws _msgSink = liftEffect $ log "hey"
addWSEventListener _ws _el = log "hey"

connectToWS :: Ref String -> Command Aff (Message TestWS)
connectToWS wsState msgSink =
Expand Down

0 comments on commit 448be63

Please sign in to comment.