packages feed

lifx-lan 0.3.0 → 0.4.0

raw patch · 3 files changed

+304/−143 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

- Lifx.Lan: Duration :: Word32 -> Duration
- Lifx.Lan: LifxT :: StateT Word8 (ReaderT (Socket, Word32, Int) (ExceptT LifxError m)) a -> LifxT m a
- Lifx.Lan: [$sel:unLifxT:LifxT] :: LifxT m a -> StateT Word8 (ReaderT (Socket, Word32, Int) (ExceptT LifxError m)) a
- Lifx.Lan: instance GHC.Classes.Eq (Lifx.Lan.Message a)
- Lifx.Lan: instance GHC.Classes.Eq Lifx.Lan.Duration
- Lifx.Lan: instance GHC.Classes.Ord (Lifx.Lan.Message a)
- Lifx.Lan: instance GHC.Classes.Ord Lifx.Lan.Duration
- Lifx.Lan: instance GHC.Generics.Generic Lifx.Lan.Duration
- Lifx.Lan: instance GHC.Show.Show (Lifx.Lan.Message a)
- Lifx.Lan: instance GHC.Show.Show Lifx.Lan.Duration
- Lifx.Lan: instance Lifx.Lan.Response ()
- Lifx.Lan: newtype Duration
- Lifx.Lan: newtype LifxT m a
+ Lifx.Lan: ($sel:unLifxT:LifxT) :: LifxT m a -> StateT Word8 (ReaderT (Socket, Word32, Int) (ExceptT LifxError m)) a
+ Lifx.Lan: data Device
+ Lifx.Lan: data LifxT m a
+ Lifx.Lan: deviceAddress :: Device -> HostAddress
+ Lifx.Lan: deviceFromAddress :: (Word8, Word8, Word8, Word8) -> Device
+ Lifx.Lan: instance GHC.Classes.Eq (Lifx.Lan.Message r)
+ Lifx.Lan: instance GHC.Classes.Eq Lifx.Lan.Device
+ Lifx.Lan: instance GHC.Classes.Ord (Lifx.Lan.Message r)
+ Lifx.Lan: instance GHC.Classes.Ord Lifx.Lan.Device
+ Lifx.Lan: instance GHC.Show.Show (Lifx.Lan.Message r)
+ Lifx.Lan: instance GHC.Show.Show Lifx.Lan.Device
+ Lifx.Lan: instance Lifx.Lan.MessageResult ()
+ Lifx.Lan: instance Lifx.Lan.MessageResult Lifx.Lan.LightState
+ Lifx.Lan: instance Lifx.Lan.MessageResult Lifx.Lan.StatePower
+ Lifx.Lan: instance Lifx.Lan.MessageResult Lifx.Lan.StateService
- Lifx.Lan: StateService :: Service -> Word32 -> StateService
+ Lifx.Lan: StateService :: Service -> PortNumber -> StateService
- Lifx.Lan: WrongSender :: HostAddress -> HostAddress -> LifxError
+ Lifx.Lan: WrongSender :: Device -> HostAddress -> LifxError
- Lifx.Lan: [$sel:port:StateService] :: StateService -> Word32
+ Lifx.Lan: [$sel:port:StateService] :: StateService -> PortNumber
- Lifx.Lan: [SetColor] :: HSBK -> Duration -> Message ()
+ Lifx.Lan: [SetColor] :: HSBK -> NominalDiffTime -> Message ()
- Lifx.Lan: [SetLightPower] :: Bool -> Duration -> Message ()
+ Lifx.Lan: [SetLightPower] :: Bool -> NominalDiffTime -> Message ()
- Lifx.Lan: broadcastMessage :: MonadLifx m => Message a -> m [(HostAddress, a)]
+ Lifx.Lan: broadcastMessage :: MonadLifx m => Message r -> m [(Device, r)]
- Lifx.Lan: data Message a
+ Lifx.Lan: data Message r
- Lifx.Lan: discoverDevices :: MonadLifx m => Maybe Int -> m [HostAddress]
+ Lifx.Lan: discoverDevices :: MonadLifx m => Maybe Int -> m [Device]
- Lifx.Lan: encodeMessage :: Bool -> Bool -> Word8 -> Word32 -> Message a -> ByteString
+ Lifx.Lan: encodeMessage :: Bool -> Bool -> Word8 -> Word32 -> Message r -> ByteString
- Lifx.Lan: sendMessage :: MonadLifx m => HostAddress -> Message a -> m a
+ Lifx.Lan: sendMessage :: MonadLifx m => Device -> Message r -> m r

