lifx-lan 0.2.0 → 0.3.0

raw patch · 3 files changed

+204/−43 lines, 3 filesdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−6
• lifx-lan.cabal +2/−1
• src/Lifx/Lan.hs +196/−36

@@ -1,11 +1,11 @@ # Revision history for lifx-lan -## 0.2.0 -- 2021-06-18--* Enable querying state (colour or power level).+## 0.3.0 -- 2021-06-19+- Implement message broadcasting and device discovery. -    * Various breaking changes to enable this.+## 0.2.0 -- 2021-06-18+- Enable querying state (colour or power level).+    - Various breaking changes to enable this.  ## 0.1.0.2--* Basic. Only supports setting power and colour.+- Basic. Only supports setting power and colour.

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               lifx-lan-version:            0.2.0+version:            0.3.0 license:            BSD-3-Clause license-file:       LICENSE author:             George Thomas@@ -30,6 +30,7 @@         safe ^>= 0.3.19,         text ^>= 1.2.3,         time ^>= 1.9.3,+        transformers ^>= 0.5.6,     default-language: Haskell2010     default-extensions:         AllowAmbiguousTypes

@@ -1,5 +1,7 @@ module Lifx.Lan (     sendMessage,+    broadcastMessage,+    discoverDevices,     Message (..),     HSBK (..),     Duration (..),@@ -12,6 +14,8 @@      -- * Responses     LightState (..),+    StateService (..),+    Service (..),     StatePower (..),      -- * Low-level@@ -21,8 +25,10 @@  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.Trans.Maybe import Data.Binary import Data.Binary.Get hiding (label) import Data.Binary.Put@@ -30,7 +36,15 @@ 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.NonEmpty (NonEmpty)+import Data.Map (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Time import Data.Tuple.Extra import GHC.Generics (Generic) import GHC.IO.Exception@@ -45,40 +59,75 @@ lifxPort = 56700  sendMessage :: MonadLifx m => HostAddress -> Message a -> m a-sendMessage lightAddr msg = do-    sock <- getSocket-    source <- getSource+sendMessage receiver msg = do     timeoutDuration <- getTimeout-    counter <- getCounter     incrementCounter-    let receiver = SockAddrInet lifxPort lightAddr-    void . liftIO $-        sendTo-            sock-            (BL.toStrict $ encodeMessage False counter source msg)-            receiver-    getResponse' msg & either pure \(expectedPacketType, messageSize, getBody) -> do-        (bs, sender) <--            throwEither . liftIO . fmap (maybeToEither RecvTimeout)-                . timeout timeoutDuration-                . recvFrom sock-                $ headerSize + messageSize-        when (sender /= receiver) $ lifxThrow $ WrongSender receiver sender-        case runGetOrFail get $ BL.fromStrict bs of-            Left e -> throwDecodeFailure e-            Right (bs', _, Header{packetType, sequenceCounter}) -> do-                when (sequenceCounter /= counter) $ lifxThrow $ WrongSequenceNumber counter sequenceCounter-                when (packetType /= expectedPacketType) $ lifxThrow $ WrongPacketType packetType expectedPacketType-                case runGetOrFail getBody bs' of-                    Left e -> throwDecodeFailure e-                    Right (_, _, res) -> pure res+    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-    throwDecodeFailure (bs, bo, e) = lifxThrow $ DecodeFailure (BL.toStrict bs) bo e     throwEither x =         x >>= \case             Left e -> lifxThrow e             Right r -> pure r +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++{- | If an integer argument is given, wait until we have responses from 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+  where+    f _addr StateService{..} = do+        checkPort $ fromIntegral port+        pure . guard $ service == ServiceUDP+    p = nDevices <&> \n -> (>= n) . length+ data HSBK = HSBK     { hue :: Word16     , saturation :: Word16@@ -90,6 +139,7 @@     deriving (Eq, Ord, Show, Generic)  data Message a where+    GetService :: Message StateService     GetPower :: Message StatePower     SetPower :: Bool -> Message ()     GetColor :: Message LightState@@ -99,6 +149,18 @@ deriving instance (Ord (Message a)) deriving instance (Show (Message a)) +data Service+    = ServiceUDP+    | ServiceReserved1+    | ServiceReserved2+    | ServiceReserved3+    | ServiceReserved4+    deriving (Eq, Ord, Show, Generic)+data StateService = StateService+    { service :: Service+    , port :: Word32+    }+    deriving (Eq, Ord, Show, Generic) newtype StatePower = StatePower     { power :: Word16     }@@ -113,9 +175,11 @@ 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 SockAddr SockAddr -- expected, then actual-    | WrongSequenceNumber Word8 Word8 -- expected, then actual+    | WrongSender HostAddress HostAddress -- expected, then actual+    | UnexpectedSockAddrType SockAddr+    | UnexpectedPort PortNumber     deriving (Eq, Ord, Show, Generic)  {- Message responses -}@@ -125,6 +189,18 @@  instance Response () where     getResponse = Left ()+instance Response StateService where+    getResponse = Right $ (3,5,) do+        service <-+            getWord8 >>= \case+                1 -> pure ServiceUDP+                2 -> pure ServiceReserved1+                3 -> pure ServiceReserved2+                4 -> pure ServiceReserved3+                5 -> pure ServiceReserved4+                n -> fail $ "unknown service: " <> show n+        port <- getWord32le+        pure StateService{..} instance Response LightState where     getResponse = Right $ (107,52,) do         hsbk <- HSBK <$> getWord16le <*> getWord16le <*> getWord16le <*> getWord16le@@ -141,6 +217,7 @@ -- | 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@@ -170,12 +247,12 @@         , MonadIO         ) -{- | Note that this throws 'LifxError's as 'IOException's, and sets timeout to 1 second.+{- | Note that this throws 'LifxError's as 'IOException's, and sets timeout to 5 seconds. Use 'runLifxT' for more control. -} runLifx :: Lifx a -> IO a runLifx m =-    runLifxT 1_000_000 m >>= \case+    runLifxT 5_000_000 m >>= \case         Left e ->             ioError                 IOError@@ -191,6 +268,7 @@ runLifxT :: MonadIO m => 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     liftIO . bind sock $ SockAddrInet defaultPort 0     source <- randomIO     runExceptT $ runReaderT (evalStateT x 0) (sock, source, timeoutDuration)@@ -202,6 +280,17 @@     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 () instance MonadIO m => MonadLifx (LifxT m) where     getSocket = LifxT $ asks fst3     getSource = LifxT $ asks snd3@@ -209,6 +298,20 @@     incrementCounter = LifxT $ modify succ'     getCounter = LifxT $ gets id     lifxThrow = LifxT . throwError+instance MonadLifx m => MonadLifx (MaybeT m) where+    getSocket = lift getSocket+    getSource = lift getSource+    getTimeout = lift getTimeout+    incrementCounter = lift incrementCounter+    getCounter = lift getCounter+    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+    lifxThrow = lift . lifxThrow instance MonadLifx m => MonadLifx (StateT s m) where     getSocket = lift getSocket     getSource = lift getSource@@ -226,9 +329,9 @@  {- Low level -} -encodeMessage :: Bool -> Word8 -> Word32 -> Message a -> BL.ByteString-encodeMessage ackRequired sequenceCounter source msg =-    runPut $ put (messageHeader ackRequired sequenceCounter source msg) >> putMessagePayload msg+encodeMessage :: Bool -> Bool -> Word8 -> Word32 -> Message a -> BL.ByteString+encodeMessage tagged ackRequired sequenceCounter source msg =+    runPut $ put (messageHeader tagged ackRequired sequenceCounter source msg) >> putMessagePayload msg  -- | https://lan.developer.lifx.com/docs/encoding-a-packet data Header = Header@@ -288,8 +391,14 @@       where         bitIf b n = if b then bit n else zeroBits -messageHeader :: Bool -> Word8 -> Word32 -> Message a -> Header-messageHeader ackRequired sequenceCounter source = \case+messageHeader :: Bool -> Bool -> Word8 -> Word32 -> Message a -> Header+messageHeader tagged ackRequired sequenceCounter source = \case+    GetService{} ->+        Header+            { size = headerSize+            , packetType = 2+            , ..+            }     GetPower{} ->         Header             { size = headerSize@@ -323,13 +432,13 @@   where     target = 0 :: Word64     protocol = 1024 :: Word16-    tagged = True     addressable = True     origin = 0 :: Word8     resRequired = False  putMessagePayload :: Message a -> Put putMessagePayload = \case+    GetService -> mempty     GetPower -> mempty     SetPower b ->         putWord16le if b then maxBound else minBound@@ -355,3 +464,54 @@  headerSize :: Num a => a headerSize = 36++-- | For use with 'timeout', 'threadDelay' etc.+nominalDiffTimeToMicroSeconds :: NominalDiffTime -> Int+nominalDiffTimeToMicroSeconds t = fromInteger $ p `div` 1_000_000+  where+    MkFixed p = 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++-- 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+    counter <- getCounter+    case runGetOrFail 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+                    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' tagged receiver msg = do+    sock <- getSocket+    counter <- getCounter+    source <- getSource+    void . liftIO $+        sendTo+            sock+            (BL.toStrict $ encodeMessage tagged False counter source msg)+            (SockAddrInet lifxPort receiver)+hostAddressFromSock :: MonadLifx 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))+receiveMessage t messageSize = do+    sock <- getSocket+    liftIO+        . timeout t+        . recvFrom sock+        $ headerSize + messageSize