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 +6/−4
- lifx-lan.cabal +7/−1
- src/Lifx/Lan.hs +291/−138
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++-}