lifx-lan 0.6.2 → 0.7

raw patch · 8 files changed

+450/−285 lines, 8 filesdep +ansi-terminaldep +colourdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal, colour

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• lifx-lan.cabal +13/−3
• src/Lifx/Internal/Colour.hs +50/−0
• src/Lifx/Internal/ProductInfo.hs +4/−4
• src/Lifx/Internal/ProductInfoMap.hs +28/−65
• src/Lifx/Lan.hs +137/−213
• src/Lifx/Lan/Internal.hs +100/−0
• src/Lifx/Lan/Mock/Terminal.hs +107/−0

@@ -1,5 +1,16 @@ # Revision history for lifx-lan +## 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`.+- 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`.+- Rename `productId` field of `Product` to `id`.+- Update to latest products list.+ ## 0.6.2 -- 2022-02-02 - Update to latest products list. 

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               lifx-lan-version:            0.6.2+version:            0.7 license:            BSD-3-Clause license-file:       LICENSE author:             George Thomas@@ -16,17 +16,22 @@  library     exposed-modules:+        Lifx.Lan+        Lifx.Lan.Mock.Terminal+        Lifx.Lan.Internal+        Lifx.Internal.Colour         Lifx.Internal.Product         Lifx.Internal.ProductInfo         Lifx.Internal.ProductInfoMap-        Lifx.Lan     hs-source-dirs: src     ghc-options:         -Wall     build-depends:-        base ^>= {4.14, 4.15, 4.16},+        base ^>= {4.16},+        ansi-terminal ^>= 0.11.1,         binary ^>= 0.8.8,         bytestring ^>= {0.10.8, 0.11},+        colour ^>= 2.3.6,         composition ^>= 1.0.2.1,         containers ^>= 0.6.2.1,         extra ^>= 1.7.1,@@ -56,11 +61,15 @@         GADTs         GeneralizedNewtypeDeriving         ImportQualifiedPost+        ImpredicativeTypes         LambdaCase         MultiParamTypeClasses         NamedFieldPuns+        NoFieldSelectors+        NoMonomorphismRestriction         NumericUnderscores         OverloadedLabels+        OverloadedRecordDot         OverloadedStrings         PartialTypeSignatures         RankNTypes@@ -69,5 +78,6 @@         StandaloneDeriving         TupleSections         TypeApplications+        TypeFamilies         TypeOperators         ViewPatterns