Files

README.md view
@@ -1,5 +1,7 @@-Bindings to the LIFX LAN API.+Haskell bindings to the [LIFX LAN API](https://lan.developer.lifx.com/docs). -Currently very basic:-- Only supports setting power and colour.-- No error-handling - we assume all UDP messages will send successfully.+This library provides a reasonably high-level interface, but doesn't try to be *too* clever.+For example, it doesn't check message delivery, and throws an error if a light takes too long to respond.+Messages and response types map directly to the low-level API (with links provided in the documentation).++It does not yet cover the full API, but PRs are very welcome and some functionality may be added on request.
lifx-lan.cabal view
@@ -1,14 +1,18 @@ cabal-version:      3.0 name:               lifx-lan-version:            0.3.0+version:            0.4.0 license:            BSD-3-Clause license-file:       LICENSE author:             George Thomas maintainer:         georgefsthomas@gmail.com synopsis:           LIFX LAN API+homepage:           https://github.com/georgefst/lifx-lan extra-doc-files:     CHANGELOG.md     README.md+source-repository head+    type: git+    location: git://github.com/georgefst/lifx-lan.git  library     exposed-modules:@@ -35,6 +39,8 @@     default-extensions:         AllowAmbiguousTypes         BlockArguments+        ConstraintKinds+        DefaultSignatures         DeriveAnyClass         DeriveFunctor         DeriveGeneric
src/Lifx/Lan.hs view
@@ -1,154 +1,208 @@+{- |+@+-- these should be enabled by default in a future version of GHC+-- (they aren't entirely necessary here anyway - they just make the example even simpler)+\{\-\# LANGUAGE BlockArguments \#\-\}+\{\-\# LANGUAGE NamedFieldPuns \#\-\}++import Control.Monad.IO.Class (liftIO)+import Data.Foldable (for_)++-- | Find all devices on the network, print their addresses, and set their brightness to 50%.+main :: IO ()+main = runLifx do+    devs <- discoverDevices Nothing+    liftIO $ print devs+    for_ devs \\d -> do+        LightState{hsbk} <- sendMessage d GetColor+        sendMessage d $ SetColor hsbk{brightness = maxBound \`div\` 2} 3+@+-} module Lifx.Lan (+    Device,+    deviceAddress,     sendMessage,     broadcastMessage,     discoverDevices,     Message (..),     HSBK (..),-    Duration (..),     Lifx,     runLifx,-    LifxT (..),+    LifxT,     runLifxT,     LifxError (..),     MonadLifx (..),      -- * Responses-    LightState (..),     StateService (..),     Service (..),     StatePower (..),+    LightState (..),      -- * Low-level+    deviceFromAddress,     encodeMessage,     Header (..),+    unLifxT, ) where  import Control.Monad import Control.Monad.Except import Control.Monad.Extra import Control.Monad.Reader-import Control.Monad.State hiding (get, put)+import Control.Monad.State import Control.Monad.Trans.Maybe-import Data.Binary-import Data.Binary.Get hiding (label)-import Data.Binary.Put-import Data.Bits-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as BL import Data.Either.Extra import Data.Fixed import Data.Foldable import Data.Function import Data.Functor+import Data.List+import Data.Maybe+import Data.Tuple.Extra+import Data.Word+import System.IO.Error++import Data.Binary (Binary)+import Data.Binary qualified as Binary+import Data.Binary.Get (+    ByteOffset,+    Get,+    getByteString,+    getWord16le,+    getWord32le,+    getWord64be,+    getWord8,+    runGetOrFail,+    skip,+ )+import Data.Binary.Put (+    Put,+    putWord16le,+    putWord32le,+    putWord64be,+    putWord8,+    runPut,+ )+import Data.Bits (Bits (..))+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) import Data.Map.Strict qualified as Map-import Data.Maybe-import Data.Time-import Data.Tuple.Extra+import Data.Time (+    NominalDiffTime,+    diffUTCTime,+    getCurrentTime,+    nominalDiffTimeToSeconds,+ ) import GHC.Generics (Generic)-import GHC.IO.Exception-import Network.Socket-import Network.Socket.ByteString-import System.Random-import System.Timeout+import Network.Socket (+    Family (AF_INET),+    HostAddress,+    PortNumber,+    SockAddr (SockAddrInet),+    Socket,+    SocketOption (Broadcast),+    SocketType (Datagram),+    bind,+    defaultPort,+    defaultProtocol,+    hostAddressToTuple,+    setSocketOption,+    socket,+    tupleToHostAddress,+ )+import Network.Socket.ByteString (recvFrom, sendTo)+import System.Random (randomIO)+import System.Timeout (timeout) +{- Device -}++-- | A LIFX device, such as a bulb.+newtype Device = Device {unDevice :: HostAddress}+    deriving newtype (Eq, Ord)++instance Show Device where+    show (Device ha) = let (a, b, c, d) = hostAddressToTuple ha in intercalate "." $ map show [a, b, c, d]++{- |+>>> deviceFromAddress (192, 168, 0, 1)+192.168.0.1++'Device's are really just 'HostAddress's, but you don't need to know that to use this library.+Prefer to get devices from 'discoverDevices' where possible, rather than hardcoding addresses.+-}+deviceFromAddress :: (Word8, Word8, Word8, Word8) -> Device+deviceFromAddress = Device . tupleToHostAddress++deviceAddress :: Device -> HostAddress+deviceAddress = unDevice+ {- Core -}  lifxPort :: PortNumber lifxPort = 56700 -sendMessage :: MonadLifx m => HostAddress -> Message a -> m a+-- | Send a message and wait for a response.+sendMessage :: MonadLifx m => Device -> Message r -> m r sendMessage receiver msg = do-    timeoutDuration <- getTimeout     incrementCounter-    sendMessage' True receiver msg-    getResponse' msg & either pure \(expectedPacketType, messageSize, getBody) -> untilJustM do-        (bs, sender0) <- throwEither $ maybeToEither RecvTimeout <$> receiveMessage timeoutDuration messageSize-        sender <- hostAddressFromSock sender0-        res <- decodeMessage getBody expectedPacketType bs-        when (isJust res && sender /= receiver) $ lifxThrow $ WrongSender receiver sender-        pure res-  where-    throwEither x =-        x >>= \case-            Left e -> lifxThrow e-            Right r -> pure r+    sendMessage' True (unDevice receiver) msg+    Dict <- pure $ msgResWitness msg+    getSendResult receiver -broadcastMessage :: MonadLifx m => Message a -> m [(HostAddress, a)]-broadcastMessage =-    fmap (concatMap (\(a, xs) -> map (a,) $ toList xs) . Map.toList)-        . broadcastMessage' (const $ pure . pure) Nothing-broadcastMessage' ::-    MonadLifx m =>-    -- | Transform output and discard messages which return 'Nothing'.-    (HostAddress -> a -> m (Maybe b)) ->-    -- | Return once this predicate over received messages passes. Otherwise just keep waiting until timeout.-    Maybe (Map HostAddress (NonEmpty b) -> Bool) ->-    Message a ->-    m (Map HostAddress (NonEmpty b))-broadcastMessage' filter' maybeFinished msg = do-    timeoutDuration <- getTimeout-    incrementCounter-    sendMessage' False receiver msg-    getResponse' msg & either noResponseNeeded \(expectedPacketType, messageSize, getBody) -> do-        t0 <- liftIO getCurrentTime-        flip execStateT Map.empty $ untilM do-            t <- liftIO getCurrentTime-            let timeLeft = timeoutDuration - nominalDiffTimeToMicroSeconds (diffUTCTime t t0)-            if timeLeft < 0-                then pure False-                else-                    receiveMessage timeLeft messageSize >>= \case-                        Just (bs, addr) -> do-                            decodeMessage getBody expectedPacketType bs >>= \case-                                Just x -> do-                                    hostAddr <- hostAddressFromSock addr-                                    lift (filter' hostAddr x) >>= \case-                                        Just x' -> modify $ Map.insertWith (<>) hostAddr (pure x')-                                        Nothing -> pure ()-                                Nothing -> pure ()-                            maybe (pure False) gets maybeFinished-                        Nothing -> do-                            -- if we were waiting for a predicate to pass, then we've timed out-                            when (isJust maybeFinished) $ lifxThrow . BroadcastTimeout =<< gets Map.keys-                            pure True-  where-    receiver = tupleToHostAddress (255, 255, 255, 255)-    noResponseNeeded = fmap (maybe Map.empty $ Map.singleton receiver . pure) . filter' receiver+-- | Broadcast a message and wait for responses.+broadcastMessage :: MonadLifx m => Message r -> m [(Device, r)]+broadcastMessage msg =+    msgResWitness msg & \Dict ->+        concatMap (\(a, xs) -> map (a,) $ toList xs) . Map.toList+            <$> broadcastAndGetResult (const $ pure . pure) Nothing msg -{- | If an integer argument is given, wait until we have responses from that number of devices.-Otherwise just keep waiting until timeout.+{- |+Search for devices on the local network.+If an integer argument is given, wait until we have found that number of devices -+otherwise just keep waiting until timeout. -}-discoverDevices :: MonadLifx m => Maybe Int -> m [HostAddress]-discoverDevices nDevices = Map.keys <$> broadcastMessage' f p GetService+discoverDevices :: MonadLifx m => Maybe Int -> m [Device]+discoverDevices nDevices = Map.keys <$> broadcastAndGetResult f p GetService   where     f _addr StateService{..} = do-        checkPort $ fromIntegral port+        checkPort port         pure . guard $ service == ServiceUDP     p = nDevices <&> \n -> (>= n) . length +-- | A colour. See https://lan.developer.lifx.com/docs/representing-color-with-hsbk. data HSBK = HSBK     { hue :: Word16     , saturation :: Word16     , brightness :: Word16-    , kelvin :: Word16+    , -- | takes values in the range 1500 to 9000+      kelvin :: Word16     }     deriving (Eq, Ord, Show, Generic)-newtype Duration = Duration Word32-    deriving (Eq, Ord, Show, Generic) -data Message a where+-- | A message we can send to a 'Device'. 'r' is the type of the expected response.+data Message r where+    -- | https://lan.developer.lifx.com/docs/querying-the-device-for-data#getservice---packet-2+    -- (you shouldn't need this - use 'discoverDevices')     GetService :: Message StateService+    -- | https://lan.developer.lifx.com/docs/querying-the-device-for-data#getpower---packet-20     GetPower :: Message StatePower+    -- | https://lan.developer.lifx.com/docs/changing-a-device#setpower---packet-21     SetPower :: Bool -> Message ()+    -- | https://lan.developer.lifx.com/docs/querying-the-device-for-data#getcolor---packet-101     GetColor :: Message LightState-    SetColor :: HSBK -> Duration -> Message ()-    SetLightPower :: Bool -> Duration -> Message ()-deriving instance (Eq (Message a))-deriving instance (Ord (Message a))-deriving instance (Show (Message a))+    -- | https://lan.developer.lifx.com/docs/changing-a-device#setcolor---packet-102+    SetColor :: HSBK -> NominalDiffTime -> Message ()+    -- | https://lan.developer.lifx.com/docs/changing-a-device#setlightpower---packet-117+    SetLightPower :: Bool -> NominalDiffTime -> Message () +deriving instance (Eq (Message r))+deriving instance (Ord (Message r))+deriving instance (Show (Message r))++-- | https://lan.developer.lifx.com/docs/field-types#services data Service     = ServiceUDP     | ServiceReserved1@@ -156,15 +210,21 @@     | ServiceReserved3     | ServiceReserved4     deriving (Eq, Ord, Show, Generic)++-- | https://lan.developer.lifx.com/docs/information-messages#stateservice---packet-3 data StateService = StateService     { service :: Service-    , port :: Word32+    , port :: PortNumber     }     deriving (Eq, Ord, Show, Generic)++-- | https://lan.developer.lifx.com/docs/information-messages#statepower---packet-22 newtype StatePower = StatePower     { power :: Word16     }     deriving (Eq, Ord, Show, Generic)++-- | https://lan.developer.lifx.com/docs/information-messages#lightstate---packet-107 data LightState = LightState     { hsbk :: HSBK     , power :: Word16@@ -177,20 +237,81 @@     | RecvTimeout     | BroadcastTimeout [HostAddress] -- contains the addresses which we have received valid responses from     | WrongPacketType Word16 Word16 -- expected, then actual-    | WrongSender HostAddress HostAddress -- expected, then actual+    | WrongSender Device HostAddress -- expected, then actual     | UnexpectedSockAddrType SockAddr     | UnexpectedPort PortNumber     deriving (Eq, Ord, Show, Generic)  {- Message responses -} +class MessageResult a where+    getSendResult :: MonadLifx m => Device -> m a+    default getSendResult :: (MonadLifx m, Response a) => Device -> m a+    getSendResult receiver = untilJustM do+        timeoutDuration <- getTimeout+        (bs, sender0) <- throwEither $ maybeToEither RecvTimeout <$> receiveMessage timeoutDuration (messageSize @a)+        sender <- hostAddressFromSock sender0+        res <- decodeMessage @a bs+        when (isJust res && sender /= deviceAddress receiver) $ lifxThrow $ WrongSender receiver sender+        pure res+      where+        throwEither x =+            x >>= \case+                Left e -> lifxThrow e+                Right r -> pure r++    broadcastAndGetResult ::+        MonadLifx m =>+        -- | Transform output and discard messages which return 'Nothing'.+        (HostAddress -> a -> m (Maybe b)) ->+        -- | Return once this predicate over received messages passes. Otherwise just keep waiting until timeout.+        Maybe (Map HostAddress (NonEmpty b) -> Bool) ->+        Message r ->+        m (Map Device (NonEmpty b))+    default broadcastAndGetResult ::+        (MonadLifx m, Response a) =>+        (HostAddress -> a -> m (Maybe b)) ->+        Maybe (Map HostAddress (NonEmpty b) -> Bool) ->+        Message r ->+        m (Map Device (NonEmpty b))+    broadcastAndGetResult filter' maybeFinished msg = do+        timeoutDuration <- getTimeout+        incrementCounter+        sendMessage' False (tupleToHostAddress (255, 255, 255, 255)) msg+        t0 <- liftIO getCurrentTime+        fmap (Map.mapKeysMonotonic Device) . flip execStateT Map.empty $ untilM do+            t <- liftIO getCurrentTime+            let timeLeft = timeoutDuration - nominalDiffTimeToInt @Micro (diffUTCTime t t0)+            if timeLeft < 0+                then pure False+                else+                    receiveMessage timeLeft (messageSize @a) >>= \case+                        Just (bs, addr) -> do+                            decodeMessage @a bs >>= \case+                                Just x -> do+                                    hostAddr <- hostAddressFromSock addr+                                    lift (filter' hostAddr x) >>= \case+                                        Just x' -> modify $ Map.insertWith (<>) hostAddr (pure x')+                                        Nothing -> pure ()+                                Nothing -> pure ()+                            maybe (pure False) gets maybeFinished+                        Nothing -> do+                            -- if we were waiting for a predicate to pass, then we've timed out+                            when (isJust maybeFinished) $ lifxThrow . BroadcastTimeout =<< gets Map.keys+                            pure True+ class Response a where-    getResponse :: Either a (Word16, Int, Get a)+    expectedPacketType :: Word16+    messageSize :: Int+    getBody :: Get a -instance Response () where-    getResponse = Left ()+instance MessageResult () where+    getSendResult = const $ pure ()+    broadcastAndGetResult = const . const . const $ pure Map.empty instance Response StateService where-    getResponse = Right $ (3,5,) do+    expectedPacketType = 3+    messageSize = 5+    getBody = do         service <-             getWord8 >>= \case                 1 -> pure ServiceUDP@@ -199,34 +320,48 @@                 4 -> pure ServiceReserved3                 5 -> pure ServiceReserved4                 n -> fail $ "unknown service: " <> show n-        port <- getWord32le+        port <- do+            x <- getWord32le+            -- `network` lib uses `Word16` for ports, but LIFX StateService uses `Word32`+            maybe (fail $ "port out of range: " <> show x) pure $ fromIntegralSafe x         pure StateService{..}+instance MessageResult StateService instance Response LightState where-    getResponse = Right $ (107,52,) do+    expectedPacketType = 107+    messageSize = 52+    getBody = do         hsbk <- HSBK <$> getWord16le <*> getWord16le <*> getWord16le <*> getWord16le         skip 2         power <- getWord16le         label <- BS.takeWhile (/= 0) <$> getByteString 32         skip 8         pure LightState{..}+instance MessageResult LightState instance Response StatePower where-    getResponse =-        Right . (22,2,) $-            StatePower <$> getWord16le+    expectedPacketType = 22+    messageSize = 2+    getBody = StatePower <$> getWord16le+instance MessageResult StatePower --- | Seeing as all `Message` response types are instances of `Response`, we can hide that type class from users.-getResponse' :: Message a -> Either a (Word16, Int, Get a)-getResponse' = \case-    GetService{} -> getResponse-    GetPower{} -> getResponse-    SetPower{} -> getResponse-    GetColor{} -> getResponse-    SetColor{} -> getResponse-    SetLightPower{} -> getResponse+-- all `Message` response types are instances of `MessageResult`+--TODO ImpredicativeTypes:+-- msgResWitness :: Message r -> (forall a. MessageResult a => x) -> x+msgResWitness :: Message r -> Dict (MessageResult r)+msgResWitness = \case+    GetService{} -> Dict+    GetPower{} -> Dict+    SetPower{} -> Dict+    GetColor{} -> Dict+    SetColor{} -> Dict+    SetLightPower{} -> Dict+data Dict c where+    Dict :: c => Dict c  {- Monad -} +-- | A simple implementation of 'MonadLifx'. type Lifx = LifxT IO+ newtype LifxT m a = LifxT     { unLifxT ::         StateT@@ -253,19 +388,15 @@ runLifx :: Lifx a -> IO a runLifx m =     runLifxT 5_000_000 m >>= \case-        Left e ->-            ioError-                IOError-                    { ioe_handle = Nothing-                    , ioe_type = OtherError-                    , ioe_location = "LIFX"-                    , ioe_description = show e-                    , ioe_errno = Nothing-                    , ioe_filename = Nothing-                    }+        Left e -> ioError $ mkIOError userErrorType (show e) Nothing Nothing         Right x -> pure x -runLifxT :: MonadIO m => Int -> LifxT m a -> m (Either LifxError a)+runLifxT ::+    MonadIO m =>+    -- | Timeout for waiting for message responses, in microseconds.+    Int ->+    LifxT m a ->+    m (Either LifxError a) runLifxT timeoutDuration (LifxT x) = do     sock <- liftIO $ socket AF_INET Datagram defaultProtocol     liftIO $ setSocketOption sock Broadcast 1@@ -273,6 +404,7 @@     source <- randomIO     runExceptT $ runReaderT (evalStateT x 0) (sock, source, timeoutDuration) +-- | A monad for sending and receiving LIFX messages. class MonadIO m => MonadLifx m where     getSocket :: m Socket     getSource :: m Word32@@ -291,6 +423,7 @@         BL.ByteString ->         m ()     handleOldMessage _ _ _ _ = pure ()+ instance MonadIO m => MonadLifx (LifxT m) where     getSocket = LifxT $ asks fst3     getSource = LifxT $ asks snd3@@ -329,9 +462,9 @@  {- Low level -} -encodeMessage :: Bool -> Bool -> Word8 -> Word32 -> Message a -> BL.ByteString+encodeMessage :: Bool -> Bool -> Word8 -> Word32 -> Message r -> BL.ByteString encodeMessage tagged ackRequired sequenceCounter source msg =-    runPut $ put (messageHeader tagged ackRequired sequenceCounter source msg) >> putMessagePayload msg+    runPut $ Binary.put (messageHeader tagged ackRequired sequenceCounter source msg) >> putMessagePayload msg  -- | https://lan.developer.lifx.com/docs/encoding-a-packet data Header = Header@@ -391,7 +524,7 @@       where         bitIf b n = if b then bit n else zeroBits -messageHeader :: Bool -> Bool -> Word8 -> Word32 -> Message a -> Header+messageHeader :: Bool -> Bool -> Word8 -> Word32 -> Message r -> Header messageHeader tagged ackRequired sequenceCounter source = \case     GetService{} ->         Header@@ -436,23 +569,23 @@     origin = 0 :: Word8     resRequired = False -putMessagePayload :: Message a -> Put+putMessagePayload :: Message r -> Put putMessagePayload = \case     GetService -> mempty     GetPower -> mempty     SetPower b ->         putWord16le if b then maxBound else minBound     GetColor -> mempty-    SetColor HSBK{..} (Duration d) -> do+    SetColor HSBK{..} d -> do         putWord8 0         putWord16le hue         putWord16le saturation         putWord16le brightness         putWord16le kelvin-        putWord32le d-    SetLightPower b (Duration d) -> do+        putWord32le $ nominalDiffTimeToInt @Milli d+    SetLightPower b d -> do         putWord16le if b then maxBound else minBound-        putWord32le d+        putWord32le $ nominalDiffTimeToInt @Milli d  {- Util -} @@ -462,39 +595,47 @@     | e == maxBound = minBound     | otherwise = succ e +fromIntegralSafe :: forall a b. (Integral a, Integral b, Bounded b) => a -> Maybe b+fromIntegralSafe x =+    guard+        ( x <= fromIntegral (maxBound @b)+            && x >= fromIntegral (minBound @b)+        )+        $> fromIntegral x+ headerSize :: Num a => a headerSize = 36 --- | For use with 'timeout', 'threadDelay' etc.-nominalDiffTimeToMicroSeconds :: NominalDiffTime -> Int-nominalDiffTimeToMicroSeconds t = fromInteger $ p `div` 1_000_000+nominalDiffTimeToInt :: forall f a r. (HasResolution r, f ~ Fixed r, Integral a) => NominalDiffTime -> a+nominalDiffTimeToInt t = fromInteger n   where-    MkFixed p = nominalDiffTimeToSeconds t+    MkFixed n = realToFrac @Pico @f $ nominalDiffTimeToSeconds t  -- | Inverted 'whileM'. untilM :: Monad m => m Bool -> m () untilM = whileM . fmap not  checkPort :: MonadLifx f => PortNumber -> f ()-checkPort port = when (port /= fromIntegral lifxPort) . lifxThrow $ UnexpectedPort port+checkPort port = when (port /= lifxPort) . lifxThrow $ UnexpectedPort port  -- these helpers are all used by 'sendMessage' and 'broadcastMessage'-decodeMessage :: MonadLifx m => Get b -> Word16 -> BS.ByteString -> m (Maybe b) -- Nothing means counter didnt match-decodeMessage getBody expectedPacketType bs = do+decodeMessage :: forall b m. (Response b, MonadLifx m) => BS.ByteString -> m (Maybe b) -- Nothing means counter mismatch+decodeMessage bs = do     counter <- getCounter-    case runGetOrFail get $ BL.fromStrict bs of+    case runGetOrFail Binary.get $ BL.fromStrict bs of         Left e -> throwDecodeFailure e         Right (bs', _, Header{packetType, sequenceCounter}) ->             if sequenceCounter /= counter                 then handleOldMessage counter sequenceCounter packetType bs' >> pure Nothing                 else do-                    when (packetType /= expectedPacketType) . lifxThrow $ WrongPacketType expectedPacketType packetType+                    when (packetType /= expectedPacketType @b) . lifxThrow $+                        WrongPacketType (expectedPacketType @b) packetType                     case runGetOrFail getBody bs' of                         Left e -> throwDecodeFailure e                         Right (_, _, res) -> pure $ Just res   where     throwDecodeFailure (bs', bo, e) = lifxThrow $ DecodeFailure (BL.toStrict bs') bo e-sendMessage' :: MonadLifx m => Bool -> HostAddress -> Message a -> m ()+sendMessage' :: MonadLifx m => Bool -> HostAddress -> Message r -> m () sendMessage' tagged receiver msg = do     sock <- getSocket     counter <- getCounter@@ -509,9 +650,21 @@     SockAddrInet port ha -> checkPort port >> pure ha     addr -> lifxThrow $ UnexpectedSockAddrType addr receiveMessage :: MonadLifx m => Int -> Int -> m (Maybe (BS.ByteString, SockAddr))-receiveMessage t messageSize = do+receiveMessage t size = do     sock <- getSocket     liftIO         . timeout t         . recvFrom sock-        $ headerSize + messageSize+        $ headerSize + size++{-+post to forum+    https://community.lifx.com/c/developing-with-lifx/5+    link to lifx-manager https://community.lifx.com/c/developing-with-lifx/5+        screenshot+        explain user-unfriendliness+    diss Python+    diss app+        or maybe just echo in https://community.lifx.com/t/done-with-lifx-such-a-waste-of-time-and-money/7731/9++-}