diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/lifx-lan.cabal b/lifx-lan.cabal --- a/lifx-lan.cabal +++ b/lifx-lan.cabal @@ -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 diff --git a/src/Lifx/Internal/Colour.hs b/src/Lifx/Internal/Colour.hs new file mode 100644 --- /dev/null +++ b/src/Lifx/Internal/Colour.hs @@ -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 diff --git a/src/Lifx/Internal/ProductInfo.hs b/src/Lifx/Internal/ProductInfo.hs --- a/src/Lifx/Internal/ProductInfo.hs +++ b/src/Lifx/Internal/ProductInfo.hs @@ -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 diff --git a/src/Lifx/Internal/ProductInfoMap.hs b/src/Lifx/Internal/ProductInfoMap.hs --- a/src/Lifx/Internal/ProductInfoMap.hs +++ b/src/Lifx/Internal/ProductInfoMap.hs @@ -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 - } diff --git a/src/Lifx/Lan.hs b/src/Lifx/Lan.hs --- a/src/Lifx/Lan.hs +++ b/src/Lifx/Lan.hs @@ -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 diff --git a/src/Lifx/Lan/Internal.hs b/src/Lifx/Lan/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Lifx/Lan/Internal.hs @@ -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 diff --git a/src/Lifx/Lan/Mock/Terminal.hs b/src/Lifx/Lan/Mock/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Lifx/Lan/Mock/Terminal.hs @@ -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