lifx-lan 0.7 → 0.7.1

raw patch · 3 files changed

+42/−28 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−1
• lifx-lan.cabal +1/−1
• src/Lifx/Lan.hs +36/−26

@@ -1,10 +1,14 @@ # Revision history for lifx-lan +## 0.7.1 -- 21-10-2022+- Handle invalid UTF-8 in light label.+- Ensure discovery exits successfully when zero devices wanted+ ## 0.7 -- 2022-02-20 - Drop support for GHC < 9.2.     - If anyone is stuck on an older version of GHC and needs recent features of `lifx-lan` then please let me know. It would be reasonably easy to create a branch for it. - Don't provide field selector functions for any types. Using `OverloadedRecordDot` in client code is recommended. We still export `unLifxT` as a normal function, for backward compatibility.-- Move much of the implementation detail of `LifxT` has been moved to `Lifx.Lan.Internal`.+- Move much of the implementation detail of `LifxT` to `Lifx.Lan.Internal`. - Add `Lifx.Lan.Mock.Terminal` module for testing programs without a physical LIFX device. - Add `sendMessageAndWait` function. - Use `Text` rather than `ByteString` for `label` field of `LightState`.

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               lifx-lan-version:            0.7+version:            0.7.1 license:            BSD-3-Clause license-file:       LICENSE author:             George Thomas

@@ -100,7 +100,8 @@ import Data.Map (Map) import Data.Map.Strict qualified as Map import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8)+import Data.Text.Encoding (decodeUtf8')+import Data.Text.Encoding.Error (UnicodeException (DecodeError)) import GHC.Generics (Generic) import Network.Socket.ByteString (recvFrom, sendTo) import System.Random (randomIO)@@ -239,26 +240,30 @@         timeoutDuration <- getTimeout         broadcast 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-                    lift (receiveMessage timeLeft (messageSize @a)) >>= \case-                        Just (bs, addr) -> do-                            lift (decodeMessage @a bs) >>= \case-                                Just x -> do-                                    hostAddr <- lift $ 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) $ lift . lifxThrowIO . BroadcastTimeout =<< gets Map.keys-                            pure True+        fmap (Map.mapKeysMonotonic Device) . flip execStateT Map.empty . untilM $+            traverse gets maybeFinished >>= \case+                Just True -> pure True+                _ -> do+                    t <- liftIO getCurrentTime+                    let timeLeft = timeoutDuration - nominalDiffTimeToInt @Micro (diffUTCTime t t0)+                    if timeLeft < 0+                        then pure False+                        else+                            lift (receiveMessage timeLeft (messageSize @a)) >>= \case+                                Just (bs, addr) -> do+                                    lift (decodeMessage @a bs) >>= \case+                                        Just x -> do+                                            hostAddr <- lift $ hostAddressFromSock addr+                                            lift (filter' hostAddr x) >>= \case+                                                Just x' -> modify (Map.insertWith (<>) hostAddr (pure x')) >> pure False+                                                Nothing -> pure False+                                        Nothing -> pure False+                                Nothing -> do+                                    -- if we were waiting for a predicate to pass, then we've timed out+                                    when (isJust maybeFinished) $+                                        lift . lifxThrowIO . BroadcastTimeout+                                            =<< gets Map.keys+                                    pure True  class Response a where     expectedPacketType :: Word16@@ -317,9 +322,13 @@         hsbk <- HSBK <$> getWord16le <*> getWord16le <*> getWord16le <*> getWord16le         skip 2         power <- getWord16le-        label <- decodeUtf8 . BS.takeWhile (/= 0) <$> getByteString 32+        label <- either (fail . showDecodeError) pure . decodeUtf8' . BS.takeWhile (/= 0) =<< getByteString 32         skip 8         pure LightState{..}+      where+        showDecodeError = \case+            DecodeError s _ -> s+            _ -> "impossible" instance MessageResult LightState  msgResWitness :: (MessageResult r => Message r -> a) -> (Message r -> a)@@ -344,7 +353,7 @@ runLifx :: Lifx a -> IO a runLifx m =     runLifxT 5_000_000 m >>= \case-        Left e -> ioError $ mkIOError userErrorType (show e) Nothing Nothing+        Left e -> ioError $ mkIOError userErrorType ("LIFX LAN: " <> show e) Nothing Nothing         Right x -> pure x  runLifxT ::@@ -388,9 +397,10 @@         sendMessage' True receiver.unwrap msg         getSendResult receiver -    broadcastMessage = msgResWitness \msg ->-        concatMap (\(a, xs) -> map (a,) $ toList xs) . Map.toList-            <$> broadcastAndGetResult (const $ pure . pure) Nothing msg+    broadcastMessage =+        msgResWitness $+            fmap (concatMap (\(a, xs) -> map (a,) $ toList xs) . Map.toList)+                . broadcastAndGetResult (const $ pure . pure) Nothing      discoverDevices nDevices = Map.keys <$> broadcastAndGetResult f p GetService       where