@@ -0,0 +1,50 @@+module Lifx.Internal.Colour where++import Control.Applicative+import Data.Colour.SRGB+import Data.Ord+import Data.Word++import Data.Colour.RGBSpace.HSV (hsv)++import Lifx.Lan.Internal++{- |+Note that when 'kelvin' has an effect (i.e. when saturation is any less than maximum), output is somewhat arbitrary.++LIFX's team have never shared an exact forumla, and this implementation is inspired by various conflicting sources.+-}+hsbkToRgb :: HSBK -> RGB Float+hsbkToRgb HSBK{..} =+    interpolateColour+        (fromIntegral saturation / maxWord16)+        c+        c'+  where+    c =+        hsv+            (360 * fromIntegral hue / maxWord16)+            (fromIntegral saturation / maxWord16)+            (fromIntegral brightness / maxWord16)+    c' =+        let t =+                (log (fromIntegral kelvin) - log minKelvin)+                    / log (maxKelvin / minKelvin)+         in clamp (0, 1)+                <$> RGB+                    { channelRed = 1+                    , channelGreen = t / 2 + 0.5+                    , channelBlue = t+                    }++interpolateColour :: Num a => a -> RGB a -> RGB a -> RGB a+interpolateColour r = liftA2 (\a b -> a * (r + b * (1 - r)))++maxWord16 :: Float+maxWord16 = fromIntegral $ maxBound @Word16++minKelvin :: Num a => a+minKelvin = 1500++maxKelvin :: Num a => a+maxKelvin = 9000

@@ -1700,7 +1700,7 @@                 }             , ProductInfo                 { pid = 117-                , name = "LIFX Z"+                , name = "LIFX Z US"                 , features = PartialFeatures                     { hev = Nothing                     , color = Just True@@ -1720,7 +1720,7 @@                 }             , ProductInfo                 { pid = 118-                , name = "LIFX Z"+                , name = "LIFX Z Intl"                 , features = PartialFeatures                     { hev = Nothing                     , color = Just True@@ -1740,7 +1740,7 @@                 }             , ProductInfo                 { pid = 119-                , name = "LIFX Beam"+                , name = "LIFX Beam US"                 , features = PartialFeatures                     { hev = Nothing                     , color = Just True@@ -1760,7 +1760,7 @@                 }             , ProductInfo                 { pid = 120-                , name = "LIFX Beam"+                , name = "LIFX Beam Intl"                 , features = PartialFeatures                     { hev = Nothing                     , color = Just True

@@ -1,9 +1,6 @@ module Lifx.Internal.ProductInfoMap where  import Control.Applicative-import Data.Either.Extra-import Data.Foldable hiding (product)-import Data.Function import Data.Functor import Data.Maybe import Data.Tuple.Extra@@ -17,9 +14,6 @@ import Lifx.Internal.Product import Lifx.Internal.ProductInfo --- TODO RecordDotSyntax can make this and other hiding unnecessary (we could also use "id" instead of "productId"...)-import Prelude hiding (product)- productInfoMap :: Map Word32 (Features, Map Word32 ProductInfo) productInfoMap =     Map.fromList $@@ -27,14 +21,14 @@             ( vid             ,               ( defaults-              , Map.fromList $ (pid &&& id) <$> products+              , Map.fromList $ ((.pid) &&& id) <$> products               )             )  -- | Information about a particular LIFX product. data Product = Product     { name :: Text-    , productId :: Word32+    , id :: Word32     , features :: Features     }     deriving (Eq, Ord, Show, Generic)@@ -45,16 +39,16 @@     deriving (Eq, Ord, Show, Generic)  productLookup :: Word32 -> Word32 -> Word16 -> Word16 -> Either ProductLookupError Product-productLookup vendor product versionMinor versionMajor =+productLookup vendor prod versionMinor versionMajor =     case productInfoMap !? vendor of         Nothing -> Left $ UnknownVendorId vendor-        Just (defaults, products) -> case products !? product of-            Nothing -> Left $ UnknownProductId product+        Just (defaults, products) -> case products !? prod of+            Nothing -> Left $ UnknownProductId prod             Just ProductInfo{features = originalFeatures, ..} ->                 pure                     Product                         { name-                        , productId = product+                        , id = prod                         , features =                             completeFeatures defaults $                                 foldl@@ -67,61 +61,30 @@                                     upgrades                         }   where-    -- TODO RecordDotSyntax-    completeFeatures+    completeFeatures f pf =         Features-            { ..+            { hev = fromMaybe f.hev pf.hev+            , color = fromMaybe f.color pf.color+            , chain = fromMaybe f.chain pf.chain+            , matrix = fromMaybe f.matrix pf.matrix+            , relays = fromMaybe f.relays pf.relays+            , buttons = fromMaybe f.buttons pf.buttons+            , infrared = fromMaybe f.infrared pf.infrared+            , multizone = fromMaybe f.multizone pf.multizone+            , temperatureRange = pf.temperatureRange <|> f.temperatureRange+            , extendedMultizone = fromMaybe f.extendedMultizone pf.extendedMultizone             }-        PartialFeatures-            { hev = maybe_hev-            , color = maybe_color-            , chain = maybe_chain-            , matrix = maybe_matrix-            , relays = maybe_relays-            , buttons = maybe_buttons-            , infrared = maybe_infrared-            , multizone = maybe_multizone-            , temperatureRange = maybe_temperatureRange-            , extendedMultizone = maybe_extendedMultizone-            } =-            Features-                { hev = fromMaybe hev maybe_hev-                , color = fromMaybe color maybe_color-                , chain = fromMaybe chain maybe_chain-                , matrix = fromMaybe matrix maybe_matrix-                , relays = fromMaybe relays maybe_relays-                , buttons = fromMaybe buttons maybe_buttons-                , infrared = fromMaybe infrared maybe_infrared-                , multizone = fromMaybe multizone maybe_multizone-                , temperatureRange = maybe_temperatureRange <|> temperatureRange-                , extendedMultizone = fromMaybe extendedMultizone maybe_extendedMultizone-                }     -- left-biased-    addFeatures+    addFeatures new old =         PartialFeatures-            { ..+            { hev = new.hev <|> old.hev+            , color = new.color <|> old.color+            , chain = new.chain <|> old.chain+            , matrix = new.matrix <|> old.matrix+            , relays = new.relays <|> old.relays+            , buttons = new.buttons <|> old.buttons+            , infrared = new.infrared <|> old.infrared+            , multizone = new.multizone <|> old.multizone+            , temperatureRange = new.temperatureRange <|> old.temperatureRange+            , extendedMultizone = new.extendedMultizone <|> old.extendedMultizone             }-        PartialFeatures-            { hev = old_hev-            , color = old_color-            , chain = old_chain-            , matrix = old_matrix-            , relays = old_relays-            , buttons = old_buttons-            , infrared = old_infrared-            , multizone = old_multizone-            , temperatureRange = old_temperatureRange-            , extendedMultizone = old_extendedMultizone-            } =-            PartialFeatures-                { hev = hev <|> old_hev-                , color = color <|> old_color-                , chain = chain <|> old_chain-                , matrix = matrix <|> old_matrix-                , relays = relays <|> old_relays-                , buttons = buttons <|> old_buttons-                , infrared = infrared <|> old_infrared-                , multizone = multizone <|> old_multizone-                , temperatureRange = temperatureRange <|> old_temperatureRange-                , extendedMultizone = extendedMultizone <|> old_extendedMultizone-                }

@@ -21,18 +21,17 @@ module Lifx.Lan (     Device,     deviceAddress,-    sendMessage,-    broadcastMessage,-    discoverDevices,+    deviceFromAddress,     Message (..),     HSBK (..),     Lifx,     runLifx,-    LifxT (LifxT),+    LifxT,     runLifxT,     LifxError (..),     ProductLookupError (..),     MonadLifx (..),+    sendMessageAndWait,      -- * Responses     StateService (..),@@ -47,35 +46,35 @@     Product (..),     Features (..), -    -- * Low-level-    deviceFromAddress,+    -- * Message encoding++    -- | These are used internally by `LifxT`'s 'sendMessage' and 'broadcastMessage'.+    -- They are exposed in order to support some advanced use cases.     encodeMessage,     Header (..),-    unLifxT, ) where -import Control.Applicative+import Control.Concurrent import Control.Monad import Control.Monad.Except import Control.Monad.Extra import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Maybe+import Data.Composition import Data.Either.Extra import Data.Fixed-import Data.Foldable hiding (product)-import Data.Function+import Data.Foldable import Data.Functor-import Data.List hiding (product) import Data.Maybe-import Data.Tuple.Extra+import Data.Time import Data.Word+import Network.Socket import System.IO.Error  import Data.Binary (Binary) import Data.Binary qualified as Binary import Data.Binary.Get (-    ByteOffset,     Get,     getByteString,     getWord16le,@@ -100,104 +99,36 @@ import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) import Data.Map.Strict qualified as Map-import Data.Time (-    NominalDiffTime,-    diffUTCTime,-    getCurrentTime,-    nominalDiffTimeToSeconds,- )+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8) import GHC.Generics (Generic)-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)  import Lifx.Internal.Product import Lifx.Internal.ProductInfoMap---- TODO RecordDotSyntax can make this and other hiding unnecessary (we could also use "id" instead of "productId"...)-import Prelude hiding (product)+import Lifx.Lan.Internal  {- 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.+If we know the IP address of a `Device`, we can create it directly, rather than calling `discoverDevices`. -} deviceFromAddress :: (Word8, Word8, Word8, Word8) -> Device deviceFromAddress = Device . tupleToHostAddress  deviceAddress :: Device -> HostAddress-deviceAddress = unDevice+deviceAddress = (.unwrap)  {- Core -}  lifxPort :: PortNumber lifxPort = 56700 --- | Send a message and wait for a response.-sendMessage :: MonadLifx m => Device -> Message r -> m r-sendMessage receiver msg = do-    incrementCounter-    sendMessage' True (unDevice receiver) msg-    Dict <- pure $ msgResWitness msg-    getSendResult 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--{- |-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 [Device]-discoverDevices nDevices = Map.keys <$> broadcastAndGetResult f p GetService-  where-    f _addr StateService{..} = do-        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-    }-    deriving (Eq, Ord, Show, Generic)- -- | 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@@ -268,41 +199,30 @@ data LightState = LightState     { hsbk :: HSBK     , power :: Word16-    , label :: BS.ByteString+    , label :: Text     }     deriving (Eq, Ord, Show, Generic) -data LifxError-    = DecodeFailure BS.ByteString ByteOffset String-    | RecvTimeout-    | BroadcastTimeout [HostAddress] -- contains the addresses which we have received valid responses from-    | WrongPacketType Word16 Word16 -- expected, then actual-    | WrongSender Device HostAddress -- expected, then actual-    | UnexpectedSockAddrType SockAddr-    | UnexpectedPort PortNumber-    | ProductLookupError ProductLookupError-    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 :: MonadLifxIO m => Device -> m a+    default getSendResult :: (MonadLifxIO 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+        when (isJust res && sender /= deviceAddress receiver) $ lifxThrowIO $ WrongSender receiver sender         pure res       where         throwEither x =             x >>= \case-                Left e -> lifxThrow e+                Left e -> lifxThrowIO e                 Right r -> pure r      broadcastAndGetResult ::-        MonadLifx m =>+        MonadLifxIO 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.@@ -310,7 +230,7 @@         Message r ->         m (Map Device (NonEmpty b))     default broadcastAndGetResult ::-        (MonadLifx m, Response a) =>+        (MonadLifxIO m, Response a) =>         (HostAddress -> a -> m (Maybe b)) ->         Maybe (Map HostAddress (NonEmpty b) -> Bool) ->         Message r ->@@ -325,11 +245,11 @@             if timeLeft < 0                 then pure False                 else-                    receiveMessage timeLeft (messageSize @a) >>= \case+                    lift (receiveMessage timeLeft (messageSize @a)) >>= \case                         Just (bs, addr) -> do-                            decodeMessage @a bs >>= \case+                            lift (decodeMessage @a bs) >>= \case                                 Just x -> do-                                    hostAddr <- hostAddressFromSock addr+                                    hostAddr <- lift $ hostAddressFromSock addr                                     lift (filter' hostAddr x) >>= \case                                         Just x' -> modify $ Map.insertWith (<>) hostAddr (pure x')                                         Nothing -> pure ()@@ -337,7 +257,7 @@                             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+                            when (isJust maybeFinished) $ lift . lifxThrowIO . BroadcastTimeout =<< gets Map.keys                             pure True  class Response a where@@ -386,9 +306,9 @@     messageSize = 20     getBody = do         vendor <- getWord32le-        product <- getWord32le+        p <- getWord32le         skip 4-        pure StateVersion{..}+        pure StateVersion{product = p, ..} instance MessageResult StateVersion instance Response LightState where     expectedPacketType = 107@@ -397,52 +317,27 @@         hsbk <- HSBK <$> getWord16le <*> getWord16le <*> getWord16le <*> getWord16le         skip 2         power <- getWord16le-        label <- BS.takeWhile (/= 0) <$> getByteString 32+        label <- decodeUtf8 . BS.takeWhile (/= 0) <$> getByteString 32         skip 8         pure LightState{..} instance MessageResult LightState --- 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-    GetHostFirmware{} -> Dict-    GetPower{} -> Dict-    SetPower{} -> Dict-    GetVersion{} -> Dict-    GetColor{} -> Dict-    SetColor{} -> Dict-    SetLightPower{} -> Dict-data Dict c where-    Dict :: c => Dict c+msgResWitness :: (MessageResult r => Message r -> a) -> (Message r -> a)+msgResWitness f m = case m of+    GetService{} -> f m+    GetHostFirmware{} -> f m+    GetPower{} -> f m+    SetPower{} -> f m+    GetVersion{} -> f m+    GetColor{} -> f m+    SetColor{} -> f m+    SetLightPower{} -> f m  {- Monad -}  -- | A simple implementation of 'MonadLifx'. type Lifx = LifxT IO -newtype LifxT m a = LifxT-    { unLifxT ::-        StateT-            Word8-            ( ReaderT-                (Socket, Word32, Int)-                ( ExceptT-                    LifxError-                    m-                )-            )-            a-    }-    deriving newtype-        ( Functor-        , Applicative-        , Monad-        , MonadIO-        )- {- | Note that this throws 'LifxError's as 'IOException's, and sets timeout to 5 seconds. Use 'runLifxT' for more control. -}@@ -465,65 +360,84 @@     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-    getTimeout :: m Int-    incrementCounter :: m ()-    getCounter :: m Word8-    lifxThrow :: LifxError -> m a-    handleOldMessage ::-        -- | expected counter value-        Word8 ->-        -- | actual counter value-        Word8 ->-        -- | packet type-        Word16 ->-        -- | payload-        BL.ByteString ->-        m ()-    handleOldMessage _ _ _ _ = pure ()+class Monad m => MonadLifx m where+    -- | The type of errors associated with 'm'.+    type MonadLifxError m +    liftProductLookupError :: ProductLookupError -> MonadLifxError m+    lifxThrow :: MonadLifxError m -> m a++    -- | Send a message and wait for a response.+    sendMessage :: Device -> Message r -> m r++    -- | Broadcast a message and wait for responses.+    broadcastMessage :: Message r -> m [(Device, r)]++    -- | 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 :: Maybe Int -> m [Device]+ instance MonadIO m => MonadLifx (LifxT m) where-    getSocket = LifxT $ asks fst3-    getSource = LifxT $ asks snd3-    getTimeout = LifxT $ asks thd3-    incrementCounter = LifxT $ modify succ'-    getCounter = LifxT $ gets id-    lifxThrow = LifxT . throwError+    type MonadLifxError (LifxT m) = LifxError+    lifxThrow = lifxThrowIO+    liftProductLookupError = ProductLookupError++    sendMessage receiver = msgResWitness \msg -> do+        incrementCounter+        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++    discoverDevices nDevices = Map.keys <$> broadcastAndGetResult f p GetService+      where+        f _addr StateService{..} = do+            checkPort port+            pure . guard $ service == ServiceUDP+        p = nDevices <&> \n -> (>= n) . length instance MonadLifx m => MonadLifx (MaybeT m) where-    getSocket = lift getSocket-    getSource = lift getSource-    getTimeout = lift getTimeout-    incrementCounter = lift incrementCounter-    getCounter = lift getCounter+    type MonadLifxError (MaybeT m) = MonadLifxError m+    liftProductLookupError = liftProductLookupError @m+    sendMessage = lift .: sendMessage+    broadcastMessage = lift . broadcastMessage+    discoverDevices = lift . discoverDevices     lifxThrow = lift . lifxThrow instance MonadLifx m => MonadLifx (ExceptT e m) where-    getSocket = lift getSocket-    getSource = lift getSource-    getTimeout = lift getTimeout-    incrementCounter = lift incrementCounter-    getCounter = lift getCounter+    type MonadLifxError (ExceptT e m) = MonadLifxError m+    liftProductLookupError = liftProductLookupError @m+    sendMessage = lift .: sendMessage+    broadcastMessage = lift . broadcastMessage+    discoverDevices = lift . discoverDevices     lifxThrow = lift . lifxThrow instance MonadLifx m => MonadLifx (StateT s m) where-    getSocket = lift getSocket-    getSource = lift getSource-    getTimeout = lift getTimeout-    incrementCounter = lift incrementCounter-    getCounter = lift getCounter+    type MonadLifxError (StateT s m) = MonadLifxError m+    liftProductLookupError = liftProductLookupError @m+    sendMessage = lift .: sendMessage+    broadcastMessage = lift . broadcastMessage+    discoverDevices = lift . discoverDevices     lifxThrow = lift . lifxThrow instance MonadLifx m => MonadLifx (ReaderT e m) where-    getSocket = lift getSocket-    getSource = lift getSource-    getTimeout = lift getTimeout-    incrementCounter = lift incrementCounter-    getCounter = lift getCounter+    type MonadLifxError (ReaderT e m) = MonadLifxError m+    liftProductLookupError = liftProductLookupError @m+    sendMessage = lift .: sendMessage+    broadcastMessage = lift . broadcastMessage+    discoverDevices = lift . discoverDevices     lifxThrow = lift . lifxThrow -{- Low level -}--encodeMessage :: Bool -> Bool -> Word8 -> Word32 -> Message r -> BL.ByteString+encodeMessage ::+    -- | tagged+    Bool ->+    -- | ackRequired+    Bool ->+    -- | sequenceCounter+    Word8 ->+    -- | source+    Word32 ->+    Message r ->+    BL.ByteString encodeMessage tagged ackRequired sequenceCounter source msg =     runPut $ Binary.put (messageHeader tagged ackRequired sequenceCounter source msg) >> putMessagePayload msg @@ -663,20 +577,30 @@         putWord32le $ nominalDiffTimeToInt @Milli d  -- | Ask a device for its vendor and product ID, and look up info on it from the official database.-getProductInfo :: MonadLifx m => Device -> m Product+getProductInfo :: forall m. MonadLifx m => Device -> m Product getProductInfo dev = do     StateHostFirmware{..} <- sendMessage dev GetHostFirmware-    StateVersion{..} <- sendMessage dev GetVersion-    either (lifxThrow . ProductLookupError) pure $ productLookup vendor product versionMinor versionMajor+    v <- sendMessage dev GetVersion+    either (lifxThrow . liftProductLookupError @m) pure $ productLookup v.vendor v.product versionMinor versionMajor -{- Util -}+{- Higher-level helpers -} --- | Safe, wraparound variant of 'succ'.-succ' :: (Eq a, Bounded a, Enum a) => a -> a-succ' e-    | e == maxBound = minBound-    | otherwise = succ e+{- | Like `sendMessage`, but for messages whose effect is not instantaneous (e.g. `SetColor`),+block (using `threadDelay`) until completion.+-}+sendMessageAndWait :: (MonadLifx m, MonadIO m) => Device -> Message () -> m ()+sendMessageAndWait d m = do+    sendMessage d m+    maybe (pure ()) (liftIO . threadDelay . timeMicros) mt+  where+    mt = case m of+        SetPower{} -> Nothing+        SetColor _ t -> Just t+        SetLightPower _ t -> Just t+    timeMicros t = round $ t * 1_000_000 +{- Util -}+ fromIntegralSafe :: forall a b. (Integral a, Integral b, Bounded b) => a -> Maybe b fromIntegralSafe x =     guard@@ -697,11 +621,11 @@ untilM :: Monad m => m Bool -> m () untilM = whileM . fmap not -checkPort :: MonadLifx f => PortNumber -> f ()-checkPort port = when (port /= lifxPort) . lifxThrow $ UnexpectedPort port+checkPort :: MonadLifxIO f => PortNumber -> f ()+checkPort port = when (port /= lifxPort) . lifxThrowIO $ UnexpectedPort port  -- these helpers are all used by 'sendMessage' and 'broadcastMessage'-decodeMessage :: forall b m. (Response b, MonadLifx m) => BS.ByteString -> m (Maybe b) -- Nothing means counter mismatch+decodeMessage :: forall b m. (Response b, MonadLifxIO m) => BS.ByteString -> m (Maybe b) -- Nothing means counter mismatch decodeMessage bs = do     counter <- getCounter     case runGetOrFail Binary.get $ BL.fromStrict bs of@@ -710,14 +634,14 @@             if sequenceCounter /= counter                 then handleOldMessage counter sequenceCounter packetType bs' >> pure Nothing                 else do-                    when (packetType /= expectedPacketType @b) . lifxThrow $+                    when (packetType /= expectedPacketType @b) . lifxThrowIO $                         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 r -> m ()+    throwDecodeFailure (bs', bo, e) = lifxThrowIO $ DecodeFailure (BL.toStrict bs') bo e+sendMessage' :: MonadLifxIO m => Bool -> HostAddress -> Message r -> m () sendMessage' tagged receiver msg = do     sock <- getSocket     counter <- getCounter@@ -727,11 +651,11 @@             sock             (BL.toStrict $ encodeMessage tagged False counter source msg)             (SockAddrInet lifxPort receiver)-hostAddressFromSock :: MonadLifx m => SockAddr -> m HostAddress+hostAddressFromSock :: MonadLifxIO m => SockAddr -> m HostAddress hostAddressFromSock = \case     SockAddrInet port ha -> checkPort port >> pure ha-    addr -> lifxThrow $ UnexpectedSockAddrType addr-receiveMessage :: MonadLifx m => Int -> Int -> m (Maybe (BS.ByteString, SockAddr))+    addr -> lifxThrowIO $ UnexpectedSockAddrType addr+receiveMessage :: MonadLifxIO m => Int -> Int -> m (Maybe (BS.ByteString, SockAddr)) receiveMessage t size = do     sock <- getSocket     liftIO@@ -739,7 +663,7 @@         . recvFrom sock         $ headerSize + size -broadcast :: MonadLifx m => Message r -> m ()+broadcast :: MonadLifxIO m => Message r -> m () broadcast msg = do     incrementCounter     sendMessage' False (tupleToHostAddress (255, 255, 255, 255)) msg

@@ -0,0 +1,100 @@+module Lifx.Lan.Internal where++import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Data.Binary.Get+import Data.List+import Data.Tuple.Extra+import Data.Word+import Network.Socket++import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import GHC.Generics (Generic)++import Lifx.Internal.ProductInfoMap (ProductLookupError)++-- | A LIFX device, such as a bulb.+newtype Device = Device {unwrap :: 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]++-- | 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+    }+    deriving (Eq, Ord, Show, Generic)++data LifxError+    = DecodeFailure BS.ByteString ByteOffset String+    | RecvTimeout+    | BroadcastTimeout [HostAddress] -- contains the addresses which we have received valid responses from+    | WrongPacketType Word16 Word16 -- expected, then actual+    | WrongSender Device HostAddress -- expected, then actual+    | UnexpectedSockAddrType SockAddr+    | UnexpectedPort PortNumber+    | ProductLookupError ProductLookupError+    deriving (Eq, Ord, Show, Generic)++-- | A monad for sending and receiving LIFX messages.+class MonadIO m => MonadLifxIO m where+    getSocket :: m Socket+    getSource :: m Word32+    getTimeout :: m Int+    incrementCounter :: m ()+    getCounter :: m Word8+    lifxThrowIO :: LifxError -> m a+    handleOldMessage ::+        -- | expected counter value+        Word8 ->+        -- | actual counter value+        Word8 ->+        -- | packet type+        Word16 ->+        -- | payload+        BL.ByteString ->+        m ()+    handleOldMessage _ _ _ _ = pure ()++instance MonadIO m => MonadLifxIO (LifxT m) where+    getSocket = LifxT $ asks fst3+    getSource = LifxT $ asks snd3+    getTimeout = LifxT $ asks thd3+    incrementCounter = LifxT $ modify succ'+    getCounter = LifxT $ gets id+    lifxThrowIO = LifxT . throwError++newtype LifxT m a = LifxT+    { unwrap ::+        StateT+            Word8+            ( ReaderT+                (Socket, Word32, Int)+                ( ExceptT+                    LifxError+                    m+                )+            )+            a+    }+    deriving newtype+        ( Functor+        , Applicative+        , Monad+        , MonadIO+        )++{- Util -}++-- | Safe, wraparound variant of 'succ'.+succ' :: (Eq a, Bounded a, Enum a) => a -> a+succ' e+    | e == maxBound = minBound+    | otherwise = succ e

@@ -0,0 +1,107 @@+-- TODO remove when `OverloadedRecordUpdate` is fully implemented (and simplify some nested updates) - hopefully 9.4+{-# OPTIONS_GHC -Wno-ambiguous-fields #-}++-- | Rather than interacting with any bulbs, simulate interactions by printing to a terminal.+module Lifx.Lan.Mock.Terminal (Mock, MockError, runMock, runMockFull, MockState (MockState)) where++import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Data.Bifunctor+import Data.Colour.RGBSpace+import Data.Colour.SRGB+import Data.Foldable++import Data.Map (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text.IO qualified as T+import System.Console.ANSI hiding (SetColor)++import Lifx.Internal.Colour+import Lifx.Lan++newtype Mock a = Mock (StateT (Map Device MockState) (ReaderT [Device] (ExceptT MockError IO)) a)+    deriving newtype+        ( Functor+        , Applicative+        , Monad+        , MonadIO+        , MonadError MockError+        , MonadReader [Device]+        , MonadState (Map Device MockState)+        )++data MockState = MockState+    { light :: LightState+    , service :: Maybe StateService+    , hostFirmware :: Maybe StateHostFirmware+    , version :: Maybe StateVersion+    }++-- TODO this seems like a GHC bug+dotLabel :: LightState -> Text+-- dotLabel = (.label)+dotLabel = \LightState{..} -> label++{- | Run a LIFX action by mocking effects in a terminal.++Note that sending some messages (e.g. 'GetVersion') will throw exceptions, since the necessary state isn't specified.+See `runMockFull` for more control.+-}+runMock :: [(Device, Text)] -> Mock a -> IO (Either MockError a)+runMock = runMockFull . fmap (second \t -> MockState (LightState (HSBK 0 0 0 0) 1 t) Nothing Nothing Nothing)++-- | More general version of `runMock`, which allows specifying extra information about devices.+runMockFull :: [(Device, MockState)] -> Mock a -> IO (Either MockError a)+runMockFull ds (Mock x) =+    runExceptT+        . flip+            runReaderT+            (fst <$> ds)+        . flip+            evalStateT+            (Map.fromList ds)+        $ x++data MockError+    = MockNoSuchDevice Device+    | MockProductLookupError ProductLookupError+    | MockDataNotProvided+    deriving (Show)++instance MonadLifx Mock where+    type MonadLifxError Mock = MockError+    lifxThrow = throwError+    liftProductLookupError = MockProductLookupError++    sendMessage d m = do+        s <- lookupDevice d+        r <- case m of+            GetService -> whenProvided s.service+            GetHostFirmware -> whenProvided s.hostFirmware+            GetPower -> pure $ StatePower s.light.power+            SetPower (convertPower -> power) -> modify $ Map.insert d s{light = s.light{power}}+            GetVersion -> whenProvided s.version+            GetColor -> pure s.light+            SetColor hsbk _t -> modify $ Map.insert d s{light = s.light{hsbk}}+            SetLightPower (convertPower -> power) _t -> modify $ Map.insert d s{light = s.light{power}}+        ds <- ask+        for_ ds \d' -> do+            s' <- lookupDevice d'+            liftIO do+                setSGR $ mkSGR s'.light+                T.putStr $ dotLabel s'.light+                setSGR []+        liftIO $ putStrLn ""+        pure r+      where+        lookupDevice = maybe (lifxThrow $ MockNoSuchDevice d) pure <=< gets . Map.lookup+        whenProvided = maybe (throwError MockDataNotProvided) pure+        convertPower = fromIntegral . fromEnum+        mkSGR s =+            if s.power /= 0+                then [SetRGBColor Background . uncurryRGB sRGB $ hsbkToRgb s.hsbk]+                else []+    broadcastMessage m = ask >>= traverse \d -> (d,) <$> sendMessage d m+    discoverDevices x = maybe id take x <$> ask