diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/lifx-lan.cabal b/lifx-lan.cabal --- a/lifx-lan.cabal +++ b/lifx-lan.cabal @@ -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 diff --git a/src/Lifx/Lan.hs b/src/Lifx/Lan.hs --- a/src/Lifx/Lan.hs +++ b/src/Lifx/Lan.hs @@ -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 + +-}