{- |
@
-- 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_)

import Lifx.Lan

-- | 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,
    deviceFromAddress,
    Message (..),
    HSBK (..),
    Lifx,
    runLifx,
    LifxT,
    runLifxT,
    LifxError (..),
    ProductLookupError (..),
    MonadLifx (..),
    sendMessageAndWait,

    -- * Responses
    StateService (..),
    Service (..),
    StateHostFirmware (..),
    StatePower (..),
    StateVersion (..),
    StateGroup (..),
    LightState (..),

    -- ** Product info
    getProductInfo,
    Product (..),
    Features (..),

    -- * 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 (..),
) where

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 Control.Monad.Writer
import Data.Composition
import Data.Either.Extra
import Data.Fixed
import Data.Foldable
import Data.Functor
import Data.Maybe
import Data.Time
import Data.Time.Clock.POSIX
import Data.Word
import Network.Socket
import System.IO.Error

import Data.Binary (Binary)
import Data.Binary qualified as Binary
import Data.Binary.Get (
    Get,
    getByteString,
    getWord16le,
    getWord32le,
    getWord64be,
    getWord64le,
    getWord8,
    runGetOrFail,
    skip,
 )
import Data.Binary.Put (
    Put,
    putByteString,
    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.Text (Text)
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Data.Text.Encoding.Error (UnicodeException (DecodeError))
import GHC.Generics (Generic)
import Network.Socket.ByteString (recvFrom, sendTo)
import System.Random (randomIO)
import System.Timeout (timeout)

import Lifx.Internal.Product
import Lifx.Internal.ProductInfoMap
import Lifx.Lan.Internal

{- Device -}

{- |
>>> deviceFromAddress (192, 168, 0, 1)
192.168.0.1

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 :: (Word8, Word8, Word8, Word8) -> Device
deviceFromAddress = HostAddress -> Device
Device (HostAddress -> Device)
-> ((Word8, Word8, Word8, Word8) -> HostAddress)
-> (Word8, Word8, Word8, Word8)
-> Device
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8, Word8, Word8, Word8) -> HostAddress
tupleToHostAddress

deviceAddress :: Device -> HostAddress
deviceAddress :: Device -> HostAddress
deviceAddress = (.unwrap)

{- Core -}

lifxPort :: PortNumber
lifxPort :: PortNumber
lifxPort = PortNumber
56700

-- | 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#gethostfirmware---packet-14
    GetHostFirmware :: Message StateHostFirmware
    -- | 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/changing-a-device#setlabel---packet-24
    SetLabel :: Text -> Message ()
    -- | https://lan.developer.lifx.com/docs/querying-the-device-for-data#getversion---packet-32
    GetVersion :: Message StateVersion
    -- | https://lan.developer.lifx.com/docs/querying-the-device-for-data#getgroup---packet-51
    GetGroup :: Message StateGroup
    -- | https://lan.developer.lifx.com/docs/querying-the-device-for-data#getcolor---packet-101
    GetColor :: Message LightState
    -- | 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
    | ServiceReserved2
    | ServiceReserved3
    | ServiceReserved4
    deriving (Service -> Service -> Bool
(Service -> Service -> Bool)
-> (Service -> Service -> Bool) -> Eq Service
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Service -> Service -> Bool
== :: Service -> Service -> Bool
$c/= :: Service -> Service -> Bool
/= :: Service -> Service -> Bool
Eq, Eq Service
Eq Service =>
(Service -> Service -> Ordering)
-> (Service -> Service -> Bool)
-> (Service -> Service -> Bool)
-> (Service -> Service -> Bool)
-> (Service -> Service -> Bool)
-> (Service -> Service -> Service)
-> (Service -> Service -> Service)
-> Ord Service
Service -> Service -> Bool
Service -> Service -> Ordering
Service -> Service -> Service
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Service -> Service -> Ordering
compare :: Service -> Service -> Ordering
$c< :: Service -> Service -> Bool
< :: Service -> Service -> Bool
$c<= :: Service -> Service -> Bool
<= :: Service -> Service -> Bool
$c> :: Service -> Service -> Bool
> :: Service -> Service -> Bool
$c>= :: Service -> Service -> Bool
>= :: Service -> Service -> Bool
$cmax :: Service -> Service -> Service
max :: Service -> Service -> Service
$cmin :: Service -> Service -> Service
min :: Service -> Service -> Service
Ord, Int -> Service -> ShowS
[Service] -> ShowS
Service -> String
(Int -> Service -> ShowS)
-> (Service -> String) -> ([Service] -> ShowS) -> Show Service
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Service -> ShowS
showsPrec :: Int -> Service -> ShowS
$cshow :: Service -> String
show :: Service -> String
$cshowList :: [Service] -> ShowS
showList :: [Service] -> ShowS
Show, (forall x. Service -> Rep Service x)
-> (forall x. Rep Service x -> Service) -> Generic Service
forall x. Rep Service x -> Service
forall x. Service -> Rep Service x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Service -> Rep Service x
from :: forall x. Service -> Rep Service x
$cto :: forall x. Rep Service x -> Service
to :: forall x. Rep Service x -> Service
Generic)

-- | https://lan.developer.lifx.com/docs/information-messages#stateservice---packet-3
data StateService = StateService
    { StateService -> Service
service :: Service
    , StateService -> PortNumber
port :: PortNumber
    }
    deriving (StateService -> StateService -> Bool
(StateService -> StateService -> Bool)
-> (StateService -> StateService -> Bool) -> Eq StateService
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StateService -> StateService -> Bool
== :: StateService -> StateService -> Bool
$c/= :: StateService -> StateService -> Bool
/= :: StateService -> StateService -> Bool
Eq, Eq StateService
Eq StateService =>
(StateService -> StateService -> Ordering)
-> (StateService -> StateService -> Bool)
-> (StateService -> StateService -> Bool)
-> (StateService -> StateService -> Bool)
-> (StateService -> StateService -> Bool)
-> (StateService -> StateService -> StateService)
-> (StateService -> StateService -> StateService)
-> Ord StateService
StateService -> StateService -> Bool
StateService -> StateService -> Ordering
StateService -> StateService -> StateService
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StateService -> StateService -> Ordering
compare :: StateService -> StateService -> Ordering
$c< :: StateService -> StateService -> Bool
< :: StateService -> StateService -> Bool
$c<= :: StateService -> StateService -> Bool
<= :: StateService -> StateService -> Bool
$c> :: StateService -> StateService -> Bool
> :: StateService -> StateService -> Bool
$c>= :: StateService -> StateService -> Bool
>= :: StateService -> StateService -> Bool
$cmax :: StateService -> StateService -> StateService
max :: StateService -> StateService -> StateService
$cmin :: StateService -> StateService -> StateService
min :: StateService -> StateService -> StateService
Ord, Int -> StateService -> ShowS
[StateService] -> ShowS
StateService -> String
(Int -> StateService -> ShowS)
-> (StateService -> String)
-> ([StateService] -> ShowS)
-> Show StateService
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StateService -> ShowS
showsPrec :: Int -> StateService -> ShowS
$cshow :: StateService -> String
show :: StateService -> String
$cshowList :: [StateService] -> ShowS
showList :: [StateService] -> ShowS
Show, (forall x. StateService -> Rep StateService x)
-> (forall x. Rep StateService x -> StateService)
-> Generic StateService
forall x. Rep StateService x -> StateService
forall x. StateService -> Rep StateService x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StateService -> Rep StateService x
from :: forall x. StateService -> Rep StateService x
$cto :: forall x. Rep StateService x -> StateService
to :: forall x. Rep StateService x -> StateService
Generic)

-- | https://lan.developer.lifx.com/docs/information-messages#statehostfirmware---packet-15
data StateHostFirmware = StateHostFirmware
    { StateHostFirmware -> Word64
build :: Word64
    -- ^ The timestamp of the firmware that is on the device as an epoch
    , StateHostFirmware -> Word16
versionMinor :: Word16
    -- ^ The minor component of the firmware version
    , StateHostFirmware -> Word16
versionMajor :: Word16
    -- ^ The major component of the firmware version
    }
    deriving (StateHostFirmware -> StateHostFirmware -> Bool
(StateHostFirmware -> StateHostFirmware -> Bool)
-> (StateHostFirmware -> StateHostFirmware -> Bool)
-> Eq StateHostFirmware
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StateHostFirmware -> StateHostFirmware -> Bool
== :: StateHostFirmware -> StateHostFirmware -> Bool
$c/= :: StateHostFirmware -> StateHostFirmware -> Bool
/= :: StateHostFirmware -> StateHostFirmware -> Bool
Eq, Eq StateHostFirmware
Eq StateHostFirmware =>
(StateHostFirmware -> StateHostFirmware -> Ordering)
-> (StateHostFirmware -> StateHostFirmware -> Bool)
-> (StateHostFirmware -> StateHostFirmware -> Bool)
-> (StateHostFirmware -> StateHostFirmware -> Bool)
-> (StateHostFirmware -> StateHostFirmware -> Bool)
-> (StateHostFirmware -> StateHostFirmware -> StateHostFirmware)
-> (StateHostFirmware -> StateHostFirmware -> StateHostFirmware)
-> Ord StateHostFirmware
StateHostFirmware -> StateHostFirmware -> Bool
StateHostFirmware -> StateHostFirmware -> Ordering
StateHostFirmware -> StateHostFirmware -> StateHostFirmware
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StateHostFirmware -> StateHostFirmware -> Ordering
compare :: StateHostFirmware -> StateHostFirmware -> Ordering
$c< :: StateHostFirmware -> StateHostFirmware -> Bool
< :: StateHostFirmware -> StateHostFirmware -> Bool
$c<= :: StateHostFirmware -> StateHostFirmware -> Bool
<= :: StateHostFirmware -> StateHostFirmware -> Bool
$c> :: StateHostFirmware -> StateHostFirmware -> Bool
> :: StateHostFirmware -> StateHostFirmware -> Bool
$c>= :: StateHostFirmware -> StateHostFirmware -> Bool
>= :: StateHostFirmware -> StateHostFirmware -> Bool
$cmax :: StateHostFirmware -> StateHostFirmware -> StateHostFirmware
max :: StateHostFirmware -> StateHostFirmware -> StateHostFirmware
$cmin :: StateHostFirmware -> StateHostFirmware -> StateHostFirmware
min :: StateHostFirmware -> StateHostFirmware -> StateHostFirmware
Ord, Int -> StateHostFirmware -> ShowS
[StateHostFirmware] -> ShowS
StateHostFirmware -> String
(Int -> StateHostFirmware -> ShowS)
-> (StateHostFirmware -> String)
-> ([StateHostFirmware] -> ShowS)
-> Show StateHostFirmware
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StateHostFirmware -> ShowS
showsPrec :: Int -> StateHostFirmware -> ShowS
$cshow :: StateHostFirmware -> String
show :: StateHostFirmware -> String
$cshowList :: [StateHostFirmware] -> ShowS
showList :: [StateHostFirmware] -> ShowS
Show, (forall x. StateHostFirmware -> Rep StateHostFirmware x)
-> (forall x. Rep StateHostFirmware x -> StateHostFirmware)
-> Generic StateHostFirmware
forall x. Rep StateHostFirmware x -> StateHostFirmware
forall x. StateHostFirmware -> Rep StateHostFirmware x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StateHostFirmware -> Rep StateHostFirmware x
from :: forall x. StateHostFirmware -> Rep StateHostFirmware x
$cto :: forall x. Rep StateHostFirmware x -> StateHostFirmware
to :: forall x. Rep StateHostFirmware x -> StateHostFirmware
Generic)

-- | https://lan.developer.lifx.com/docs/information-messages#statepower---packet-22
newtype StatePower = StatePower
    { StatePower -> Word16
power :: Word16
    }
    deriving (StatePower -> StatePower -> Bool
(StatePower -> StatePower -> Bool)
-> (StatePower -> StatePower -> Bool) -> Eq StatePower
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StatePower -> StatePower -> Bool
== :: StatePower -> StatePower -> Bool
$c/= :: StatePower -> StatePower -> Bool
/= :: StatePower -> StatePower -> Bool
Eq, Eq StatePower
Eq StatePower =>
(StatePower -> StatePower -> Ordering)
-> (StatePower -> StatePower -> Bool)
-> (StatePower -> StatePower -> Bool)
-> (StatePower -> StatePower -> Bool)
-> (StatePower -> StatePower -> Bool)
-> (StatePower -> StatePower -> StatePower)
-> (StatePower -> StatePower -> StatePower)
-> Ord StatePower
StatePower -> StatePower -> Bool
StatePower -> StatePower -> Ordering
StatePower -> StatePower -> StatePower
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StatePower -> StatePower -> Ordering
compare :: StatePower -> StatePower -> Ordering
$c< :: StatePower -> StatePower -> Bool
< :: StatePower -> StatePower -> Bool
$c<= :: StatePower -> StatePower -> Bool
<= :: StatePower -> StatePower -> Bool
$c> :: StatePower -> StatePower -> Bool
> :: StatePower -> StatePower -> Bool
$c>= :: StatePower -> StatePower -> Bool
>= :: StatePower -> StatePower -> Bool
$cmax :: StatePower -> StatePower -> StatePower
max :: StatePower -> StatePower -> StatePower
$cmin :: StatePower -> StatePower -> StatePower
min :: StatePower -> StatePower -> StatePower
Ord, Int -> StatePower -> ShowS
[StatePower] -> ShowS
StatePower -> String
(Int -> StatePower -> ShowS)
-> (StatePower -> String)
-> ([StatePower] -> ShowS)
-> Show StatePower
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StatePower -> ShowS
showsPrec :: Int -> StatePower -> ShowS
$cshow :: StatePower -> String
show :: StatePower -> String
$cshowList :: [StatePower] -> ShowS
showList :: [StatePower] -> ShowS
Show, (forall x. StatePower -> Rep StatePower x)
-> (forall x. Rep StatePower x -> StatePower) -> Generic StatePower
forall x. Rep StatePower x -> StatePower
forall x. StatePower -> Rep StatePower x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StatePower -> Rep StatePower x
from :: forall x. StatePower -> Rep StatePower x
$cto :: forall x. Rep StatePower x -> StatePower
to :: forall x. Rep StatePower x -> StatePower
Generic)

-- | https://lan.developer.lifx.com/docs/information-messages#stateversion---packet-33
data StateVersion = StateVersion
    { StateVersion -> HostAddress
vendor :: Word32
    -- ^ For LIFX products this value is 1. There may be devices in the future with a different vendor value.
    , StateVersion -> HostAddress
product :: Word32
    -- ^ The product id of the device. The available products can be found in our Product Registry.
    }
    deriving (StateVersion -> StateVersion -> Bool
(StateVersion -> StateVersion -> Bool)
-> (StateVersion -> StateVersion -> Bool) -> Eq StateVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StateVersion -> StateVersion -> Bool
== :: StateVersion -> StateVersion -> Bool
$c/= :: StateVersion -> StateVersion -> Bool
/= :: StateVersion -> StateVersion -> Bool
Eq, Eq StateVersion
Eq StateVersion =>
(StateVersion -> StateVersion -> Ordering)
-> (StateVersion -> StateVersion -> Bool)
-> (StateVersion -> StateVersion -> Bool)
-> (StateVersion -> StateVersion -> Bool)
-> (StateVersion -> StateVersion -> Bool)
-> (StateVersion -> StateVersion -> StateVersion)
-> (StateVersion -> StateVersion -> StateVersion)
-> Ord StateVersion
StateVersion -> StateVersion -> Bool
StateVersion -> StateVersion -> Ordering
StateVersion -> StateVersion -> StateVersion
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StateVersion -> StateVersion -> Ordering
compare :: StateVersion -> StateVersion -> Ordering
$c< :: StateVersion -> StateVersion -> Bool
< :: StateVersion -> StateVersion -> Bool
$c<= :: StateVersion -> StateVersion -> Bool
<= :: StateVersion -> StateVersion -> Bool
$c> :: StateVersion -> StateVersion -> Bool
> :: StateVersion -> StateVersion -> Bool
$c>= :: StateVersion -> StateVersion -> Bool
>= :: StateVersion -> StateVersion -> Bool
$cmax :: StateVersion -> StateVersion -> StateVersion
max :: StateVersion -> StateVersion -> StateVersion
$cmin :: StateVersion -> StateVersion -> StateVersion
min :: StateVersion -> StateVersion -> StateVersion
Ord, Int -> StateVersion -> ShowS
[StateVersion] -> ShowS
StateVersion -> String
(Int -> StateVersion -> ShowS)
-> (StateVersion -> String)
-> ([StateVersion] -> ShowS)
-> Show StateVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StateVersion -> ShowS
showsPrec :: Int -> StateVersion -> ShowS
$cshow :: StateVersion -> String
show :: StateVersion -> String
$cshowList :: [StateVersion] -> ShowS
showList :: [StateVersion] -> ShowS
Show, (forall x. StateVersion -> Rep StateVersion x)
-> (forall x. Rep StateVersion x -> StateVersion)
-> Generic StateVersion
forall x. Rep StateVersion x -> StateVersion
forall x. StateVersion -> Rep StateVersion x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StateVersion -> Rep StateVersion x
from :: forall x. StateVersion -> Rep StateVersion x
$cto :: forall x. Rep StateVersion x -> StateVersion
to :: forall x. Rep StateVersion x -> StateVersion
Generic)

-- | https://lan.developer.lifx.com/docs/information-messages#stategroup---packet-53
data StateGroup = StateGroup
    { StateGroup -> ByteString
group :: BS.ByteString
    -- ^ The unique identifier of this group as a UUID.
    , StateGroup -> Text
label :: Text
    -- ^ The name assigned to this group.
    , StateGroup -> NominalDiffTime
updatedAt :: POSIXTime
    -- ^ When this group was set on the device.
    }
    deriving (StateGroup -> StateGroup -> Bool
(StateGroup -> StateGroup -> Bool)
-> (StateGroup -> StateGroup -> Bool) -> Eq StateGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StateGroup -> StateGroup -> Bool
== :: StateGroup -> StateGroup -> Bool
$c/= :: StateGroup -> StateGroup -> Bool
/= :: StateGroup -> StateGroup -> Bool
Eq, Eq StateGroup
Eq StateGroup =>
(StateGroup -> StateGroup -> Ordering)
-> (StateGroup -> StateGroup -> Bool)
-> (StateGroup -> StateGroup -> Bool)
-> (StateGroup -> StateGroup -> Bool)
-> (StateGroup -> StateGroup -> Bool)
-> (StateGroup -> StateGroup -> StateGroup)
-> (StateGroup -> StateGroup -> StateGroup)
-> Ord StateGroup
StateGroup -> StateGroup -> Bool
StateGroup -> StateGroup -> Ordering
StateGroup -> StateGroup -> StateGroup
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StateGroup -> StateGroup -> Ordering
compare :: StateGroup -> StateGroup -> Ordering
$c< :: StateGroup -> StateGroup -> Bool
< :: StateGroup -> StateGroup -> Bool
$c<= :: StateGroup -> StateGroup -> Bool
<= :: StateGroup -> StateGroup -> Bool
$c> :: StateGroup -> StateGroup -> Bool
> :: StateGroup -> StateGroup -> Bool
$c>= :: StateGroup -> StateGroup -> Bool
>= :: StateGroup -> StateGroup -> Bool
$cmax :: StateGroup -> StateGroup -> StateGroup
max :: StateGroup -> StateGroup -> StateGroup
$cmin :: StateGroup -> StateGroup -> StateGroup
min :: StateGroup -> StateGroup -> StateGroup
Ord, Int -> StateGroup -> ShowS
[StateGroup] -> ShowS
StateGroup -> String
(Int -> StateGroup -> ShowS)
-> (StateGroup -> String)
-> ([StateGroup] -> ShowS)
-> Show StateGroup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StateGroup -> ShowS
showsPrec :: Int -> StateGroup -> ShowS
$cshow :: StateGroup -> String
show :: StateGroup -> String
$cshowList :: [StateGroup] -> ShowS
showList :: [StateGroup] -> ShowS
Show, (forall x. StateGroup -> Rep StateGroup x)
-> (forall x. Rep StateGroup x -> StateGroup) -> Generic StateGroup
forall x. Rep StateGroup x -> StateGroup
forall x. StateGroup -> Rep StateGroup x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StateGroup -> Rep StateGroup x
from :: forall x. StateGroup -> Rep StateGroup x
$cto :: forall x. Rep StateGroup x -> StateGroup
to :: forall x. Rep StateGroup x -> StateGroup
Generic)

-- | https://lan.developer.lifx.com/docs/information-messages#lightstate---packet-107
data LightState = LightState
    { LightState -> HSBK
hsbk :: HSBK
    , LightState -> Word16
power :: Word16
    , LightState -> Text
label :: Text
    }
    deriving (LightState -> LightState -> Bool
(LightState -> LightState -> Bool)
-> (LightState -> LightState -> Bool) -> Eq LightState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LightState -> LightState -> Bool
== :: LightState -> LightState -> Bool
$c/= :: LightState -> LightState -> Bool
/= :: LightState -> LightState -> Bool
Eq, Eq LightState
Eq LightState =>
(LightState -> LightState -> Ordering)
-> (LightState -> LightState -> Bool)
-> (LightState -> LightState -> Bool)
-> (LightState -> LightState -> Bool)
-> (LightState -> LightState -> Bool)
-> (LightState -> LightState -> LightState)
-> (LightState -> LightState -> LightState)
-> Ord LightState
LightState -> LightState -> Bool
LightState -> LightState -> Ordering
LightState -> LightState -> LightState
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LightState -> LightState -> Ordering
compare :: LightState -> LightState -> Ordering
$c< :: LightState -> LightState -> Bool
< :: LightState -> LightState -> Bool
$c<= :: LightState -> LightState -> Bool
<= :: LightState -> LightState -> Bool
$c> :: LightState -> LightState -> Bool
> :: LightState -> LightState -> Bool
$c>= :: LightState -> LightState -> Bool
>= :: LightState -> LightState -> Bool
$cmax :: LightState -> LightState -> LightState
max :: LightState -> LightState -> LightState
$cmin :: LightState -> LightState -> LightState
min :: LightState -> LightState -> LightState
Ord, Int -> LightState -> ShowS
[LightState] -> ShowS
LightState -> String
(Int -> LightState -> ShowS)
-> (LightState -> String)
-> ([LightState] -> ShowS)
-> Show LightState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LightState -> ShowS
showsPrec :: Int -> LightState -> ShowS
$cshow :: LightState -> String
show :: LightState -> String
$cshowList :: [LightState] -> ShowS
showList :: [LightState] -> ShowS
Show, (forall x. LightState -> Rep LightState x)
-> (forall x. Rep LightState x -> LightState) -> Generic LightState
forall x. Rep LightState x -> LightState
forall x. LightState -> Rep LightState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LightState -> Rep LightState x
from :: forall x. LightState -> Rep LightState x
$cto :: forall x. Rep LightState x -> LightState
to :: forall x. Rep LightState x -> LightState
Generic)

{- Message responses -}

class MessageResult a where
    getSendResult :: (MonadLifxIO m) => Device -> m a
    default getSendResult :: (MonadLifxIO m, Response a) => Device -> m a
    getSendResult Device
receiver = m (Maybe a) -> m a
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a
untilJustM do
        Int
timeoutDuration <- m Int
forall (m :: * -> *). MonadLifxIO m => m Int
getTimeout
        (ByteString
bs, SockAddr
sender0) <- m (Either LifxError (ByteString, SockAddr))
-> m (ByteString, SockAddr)
forall {m :: * -> *} {b}.
MonadLifxIO m =>
m (Either LifxError b) -> m b
throwEither (m (Either LifxError (ByteString, SockAddr))
 -> m (ByteString, SockAddr))
-> m (Either LifxError (ByteString, SockAddr))
-> m (ByteString, SockAddr)
forall a b. (a -> b) -> a -> b
$ LifxError
-> Maybe (ByteString, SockAddr)
-> Either LifxError (ByteString, SockAddr)
forall a b. a -> Maybe b -> Either a b
maybeToEither LifxError
RecvTimeout (Maybe (ByteString, SockAddr)
 -> Either LifxError (ByteString, SockAddr))
-> m (Maybe (ByteString, SockAddr))
-> m (Either LifxError (ByteString, SockAddr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> m (Maybe (ByteString, SockAddr))
forall (m :: * -> *).
MonadLifxIO m =>
Int -> Int -> m (Maybe (ByteString, SockAddr))
receiveMessage Int
timeoutDuration (forall a. Response a => Int
messageSize @a)
        HostAddress
sender <- SockAddr -> m HostAddress
forall (m :: * -> *). MonadLifxIO m => SockAddr -> m HostAddress
hostAddressFromSock SockAddr
sender0
        Maybe a
res <- forall b (m :: * -> *).
(Response b, MonadLifxIO m) =>
ByteString -> m (Maybe b)
decodeMessage @a ByteString
bs
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
res Bool -> Bool -> Bool
&& HostAddress
sender HostAddress -> HostAddress -> Bool
forall a. Eq a => a -> a -> Bool
/= Device -> HostAddress
deviceAddress Device
receiver) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ LifxError -> m ()
forall a. LifxError -> m a
forall (m :: * -> *) a. MonadLifxIO m => LifxError -> m a
lifxThrowIO (LifxError -> m ()) -> LifxError -> m ()
forall a b. (a -> b) -> a -> b
$ Device -> HostAddress -> LifxError
WrongSender Device
receiver HostAddress
sender
        Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
res
      where
        throwEither :: m (Either LifxError b) -> m b
throwEither m (Either LifxError b)
x =
            m (Either LifxError b)
x m (Either LifxError b) -> (Either LifxError b -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left LifxError
e -> LifxError -> m b
forall a. LifxError -> m a
forall (m :: * -> *) a. MonadLifxIO m => LifxError -> m a
lifxThrowIO LifxError
e
                Right b
r -> b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r

    broadcastAndGetResult ::
        (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.
        Maybe (Map HostAddress (NonEmpty b) -> Bool) ->
        Message r ->
        m (Map Device (NonEmpty b))
    default broadcastAndGetResult ::
        (MonadLifxIO m, Response a) =>
        (HostAddress -> a -> m (Maybe b)) ->
        Maybe (Map HostAddress (NonEmpty b) -> Bool) ->
        Message r ->
        m (Map Device (NonEmpty b))
    broadcastAndGetResult HostAddress -> a -> m (Maybe b)
filter' Maybe (Map HostAddress (NonEmpty b) -> Bool)
maybeFinished Message r
msg = do
        Int
timeoutDuration <- m Int
forall (m :: * -> *). MonadLifxIO m => m Int
getTimeout
        Message r -> m ()
forall (m :: * -> *) r. MonadLifxIO m => Message r -> m ()
broadcast Message r
msg
        UTCTime
t0 <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        (Map HostAddress (NonEmpty b) -> Map Device (NonEmpty b))
-> m (Map HostAddress (NonEmpty b)) -> m (Map Device (NonEmpty b))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HostAddress -> Device)
-> Map HostAddress (NonEmpty b) -> Map Device (NonEmpty b)
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic HostAddress -> Device
Device) (m (Map HostAddress (NonEmpty b)) -> m (Map Device (NonEmpty b)))
-> (StateT (Map HostAddress (NonEmpty b)) m Bool
    -> m (Map HostAddress (NonEmpty b)))
-> StateT (Map HostAddress (NonEmpty b)) m Bool
-> m (Map Device (NonEmpty b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT (Map HostAddress (NonEmpty b)) m ()
 -> Map HostAddress (NonEmpty b)
 -> m (Map HostAddress (NonEmpty b)))
-> Map HostAddress (NonEmpty b)
-> StateT (Map HostAddress (NonEmpty b)) m ()
-> m (Map HostAddress (NonEmpty b))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Map HostAddress (NonEmpty b)) m ()
-> Map HostAddress (NonEmpty b) -> m (Map HostAddress (NonEmpty b))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT Map HostAddress (NonEmpty b)
forall k a. Map k a
Map.empty (StateT (Map HostAddress (NonEmpty b)) m ()
 -> m (Map HostAddress (NonEmpty b)))
-> (StateT (Map HostAddress (NonEmpty b)) m Bool
    -> StateT (Map HostAddress (NonEmpty b)) m ())
-> StateT (Map HostAddress (NonEmpty b)) m Bool
-> m (Map HostAddress (NonEmpty b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (Map HostAddress (NonEmpty b)) m Bool
-> StateT (Map HostAddress (NonEmpty b)) m ()
forall (m :: * -> *). Monad m => m Bool -> m ()
untilM (StateT (Map HostAddress (NonEmpty b)) m Bool
 -> m (Map Device (NonEmpty b)))
-> StateT (Map HostAddress (NonEmpty b)) m Bool
-> m (Map Device (NonEmpty b))
forall a b. (a -> b) -> a -> b
$
            ((Map HostAddress (NonEmpty b) -> Bool)
 -> StateT (Map HostAddress (NonEmpty b)) m Bool)
-> Maybe (Map HostAddress (NonEmpty b) -> Bool)
-> StateT (Map HostAddress (NonEmpty b)) m (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Map HostAddress (NonEmpty b) -> Bool)
-> StateT (Map HostAddress (NonEmpty b)) m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Maybe (Map HostAddress (NonEmpty b) -> Bool)
maybeFinished StateT (Map HostAddress (NonEmpty b)) m (Maybe Bool)
-> (Maybe Bool -> StateT (Map HostAddress (NonEmpty b)) m Bool)
-> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a b.
StateT (Map HostAddress (NonEmpty b)) m a
-> (a -> StateT (Map HostAddress (NonEmpty b)) m b)
-> StateT (Map HostAddress (NonEmpty b)) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just Bool
True -> Bool -> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a. a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                Maybe Bool
_ -> do
                    UTCTime
t <- IO UTCTime -> StateT (Map HostAddress (NonEmpty b)) m UTCTime
forall a. IO a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                    let timeLeft :: Int
timeLeft = Int
timeoutDuration Int -> Int -> Int
forall a. Num a => a -> a -> a
- forall f a r.
(HasResolution r, f ~ Fixed r, Integral a) =>
NominalDiffTime -> a
nominalDiffTimeToInt @Micro (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t UTCTime
t0)
                    if Int
timeLeft Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
                        then Bool -> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a. a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                        else
                            m (Maybe (ByteString, SockAddr))
-> StateT
     (Map HostAddress (NonEmpty b)) m (Maybe (ByteString, SockAddr))
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Int -> Int -> m (Maybe (ByteString, SockAddr))
forall (m :: * -> *).
MonadLifxIO m =>
Int -> Int -> m (Maybe (ByteString, SockAddr))
receiveMessage Int
timeLeft (forall a. Response a => Int
messageSize @a)) StateT
  (Map HostAddress (NonEmpty b)) m (Maybe (ByteString, SockAddr))
-> (Maybe (ByteString, SockAddr)
    -> StateT (Map HostAddress (NonEmpty b)) m Bool)
-> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a b.
StateT (Map HostAddress (NonEmpty b)) m a
-> (a -> StateT (Map HostAddress (NonEmpty b)) m b)
-> StateT (Map HostAddress (NonEmpty b)) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                Just (ByteString
bs, SockAddr
addr) -> do
                                    m (Maybe a) -> StateT (Map HostAddress (NonEmpty b)) m (Maybe a)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall b (m :: * -> *).
(Response b, MonadLifxIO m) =>
ByteString -> m (Maybe b)
decodeMessage @a ByteString
bs) StateT (Map HostAddress (NonEmpty b)) m (Maybe a)
-> (Maybe a -> StateT (Map HostAddress (NonEmpty b)) m Bool)
-> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a b.
StateT (Map HostAddress (NonEmpty b)) m a
-> (a -> StateT (Map HostAddress (NonEmpty b)) m b)
-> StateT (Map HostAddress (NonEmpty b)) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                        Just a
x -> do
                                            HostAddress
hostAddr <- m HostAddress
-> StateT (Map HostAddress (NonEmpty b)) m HostAddress
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m HostAddress
 -> StateT (Map HostAddress (NonEmpty b)) m HostAddress)
-> m HostAddress
-> StateT (Map HostAddress (NonEmpty b)) m HostAddress
forall a b. (a -> b) -> a -> b
$ SockAddr -> m HostAddress
forall (m :: * -> *). MonadLifxIO m => SockAddr -> m HostAddress
hostAddressFromSock SockAddr
addr
                                            m (Maybe b) -> StateT (Map HostAddress (NonEmpty b)) m (Maybe b)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (HostAddress -> a -> m (Maybe b)
filter' HostAddress
hostAddr a
x) StateT (Map HostAddress (NonEmpty b)) m (Maybe b)
-> (Maybe b -> StateT (Map HostAddress (NonEmpty b)) m Bool)
-> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a b.
StateT (Map HostAddress (NonEmpty b)) m a
-> (a -> StateT (Map HostAddress (NonEmpty b)) m b)
-> StateT (Map HostAddress (NonEmpty b)) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                                Just b
x' -> (Map HostAddress (NonEmpty b) -> Map HostAddress (NonEmpty b))
-> StateT (Map HostAddress (NonEmpty b)) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((NonEmpty b -> NonEmpty b -> NonEmpty b)
-> HostAddress
-> NonEmpty b
-> Map HostAddress (NonEmpty b)
-> Map HostAddress (NonEmpty b)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith NonEmpty b -> NonEmpty b -> NonEmpty b
forall a. Semigroup a => a -> a -> a
(<>) HostAddress
hostAddr (b -> NonEmpty b
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x')) StateT (Map HostAddress (NonEmpty b)) m ()
-> StateT (Map HostAddress (NonEmpty b)) m Bool
-> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a b.
StateT (Map HostAddress (NonEmpty b)) m a
-> StateT (Map HostAddress (NonEmpty b)) m b
-> StateT (Map HostAddress (NonEmpty b)) m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a. a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                                                Maybe b
Nothing -> Bool -> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a. a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                                        Maybe a
Nothing -> Bool -> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a. a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                                Maybe (ByteString, SockAddr)
Nothing -> do
                                    -- if we were waiting for a predicate to pass, then we've timed out
                                    Bool
-> StateT (Map HostAddress (NonEmpty b)) m ()
-> StateT (Map HostAddress (NonEmpty b)) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Map HostAddress (NonEmpty b) -> Bool) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Map HostAddress (NonEmpty b) -> Bool)
maybeFinished) (StateT (Map HostAddress (NonEmpty b)) m ()
 -> StateT (Map HostAddress (NonEmpty b)) m ())
-> StateT (Map HostAddress (NonEmpty b)) m ()
-> StateT (Map HostAddress (NonEmpty b)) m ()
forall a b. (a -> b) -> a -> b
$
                                        m () -> StateT (Map HostAddress (NonEmpty b)) m ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT (Map HostAddress (NonEmpty b)) m ())
-> ([HostAddress] -> m ())
-> [HostAddress]
-> StateT (Map HostAddress (NonEmpty b)) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LifxError -> m ()
forall a. LifxError -> m a
forall (m :: * -> *) a. MonadLifxIO m => LifxError -> m a
lifxThrowIO (LifxError -> m ())
-> ([HostAddress] -> LifxError) -> [HostAddress] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HostAddress] -> LifxError
BroadcastTimeout
                                            ([HostAddress] -> StateT (Map HostAddress (NonEmpty b)) m ())
-> StateT (Map HostAddress (NonEmpty b)) m [HostAddress]
-> StateT (Map HostAddress (NonEmpty b)) m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Map HostAddress (NonEmpty b) -> [HostAddress])
-> StateT (Map HostAddress (NonEmpty b)) m [HostAddress]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Map HostAddress (NonEmpty b) -> [HostAddress]
forall k a. Map k a -> [k]
Map.keys
                                    Bool -> StateT (Map HostAddress (NonEmpty b)) m Bool
forall a. a -> StateT (Map HostAddress (NonEmpty b)) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

class Response a where
    expectedPacketType :: Word16
    messageSize :: Int
    getBody :: Get a

instance MessageResult () where
    getSendResult :: forall (m :: * -> *). MonadLifxIO m => Device -> m ()
getSendResult = m () -> Device -> m ()
forall a b. a -> b -> a
const (m () -> Device -> m ()) -> m () -> Device -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    broadcastAndGetResult :: forall (m :: * -> *) b r.
MonadLifxIO m =>
(HostAddress -> () -> m (Maybe b))
-> Maybe (Map HostAddress (NonEmpty b) -> Bool)
-> Message r
-> m (Map Device (NonEmpty b))
broadcastAndGetResult = (Maybe (Map HostAddress (NonEmpty b) -> Bool)
 -> Message r -> m (Map Device (NonEmpty b)))
-> (HostAddress -> () -> m (Maybe b))
-> Maybe (Map HostAddress (NonEmpty b) -> Bool)
-> Message r
-> m (Map Device (NonEmpty b))
forall a b. a -> b -> a
const ((Maybe (Map HostAddress (NonEmpty b) -> Bool)
  -> Message r -> m (Map Device (NonEmpty b)))
 -> (HostAddress -> () -> m (Maybe b))
 -> Maybe (Map HostAddress (NonEmpty b) -> Bool)
 -> Message r
 -> m (Map Device (NonEmpty b)))
-> (Maybe (Map HostAddress (NonEmpty b) -> Bool)
    -> Message r -> m (Map Device (NonEmpty b)))
-> (HostAddress -> () -> m (Maybe b))
-> Maybe (Map HostAddress (NonEmpty b) -> Bool)
-> Message r
-> m (Map Device (NonEmpty b))
forall a b. (a -> b) -> a -> b
$ (Message r -> m (Map Device (NonEmpty b)))
-> Maybe (Map HostAddress (NonEmpty b) -> Bool)
-> Message r
-> m (Map Device (NonEmpty b))
forall a b. a -> b -> a
const ((Message r -> m (Map Device (NonEmpty b)))
 -> Maybe (Map HostAddress (NonEmpty b) -> Bool)
 -> Message r
 -> m (Map Device (NonEmpty b)))
-> (Message r -> m (Map Device (NonEmpty b)))
-> Maybe (Map HostAddress (NonEmpty b) -> Bool)
-> Message r
-> m (Map Device (NonEmpty b))
forall a b. (a -> b) -> a -> b
$ (Map Device (NonEmpty b)
forall k a. Map k a
Map.empty Map Device (NonEmpty b) -> m () -> m (Map Device (NonEmpty b))
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (m () -> m (Map Device (NonEmpty b)))
-> (Message r -> m ()) -> Message r -> m (Map Device (NonEmpty b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message r -> m ()
forall (m :: * -> *) r. MonadLifxIO m => Message r -> m ()
broadcast
instance Response StateService where
    expectedPacketType :: Word16
expectedPacketType = Word16
3
    messageSize :: Int
messageSize = Int
5
    getBody :: Get StateService
getBody = do
        Service
service <-
            Get Word8
getWord8 Get Word8 -> (Word8 -> Get Service) -> Get Service
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Word8
1 -> Service -> Get Service
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Service
ServiceUDP
                Word8
2 -> Service -> Get Service
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Service
ServiceReserved1
                Word8
3 -> Service -> Get Service
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Service
ServiceReserved2
                Word8
4 -> Service -> Get Service
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Service
ServiceReserved3
                Word8
5 -> Service -> Get Service
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Service
ServiceReserved4
                Word8
n -> String -> Get Service
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Service) -> String -> Get Service
forall a b. (a -> b) -> a -> b
$ String
"unknown service: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
n
        PortNumber
port <- do
            HostAddress
x <- Get HostAddress
getWord32le
            -- `network` lib uses `Word16` for ports, but LIFX StateService uses `Word32`
            Get PortNumber
-> (PortNumber -> Get PortNumber)
-> Maybe PortNumber
-> Get PortNumber
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Get PortNumber
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get PortNumber) -> String -> Get PortNumber
forall a b. (a -> b) -> a -> b
$ String
"port out of range: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HostAddress -> String
forall a. Show a => a -> String
show HostAddress
x) PortNumber -> Get PortNumber
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PortNumber -> Get PortNumber)
-> Maybe PortNumber -> Get PortNumber
forall a b. (a -> b) -> a -> b
$ HostAddress -> Maybe PortNumber
forall a b. (Integral a, Integral b, Bounded b) => a -> Maybe b
fromIntegralSafe HostAddress
x
        StateService -> Get StateService
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateService{PortNumber
Service
$sel:service:StateService :: Service
$sel:port:StateService :: PortNumber
service :: Service
port :: PortNumber
..}
instance MessageResult StateService
instance Response StateHostFirmware where
    expectedPacketType :: Word16
expectedPacketType = Word16
15
    messageSize :: Int
messageSize = Int
20
    getBody :: Get StateHostFirmware
getBody = do
        Word64
build <- Get Word64
getWord64le
        Int -> Get ()
skip Int
8
        Word16
versionMinor <- Get Word16
getWord16le
        Word16
versionMajor <- Get Word16
getWord16le
        StateHostFirmware -> Get StateHostFirmware
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateHostFirmware{Word16
Word64
$sel:build:StateHostFirmware :: Word64
$sel:versionMinor:StateHostFirmware :: Word16
$sel:versionMajor:StateHostFirmware :: Word16
build :: Word64
versionMinor :: Word16
versionMajor :: Word16
..}
instance MessageResult StateHostFirmware
instance Response StatePower where
    expectedPacketType :: Word16
expectedPacketType = Word16
22
    messageSize :: Int
messageSize = Int
2
    getBody :: Get StatePower
getBody = Word16 -> StatePower
StatePower (Word16 -> StatePower) -> Get Word16 -> Get StatePower
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le
instance MessageResult StatePower
instance Response StateVersion where
    expectedPacketType :: Word16
expectedPacketType = Word16
33
    messageSize :: Int
messageSize = Int
20
    getBody :: Get StateVersion
getBody = do
        HostAddress
vendor <- Get HostAddress
getWord32le
        HostAddress
p <- Get HostAddress
getWord32le
        Int -> Get ()
skip Int
4
        StateVersion -> Get StateVersion
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateVersion{$sel:product:StateVersion :: HostAddress
product = HostAddress
p, HostAddress
$sel:vendor:StateVersion :: HostAddress
vendor :: HostAddress
..}
instance MessageResult StateVersion
instance Response StateGroup where
    expectedPacketType :: Word16
expectedPacketType = Word16
53
    messageSize :: Int
messageSize = Int
56
    getBody :: Get StateGroup
getBody = do
        ByteString
group <- Int -> Get ByteString
getByteString Int
16
        Text
label <- (UnicodeException -> Get Text)
-> (Text -> Get Text) -> Either UnicodeException Text -> Get Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Get Text
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Text)
-> (UnicodeException -> String) -> UnicodeException -> Get Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnicodeException -> String
showDecodeError) Text -> Get Text
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either UnicodeException Text -> Get Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Get Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> (ByteString -> ByteString)
-> ByteString
-> Either UnicodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> ByteString
BS.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (ByteString -> Get Text) -> Get ByteString -> Get Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Get ByteString
getByteString Int
32
        NominalDiffTime
updatedAt <- Pico -> NominalDiffTime
secondsToNominalDiffTime (Pico -> NominalDiffTime)
-> (Word64 -> Pico) -> Word64 -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Pico
forall k (a :: k). Integer -> Fixed a
MkFixed (Integer -> Pico) -> (Word64 -> Integer) -> Word64 -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000) (Integer -> Integer) -> (Word64 -> Integer) -> Word64 -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> NominalDiffTime) -> Get Word64 -> Get NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64le
        StateGroup -> Get StateGroup
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateGroup{ByteString
Text
NominalDiffTime
$sel:group:StateGroup :: ByteString
$sel:label:StateGroup :: Text
$sel:updatedAt:StateGroup :: NominalDiffTime
group :: ByteString
label :: Text
updatedAt :: NominalDiffTime
..}
instance MessageResult StateGroup
instance Response LightState where
    expectedPacketType :: Word16
expectedPacketType = Word16
107
    messageSize :: Int
messageSize = Int
52
    getBody :: Get LightState
getBody = do
        HSBK
hsbk <- Word16 -> Word16 -> Word16 -> Word16 -> HSBK
HSBK (Word16 -> Word16 -> Word16 -> Word16 -> HSBK)
-> Get Word16 -> Get (Word16 -> Word16 -> Word16 -> HSBK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le Get (Word16 -> Word16 -> Word16 -> HSBK)
-> Get Word16 -> Get (Word16 -> Word16 -> HSBK)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
getWord16le Get (Word16 -> Word16 -> HSBK)
-> Get Word16 -> Get (Word16 -> HSBK)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
getWord16le Get (Word16 -> HSBK) -> Get Word16 -> Get HSBK
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
getWord16le
        Int -> Get ()
skip Int
2
        Word16
power <- Get Word16
getWord16le
        Text
label <- (UnicodeException -> Get Text)
-> (Text -> Get Text) -> Either UnicodeException Text -> Get Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Get Text
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Text)
-> (UnicodeException -> String) -> UnicodeException -> Get Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnicodeException -> String
showDecodeError) Text -> Get Text
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either UnicodeException Text -> Get Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Get Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> (ByteString -> ByteString)
-> ByteString
-> Either UnicodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> ByteString
BS.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (ByteString -> Get Text) -> Get ByteString -> Get Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Get ByteString
getByteString Int
32
        Int -> Get ()
skip Int
8
        LightState -> Get LightState
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LightState{Word16
Text
HSBK
$sel:hsbk:LightState :: HSBK
$sel:power:LightState :: Word16
$sel:label:LightState :: Text
hsbk :: HSBK
power :: Word16
label :: Text
..}
instance MessageResult LightState

msgResWitness :: ((MessageResult r) => Message r -> a) -> (Message r -> a)
msgResWitness :: forall r a. (MessageResult r => Message r -> a) -> Message r -> a
msgResWitness MessageResult r => Message r -> a
f Message r
m = case Message r
m of
    GetService{} -> MessageResult r => Message r -> a
Message r -> a
f Message r
m
    GetHostFirmware{} -> MessageResult r => Message r -> a
Message r -> a
f Message r
m
    GetPower{} -> MessageResult r => Message r -> a
Message r -> a
f Message r
m
    SetPower{} -> MessageResult r => Message r -> a
Message r -> a
f Message r
m
    SetLabel{} -> MessageResult r => Message r -> a
Message r -> a
f Message r
m
    GetVersion{} -> MessageResult r => Message r -> a
Message r -> a
f Message r
m
    GetGroup{} -> MessageResult r => Message r -> a
Message r -> a
f Message r
m
    GetColor{} -> MessageResult r => Message r -> a
Message r -> a
f Message r
m
    SetColor{} -> MessageResult r => Message r -> a
Message r -> a
f Message r
m
    SetLightPower{} -> MessageResult r => Message r -> a
Message r -> a
f Message r
m

{- Monad -}

-- | A simple implementation of 'MonadLifx'.
type Lifx = LifxT IO

{- | 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 :: forall a. Lifx a -> IO a
runLifx Lifx a
m =
    Int -> Lifx a -> IO (Either LifxError a)
forall (m :: * -> *) a.
MonadIO m =>
Int -> LifxT m a -> m (Either LifxError a)
runLifxT Int
5_000_000 Lifx a
m IO (Either LifxError a) -> (Either LifxError a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left LifxError
e -> IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$ IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
userErrorType (String
"LIFX LAN: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> LifxError -> String
forall a. Show a => a -> String
show LifxError
e) Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
        Right a
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

runLifxT ::
    (MonadIO m) =>
    -- | Timeout for waiting for message responses, in microseconds.
    Int ->
    LifxT m a ->
    m (Either LifxError a)
runLifxT :: forall (m :: * -> *) a.
MonadIO m =>
Int -> LifxT m a -> m (Either LifxError a)
runLifxT Int
timeoutDuration (LifxT StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
x) = do
    Socket
sock <- IO Socket -> m Socket
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Socket -> m Socket) -> IO Socket -> m Socket
forall a b. (a -> b) -> a -> b
$ Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_INET SocketType
Datagram ProtocolNumber
defaultProtocol
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
Broadcast Int
1
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (SockAddr -> IO ()) -> SockAddr -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> SockAddr -> IO ()
bind Socket
sock (SockAddr -> m ()) -> SockAddr -> m ()
forall a b. (a -> b) -> a -> b
$ PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
defaultPort HostAddress
0
    HostAddress
source <-
        m (Maybe HostAddress) -> m HostAddress
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a
untilJustM (m (Maybe HostAddress) -> m HostAddress)
-> m (Maybe HostAddress) -> m HostAddress
forall a b. (a -> b) -> a -> b
$
            m HostAddress
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO m HostAddress
-> (HostAddress -> Maybe HostAddress) -> m (Maybe HostAddress)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                -- 0 and 1 cause problems on old firmware: https://lan.developer.lifx.com/docs/packet-contents#frame-header
                HostAddress
n | HostAddress
n HostAddress -> HostAddress -> Bool
forall a. Ord a => a -> a -> Bool
> HostAddress
1 -> HostAddress -> Maybe HostAddress
forall a. a -> Maybe a
Just HostAddress
n
                HostAddress
_ -> Maybe HostAddress
forall a. Maybe a
Nothing
    ExceptT LifxError m a -> m (Either LifxError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT LifxError m a -> m (Either LifxError a))
-> ExceptT LifxError m a -> m (Either LifxError a)
forall a b. (a -> b) -> a -> b
$ ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m) a
-> (Socket, HostAddress, Int) -> ExceptT LifxError m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
-> Word8
-> ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m) a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
x Word8
0) (Socket
sock, HostAddress
source, Int
timeoutDuration)

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
    type MonadLifxError (LifxT m) = LifxError
    lifxThrow :: forall a. MonadLifxError (LifxT m) -> LifxT m a
lifxThrow = LifxError -> LifxT m a
MonadLifxError (LifxT m) -> LifxT m a
forall a. LifxError -> LifxT m a
forall (m :: * -> *) a. MonadLifxIO m => LifxError -> m a
lifxThrowIO
    liftProductLookupError :: ProductLookupError -> MonadLifxError (LifxT m)
liftProductLookupError = ProductLookupError -> LifxError
ProductLookupError -> MonadLifxError (LifxT m)
ProductLookupError

    sendMessage :: forall r. Device -> Message r -> LifxT m r
sendMessage Device
receiver = (MessageResult r => Message r -> LifxT m r)
-> Message r -> LifxT m r
forall r a. (MessageResult r => Message r -> a) -> Message r -> a
msgResWitness \Message r
msg -> do
        LifxT m ()
forall (m :: * -> *). MonadLifxIO m => m ()
incrementCounter
        Bool -> HostAddress -> Message r -> LifxT m ()
forall (m :: * -> *) r.
MonadLifxIO m =>
Bool -> HostAddress -> Message r -> m ()
sendMessage' Bool
True Device
receiver.unwrap Message r
msg
        Device -> LifxT m r
forall a (m :: * -> *).
(MessageResult a, MonadLifxIO m) =>
Device -> m a
forall (m :: * -> *). MonadLifxIO m => Device -> m r
getSendResult Device
receiver

    broadcastMessage :: forall r. Message r -> LifxT m [(Device, r)]
broadcastMessage =
        (MessageResult r => Message r -> LifxT m [(Device, r)])
-> Message r -> LifxT m [(Device, r)]
forall r a. (MessageResult r => Message r -> a) -> Message r -> a
msgResWitness ((MessageResult r => Message r -> LifxT m [(Device, r)])
 -> Message r -> LifxT m [(Device, r)])
-> (MessageResult r => Message r -> LifxT m [(Device, r)])
-> Message r
-> LifxT m [(Device, r)]
forall a b. (a -> b) -> a -> b
$
            (Map Device (NonEmpty r) -> [(Device, r)])
-> LifxT m (Map Device (NonEmpty r)) -> LifxT m [(Device, r)]
forall a b. (a -> b) -> LifxT m a -> LifxT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Device, NonEmpty r) -> [(Device, r)])
-> [(Device, NonEmpty r)] -> [(Device, r)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Device
a, NonEmpty r
xs) -> (r -> (Device, r)) -> [r] -> [(Device, r)]
forall a b. (a -> b) -> [a] -> [b]
map (Device
a,) ([r] -> [(Device, r)]) -> [r] -> [(Device, r)]
forall a b. (a -> b) -> a -> b
$ NonEmpty r -> [r]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty r
xs) ([(Device, NonEmpty r)] -> [(Device, r)])
-> (Map Device (NonEmpty r) -> [(Device, NonEmpty r)])
-> Map Device (NonEmpty r)
-> [(Device, r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Device (NonEmpty r) -> [(Device, NonEmpty r)]
forall k a. Map k a -> [(k, a)]
Map.toList)
                (LifxT m (Map Device (NonEmpty r)) -> LifxT m [(Device, r)])
-> (Message r -> LifxT m (Map Device (NonEmpty r)))
-> Message r
-> LifxT m [(Device, r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HostAddress -> r -> LifxT m (Maybe r))
-> Maybe (Map HostAddress (NonEmpty r) -> Bool)
-> Message r
-> LifxT m (Map Device (NonEmpty r))
forall a (m :: * -> *) b r.
(MessageResult a, MonadLifxIO m) =>
(HostAddress -> a -> m (Maybe b))
-> Maybe (Map HostAddress (NonEmpty b) -> Bool)
-> Message r
-> m (Map Device (NonEmpty b))
forall (m :: * -> *) b r.
MonadLifxIO m =>
(HostAddress -> r -> m (Maybe b))
-> Maybe (Map HostAddress (NonEmpty b) -> Bool)
-> Message r
-> m (Map Device (NonEmpty b))
broadcastAndGetResult ((r -> LifxT m (Maybe r)) -> HostAddress -> r -> LifxT m (Maybe r)
forall a b. a -> b -> a
const ((r -> LifxT m (Maybe r)) -> HostAddress -> r -> LifxT m (Maybe r))
-> (r -> LifxT m (Maybe r))
-> HostAddress
-> r
-> LifxT m (Maybe r)
forall a b. (a -> b) -> a -> b
$ Maybe r -> LifxT m (Maybe r)
forall a. a -> LifxT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe r -> LifxT m (Maybe r))
-> (r -> Maybe r) -> r -> LifxT m (Maybe r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Maybe r
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Maybe (Map HostAddress (NonEmpty r) -> Bool)
forall a. Maybe a
Nothing

    discoverDevices :: Maybe Int -> LifxT m [Device]
discoverDevices Maybe Int
nDevices = Map Device (NonEmpty ()) -> [Device]
forall k a. Map k a -> [k]
Map.keys (Map Device (NonEmpty ()) -> [Device])
-> LifxT m (Map Device (NonEmpty ())) -> LifxT m [Device]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HostAddress -> StateService -> LifxT m (Maybe ()))
-> Maybe (Map HostAddress (NonEmpty ()) -> Bool)
-> Message StateService
-> LifxT m (Map Device (NonEmpty ()))
forall a (m :: * -> *) b r.
(MessageResult a, MonadLifxIO m) =>
(HostAddress -> a -> m (Maybe b))
-> Maybe (Map HostAddress (NonEmpty b) -> Bool)
-> Message r
-> m (Map Device (NonEmpty b))
forall (m :: * -> *) b r.
MonadLifxIO m =>
(HostAddress -> StateService -> m (Maybe b))
-> Maybe (Map HostAddress (NonEmpty b) -> Bool)
-> Message r
-> m (Map Device (NonEmpty b))
broadcastAndGetResult HostAddress -> StateService -> LifxT m (Maybe ())
forall {m :: * -> *} {f :: * -> *} {p}.
(MonadLifxIO m, Alternative f) =>
p -> StateService -> m (f ())
f Maybe (Map HostAddress (NonEmpty ()) -> Bool)
p Message StateService
GetService
      where
        f :: p -> StateService -> m (f ())
f p
_addr StateService{PortNumber
Service
$sel:service:StateService :: StateService -> Service
$sel:port:StateService :: StateService -> PortNumber
service :: Service
port :: PortNumber
..} = do
            PortNumber -> m ()
forall (f :: * -> *). MonadLifxIO f => PortNumber -> f ()
checkPort PortNumber
port
            f () -> m (f ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f () -> m (f ())) -> (Bool -> f ()) -> Bool -> m (f ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> f ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m (f ())) -> Bool -> m (f ())
forall a b. (a -> b) -> a -> b
$ Service
service Service -> Service -> Bool
forall a. Eq a => a -> a -> Bool
== Service
ServiceUDP
        p :: Maybe (Map HostAddress (NonEmpty ()) -> Bool)
p = Maybe Int
nDevices Maybe Int
-> (Int -> Map HostAddress (NonEmpty ()) -> Bool)
-> Maybe (Map HostAddress (NonEmpty ()) -> Bool)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
n -> (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n) (Int -> Bool)
-> (Map HostAddress (NonEmpty ()) -> Int)
-> Map HostAddress (NonEmpty ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map HostAddress (NonEmpty ()) -> Int
forall a. Map HostAddress a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
instance (MonadLifx m) => MonadLifx (MaybeT m) where
    type MonadLifxError (MaybeT m) = MonadLifxError m
    liftProductLookupError :: ProductLookupError -> MonadLifxError (MaybeT m)
liftProductLookupError = forall (m :: * -> *).
MonadLifx m =>
ProductLookupError -> MonadLifxError m
liftProductLookupError @m
    sendMessage :: forall r. Device -> Message r -> MaybeT m r
sendMessage = m r -> MaybeT m r
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m r -> MaybeT m r)
-> (Device -> Message r -> m r)
-> Device
-> Message r
-> MaybeT m r
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: Device -> Message r -> m r
forall r. Device -> Message r -> m r
forall (m :: * -> *) r. MonadLifx m => Device -> Message r -> m r
sendMessage
    broadcastMessage :: forall r. Message r -> MaybeT m [(Device, r)]
broadcastMessage = m [(Device, r)] -> MaybeT m [(Device, r)]
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [(Device, r)] -> MaybeT m [(Device, r)])
-> (Message r -> m [(Device, r)])
-> Message r
-> MaybeT m [(Device, r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message r -> m [(Device, r)]
forall r. Message r -> m [(Device, r)]
forall (m :: * -> *) r. MonadLifx m => Message r -> m [(Device, r)]
broadcastMessage
    discoverDevices :: Maybe Int -> MaybeT m [Device]
discoverDevices = m [Device] -> MaybeT m [Device]
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Device] -> MaybeT m [Device])
-> (Maybe Int -> m [Device]) -> Maybe Int -> MaybeT m [Device]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> m [Device]
forall (m :: * -> *). MonadLifx m => Maybe Int -> m [Device]
discoverDevices
    lifxThrow :: forall a. MonadLifxError (MaybeT m) -> MaybeT m a
lifxThrow = m a -> MaybeT m a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> MaybeT m a)
-> (MonadLifxError m -> m a) -> MonadLifxError m -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonadLifxError m -> m a
forall a. MonadLifxError m -> m a
forall (m :: * -> *) a. MonadLifx m => MonadLifxError m -> m a
lifxThrow
instance (MonadLifx m) => MonadLifx (ExceptT e m) where
    type MonadLifxError (ExceptT e m) = MonadLifxError m
    liftProductLookupError :: ProductLookupError -> MonadLifxError (ExceptT e m)
liftProductLookupError = forall (m :: * -> *).
MonadLifx m =>
ProductLookupError -> MonadLifxError m
liftProductLookupError @m
    sendMessage :: forall r. Device -> Message r -> ExceptT e m r
sendMessage = m r -> ExceptT e m r
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m r -> ExceptT e m r)
-> (Device -> Message r -> m r)
-> Device
-> Message r
-> ExceptT e m r
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: Device -> Message r -> m r
forall r. Device -> Message r -> m r
forall (m :: * -> *) r. MonadLifx m => Device -> Message r -> m r
sendMessage
    broadcastMessage :: forall r. Message r -> ExceptT e m [(Device, r)]
broadcastMessage = m [(Device, r)] -> ExceptT e m [(Device, r)]
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [(Device, r)] -> ExceptT e m [(Device, r)])
-> (Message r -> m [(Device, r)])
-> Message r
-> ExceptT e m [(Device, r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message r -> m [(Device, r)]
forall r. Message r -> m [(Device, r)]
forall (m :: * -> *) r. MonadLifx m => Message r -> m [(Device, r)]
broadcastMessage
    discoverDevices :: Maybe Int -> ExceptT e m [Device]
discoverDevices = m [Device] -> ExceptT e m [Device]
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Device] -> ExceptT e m [Device])
-> (Maybe Int -> m [Device]) -> Maybe Int -> ExceptT e m [Device]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> m [Device]
forall (m :: * -> *). MonadLifx m => Maybe Int -> m [Device]
discoverDevices
    lifxThrow :: forall a. MonadLifxError (ExceptT e m) -> ExceptT e m a
lifxThrow = m a -> ExceptT e m a
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ExceptT e m a)
-> (MonadLifxError m -> m a) -> MonadLifxError m -> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonadLifxError m -> m a
forall a. MonadLifxError m -> m a
forall (m :: * -> *) a. MonadLifx m => MonadLifxError m -> m a
lifxThrow
instance (MonadLifx m) => MonadLifx (StateT s m) where
    type MonadLifxError (StateT s m) = MonadLifxError m
    liftProductLookupError :: ProductLookupError -> MonadLifxError (StateT s m)
liftProductLookupError = forall (m :: * -> *).
MonadLifx m =>
ProductLookupError -> MonadLifxError m
liftProductLookupError @m
    sendMessage :: forall r. Device -> Message r -> StateT s m r
sendMessage = m r -> StateT s m r
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m r -> StateT s m r)
-> (Device -> Message r -> m r)
-> Device
-> Message r
-> StateT s m r
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: Device -> Message r -> m r
forall r. Device -> Message r -> m r
forall (m :: * -> *) r. MonadLifx m => Device -> Message r -> m r
sendMessage
    broadcastMessage :: forall r. Message r -> StateT s m [(Device, r)]
broadcastMessage = m [(Device, r)] -> StateT s m [(Device, r)]
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [(Device, r)] -> StateT s m [(Device, r)])
-> (Message r -> m [(Device, r)])
-> Message r
-> StateT s m [(Device, r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message r -> m [(Device, r)]
forall r. Message r -> m [(Device, r)]
forall (m :: * -> *) r. MonadLifx m => Message r -> m [(Device, r)]
broadcastMessage
    discoverDevices :: Maybe Int -> StateT s m [Device]
discoverDevices = m [Device] -> StateT s m [Device]
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Device] -> StateT s m [Device])
-> (Maybe Int -> m [Device]) -> Maybe Int -> StateT s m [Device]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> m [Device]
forall (m :: * -> *). MonadLifx m => Maybe Int -> m [Device]
discoverDevices
    lifxThrow :: forall a. MonadLifxError (StateT s m) -> StateT s m a
lifxThrow = m a -> StateT s m a
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT s m a)
-> (MonadLifxError m -> m a) -> MonadLifxError m -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonadLifxError m -> m a
forall a. MonadLifxError m -> m a
forall (m :: * -> *) a. MonadLifx m => MonadLifxError m -> m a
lifxThrow
instance (MonadLifx m, Monoid t) => MonadLifx (WriterT t m) where
    type MonadLifxError (WriterT t m) = MonadLifxError m
    liftProductLookupError :: ProductLookupError -> MonadLifxError (WriterT t m)
liftProductLookupError = forall (m :: * -> *).
MonadLifx m =>
ProductLookupError -> MonadLifxError m
liftProductLookupError @m
    sendMessage :: forall r. Device -> Message r -> WriterT t m r
sendMessage = m r -> WriterT t m r
forall (m :: * -> *) a. Monad m => m a -> WriterT t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m r -> WriterT t m r)
-> (Device -> Message r -> m r)
-> Device
-> Message r
-> WriterT t m r
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: Device -> Message r -> m r
forall r. Device -> Message r -> m r
forall (m :: * -> *) r. MonadLifx m => Device -> Message r -> m r
sendMessage
    broadcastMessage :: forall r. Message r -> WriterT t m [(Device, r)]
broadcastMessage = m [(Device, r)] -> WriterT t m [(Device, r)]
forall (m :: * -> *) a. Monad m => m a -> WriterT t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [(Device, r)] -> WriterT t m [(Device, r)])
-> (Message r -> m [(Device, r)])
-> Message r
-> WriterT t m [(Device, r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message r -> m [(Device, r)]
forall r. Message r -> m [(Device, r)]
forall (m :: * -> *) r. MonadLifx m => Message r -> m [(Device, r)]
broadcastMessage
    discoverDevices :: Maybe Int -> WriterT t m [Device]
discoverDevices = m [Device] -> WriterT t m [Device]
forall (m :: * -> *) a. Monad m => m a -> WriterT t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Device] -> WriterT t m [Device])
-> (Maybe Int -> m [Device]) -> Maybe Int -> WriterT t m [Device]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> m [Device]
forall (m :: * -> *). MonadLifx m => Maybe Int -> m [Device]
discoverDevices
    lifxThrow :: forall a. MonadLifxError (WriterT t m) -> WriterT t m a
lifxThrow = m a -> WriterT t m a
forall (m :: * -> *) a. Monad m => m a -> WriterT t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> WriterT t m a)
-> (MonadLifxError m -> m a) -> MonadLifxError m -> WriterT t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonadLifxError m -> m a
forall a. MonadLifxError m -> m a
forall (m :: * -> *) a. MonadLifx m => MonadLifxError m -> m a
lifxThrow
instance (MonadLifx m) => MonadLifx (ReaderT e m) where
    type MonadLifxError (ReaderT e m) = MonadLifxError m
    liftProductLookupError :: ProductLookupError -> MonadLifxError (ReaderT e m)
liftProductLookupError = forall (m :: * -> *).
MonadLifx m =>
ProductLookupError -> MonadLifxError m
liftProductLookupError @m
    sendMessage :: forall r. Device -> Message r -> ReaderT e m r
sendMessage = m r -> ReaderT e m r
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m r -> ReaderT e m r)
-> (Device -> Message r -> m r)
-> Device
-> Message r
-> ReaderT e m r
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: Device -> Message r -> m r
forall r. Device -> Message r -> m r
forall (m :: * -> *) r. MonadLifx m => Device -> Message r -> m r
sendMessage
    broadcastMessage :: forall r. Message r -> ReaderT e m [(Device, r)]
broadcastMessage = m [(Device, r)] -> ReaderT e m [(Device, r)]
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [(Device, r)] -> ReaderT e m [(Device, r)])
-> (Message r -> m [(Device, r)])
-> Message r
-> ReaderT e m [(Device, r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message r -> m [(Device, r)]
forall r. Message r -> m [(Device, r)]
forall (m :: * -> *) r. MonadLifx m => Message r -> m [(Device, r)]
broadcastMessage
    discoverDevices :: Maybe Int -> ReaderT e m [Device]
discoverDevices = m [Device] -> ReaderT e m [Device]
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Device] -> ReaderT e m [Device])
-> (Maybe Int -> m [Device]) -> Maybe Int -> ReaderT e m [Device]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> m [Device]
forall (m :: * -> *). MonadLifx m => Maybe Int -> m [Device]
discoverDevices
    lifxThrow :: forall a. MonadLifxError (ReaderT e m) -> ReaderT e m a
lifxThrow = m a -> ReaderT e m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT e m a)
-> (MonadLifxError m -> m a) -> MonadLifxError m -> ReaderT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonadLifxError m -> m a
forall a. MonadLifxError m -> m a
forall (m :: * -> *) a. MonadLifx m => MonadLifxError m -> m a
lifxThrow

encodeMessage ::
    -- | tagged
    Bool ->
    -- | ackRequired
    Bool ->
    -- | sequenceCounter
    Word8 ->
    -- | source
    Word32 ->
    Message r ->
    BL.ByteString
encodeMessage :: forall r.
Bool -> Bool -> Word8 -> HostAddress -> Message r -> ByteString
encodeMessage Bool
tagged Bool
ackRequired Word8
sequenceCounter HostAddress
source Message r
msg =
    Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Header -> Put
forall t. Binary t => t -> Put
Binary.put (Bool -> Bool -> Word8 -> HostAddress -> Message r -> Header
forall r.
Bool -> Bool -> Word8 -> HostAddress -> Message r -> Header
messageHeader Bool
tagged Bool
ackRequired Word8
sequenceCounter HostAddress
source Message r
msg) Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Message r -> Put
forall r. Message r -> Put
putMessagePayload Message r
msg

-- | https://lan.developer.lifx.com/docs/encoding-a-packet
data Header = Header
    { Header -> Word16
size :: Word16
    , Header -> Word16
protocol :: Word16
    , Header -> Bool
addressable :: Bool
    , Header -> Bool
tagged :: Bool
    , Header -> Word8
origin :: Word8
    , Header -> HostAddress
source :: Word32
    , Header -> Word64
target :: Word64
    , Header -> Bool
resRequired :: Bool
    , Header -> Bool
ackRequired :: Bool
    , Header -> Word8
sequenceCounter :: Word8
    , Header -> Word16
packetType :: Word16
    }
    deriving (Header -> Header -> Bool
(Header -> Header -> Bool)
-> (Header -> Header -> Bool) -> Eq Header
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Header -> Header -> Bool
== :: Header -> Header -> Bool
$c/= :: Header -> Header -> Bool
/= :: Header -> Header -> Bool
Eq, Eq Header
Eq Header =>
(Header -> Header -> Ordering)
-> (Header -> Header -> Bool)
-> (Header -> Header -> Bool)
-> (Header -> Header -> Bool)
-> (Header -> Header -> Bool)
-> (Header -> Header -> Header)
-> (Header -> Header -> Header)
-> Ord Header
Header -> Header -> Bool
Header -> Header -> Ordering
Header -> Header -> Header
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Header -> Header -> Ordering
compare :: Header -> Header -> Ordering
$c< :: Header -> Header -> Bool
< :: Header -> Header -> Bool
$c<= :: Header -> Header -> Bool
<= :: Header -> Header -> Bool
$c> :: Header -> Header -> Bool
> :: Header -> Header -> Bool
$c>= :: Header -> Header -> Bool
>= :: Header -> Header -> Bool
$cmax :: Header -> Header -> Header
max :: Header -> Header -> Header
$cmin :: Header -> Header -> Header
min :: Header -> Header -> Header
Ord, Int -> Header -> ShowS
[Header] -> ShowS
Header -> String
(Int -> Header -> ShowS)
-> (Header -> String) -> ([Header] -> ShowS) -> Show Header
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Header -> ShowS
showsPrec :: Int -> Header -> ShowS
$cshow :: Header -> String
show :: Header -> String
$cshowList :: [Header] -> ShowS
showList :: [Header] -> ShowS
Show, (forall x. Header -> Rep Header x)
-> (forall x. Rep Header x -> Header) -> Generic Header
forall x. Rep Header x -> Header
forall x. Header -> Rep Header x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Header -> Rep Header x
from :: forall x. Header -> Rep Header x
$cto :: forall x. Rep Header x -> Header
to :: forall x. Rep Header x -> Header
Generic)

instance Binary Header where
    get :: Get Header
get = do
        Word16
size <- Get Word16
getWord16le
        Word16
protBytes <- Get Word16
getWord16le
        let protocol :: Word16
protocol = (Word16 -> Int -> Word16) -> Int -> Word16 -> Word16
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
clearBit Int
12 (Word16 -> Word16) -> (Word16 -> Word16) -> Word16 -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> Int -> Word16) -> Int -> Word16 -> Word16
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
clearBit Int
13 (Word16 -> Word16) -> (Word16 -> Word16) -> Word16 -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> Int -> Word16) -> Int -> Word16 -> Word16
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
clearBit Int
14 (Word16 -> Word16) -> (Word16 -> Word16) -> Word16 -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> Int -> Word16) -> Int -> Word16 -> Word16
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
clearBit Int
15 (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ Word16
protBytes
            addressable :: Bool
addressable = Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
protBytes Int
12
            tagged :: Bool
tagged = Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
protBytes Int
13
            origin :: Word8
origin = (if Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
protBytes Int
14 then Word8
0 else Word8
1) Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ (if Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
protBytes Int
15 then Word8
0 else Word8
2)
        HostAddress
source <- Get HostAddress
getWord32le
        Word64
target <- Get Word64
getWord64be
        Int -> Get ()
skip Int
6
        Word8
resAckByte <- Get Word8
getWord8
        let resRequired :: Bool
resRequired = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
resAckByte Int
0
            ackRequired :: Bool
ackRequired = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
resAckByte Int
1
        Word8
sequenceCounter <- Get Word8
getWord8
        Int -> Get ()
skip Int
8
        Word16
packetType <- Get Word16
getWord16le
        Int -> Get ()
skip Int
2
        Header -> Get Header
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Header{Bool
Word8
Word16
HostAddress
Word64
$sel:size:Header :: Word16
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
$sel:packetType:Header :: Word16
size :: Word16
protocol :: Word16
addressable :: Bool
tagged :: Bool
origin :: Word8
source :: HostAddress
target :: Word64
resRequired :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
packetType :: Word16
..}

    put :: Header -> Put
put Header{Bool
Word8
Word16
HostAddress
Word64
$sel:size:Header :: Header -> Word16
$sel:protocol:Header :: Header -> Word16
$sel:addressable:Header :: Header -> Bool
$sel:tagged:Header :: Header -> Bool
$sel:origin:Header :: Header -> Word8
$sel:source:Header :: Header -> HostAddress
$sel:target:Header :: Header -> Word64
$sel:resRequired:Header :: Header -> Bool
$sel:ackRequired:Header :: Header -> Bool
$sel:sequenceCounter:Header :: Header -> Word8
$sel:packetType:Header :: Header -> Word16
size :: Word16
protocol :: Word16
addressable :: Bool
tagged :: Bool
origin :: Word8
source :: HostAddress
target :: Word64
resRequired :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
packetType :: Word16
..} = do
        Word16 -> Put
putWord16le Word16
size
        Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$
            Word16
protocol
                Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Bool -> Int -> Word16
forall {a}. Bits a => Bool -> Int -> a
bitIf Bool
addressable Int
12
                Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Bool -> Int -> Word16
forall {a}. Bits a => Bool -> Int -> a
bitIf Bool
tagged Int
13
                Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Bool -> Int -> Word16
forall {a}. Bits a => Bool -> Int -> a
bitIf (Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
origin Int
0) Int
14
                Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Bool -> Int -> Word16
forall {a}. Bits a => Bool -> Int -> a
bitIf (Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
origin Int
1) Int
15
        HostAddress -> Put
putWord32le HostAddress
source
        Word64 -> Put
putWord64be Word64
target
        Int -> Put -> Put
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
6 (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ Word8 -> Put
putWord8 Word8
0
        Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$
            Word8
forall a. Bits a => a
zeroBits
                Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Bool -> Int -> Word8
forall {a}. Bits a => Bool -> Int -> a
bitIf Bool
resRequired Int
0
                Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Bool -> Int -> Word8
forall {a}. Bits a => Bool -> Int -> a
bitIf Bool
ackRequired Int
1
        Word8 -> Put
putWord8 Word8
sequenceCounter
        Int -> Put -> Put
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
8 (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ Word8 -> Put
putWord8 Word8
0
        Word16 -> Put
putWord16le Word16
packetType
        Int -> Put -> Put
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
2 (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ Word8 -> Put
putWord8 Word8
0
      where
        bitIf :: Bool -> Int -> a
bitIf Bool
b Int
n = if Bool
b then Int -> a
forall a. Bits a => Int -> a
bit Int
n else a
forall a. Bits a => a
zeroBits

messageHeader :: Bool -> Bool -> Word8 -> Word32 -> Message r -> Header
messageHeader :: forall r.
Bool -> Bool -> Word8 -> HostAddress -> Message r -> Header
messageHeader Bool
tagged Bool
ackRequired Word8
sequenceCounter HostAddress
source = \case
    GetService{} ->
        Header
            { $sel:size:Header :: Word16
size = Word16
forall a. Num a => a
headerSize
            , $sel:packetType:Header :: Word16
packetType = Word16
2
            , Bool
Word8
Word16
HostAddress
Word64
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
tagged :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
source :: HostAddress
target :: Word64
protocol :: Word16
addressable :: Bool
origin :: Word8
resRequired :: Bool
..
            }
    GetHostFirmware{} ->
        Header
            { $sel:size:Header :: Word16
size = Word16
forall a. Num a => a
headerSize
            , $sel:packetType:Header :: Word16
packetType = Word16
14
            , Bool
Word8
Word16
HostAddress
Word64
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
tagged :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
source :: HostAddress
target :: Word64
protocol :: Word16
addressable :: Bool
origin :: Word8
resRequired :: Bool
..
            }
    GetPower{} ->
        Header
            { $sel:size:Header :: Word16
size = Word16
forall a. Num a => a
headerSize
            , $sel:packetType:Header :: Word16
packetType = Word16
20
            , Bool
Word8
Word16
HostAddress
Word64
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
tagged :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
source :: HostAddress
target :: Word64
protocol :: Word16
addressable :: Bool
origin :: Word8
resRequired :: Bool
..
            }
    SetPower{} ->
        Header
            { $sel:size:Header :: Word16
size = Word16
forall a. Num a => a
headerSize Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
2
            , $sel:packetType:Header :: Word16
packetType = Word16
21
            , Bool
Word8
Word16
HostAddress
Word64
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
tagged :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
source :: HostAddress
target :: Word64
protocol :: Word16
addressable :: Bool
origin :: Word8
resRequired :: Bool
..
            }
    SetLabel{} ->
        Header
            { $sel:size:Header :: Word16
size = Word16
forall a. Num a => a
headerSize Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
32
            , $sel:packetType:Header :: Word16
packetType = Word16
24
            , Bool
Word8
Word16
HostAddress
Word64
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
tagged :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
source :: HostAddress
target :: Word64
protocol :: Word16
addressable :: Bool
origin :: Word8
resRequired :: Bool
..
            }
    GetVersion{} ->
        Header
            { $sel:size:Header :: Word16
size = Word16
forall a. Num a => a
headerSize
            , $sel:packetType:Header :: Word16
packetType = Word16
32
            , Bool
Word8
Word16
HostAddress
Word64
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
tagged :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
source :: HostAddress
target :: Word64
protocol :: Word16
addressable :: Bool
origin :: Word8
resRequired :: Bool
..
            }
    GetGroup{} ->
        Header
            { $sel:size:Header :: Word16
size = Word16
forall a. Num a => a
headerSize
            , $sel:packetType:Header :: Word16
packetType = Word16
51
            , Bool
Word8
Word16
HostAddress
Word64
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
tagged :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
source :: HostAddress
target :: Word64
protocol :: Word16
addressable :: Bool
origin :: Word8
resRequired :: Bool
..
            }
    GetColor{} ->
        Header
            { $sel:size:Header :: Word16
size = Word16
forall a. Num a => a
headerSize
            , $sel:packetType:Header :: Word16
packetType = Word16
101
            , Bool
Word8
Word16
HostAddress
Word64
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
tagged :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
source :: HostAddress
target :: Word64
protocol :: Word16
addressable :: Bool
origin :: Word8
resRequired :: Bool
..
            }
    SetColor{} ->
        Header
            { $sel:size:Header :: Word16
size = Word16
forall a. Num a => a
headerSize Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
13
            , $sel:packetType:Header :: Word16
packetType = Word16
102
            , Bool
Word8
Word16
HostAddress
Word64
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
tagged :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
source :: HostAddress
target :: Word64
protocol :: Word16
addressable :: Bool
origin :: Word8
resRequired :: Bool
..
            }
    SetLightPower{} ->
        Header
            { $sel:size:Header :: Word16
size = Word16
forall a. Num a => a
headerSize Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
6
            , $sel:packetType:Header :: Word16
packetType = Word16
117
            , Bool
Word8
Word16
HostAddress
Word64
$sel:protocol:Header :: Word16
$sel:addressable:Header :: Bool
$sel:tagged:Header :: Bool
$sel:origin:Header :: Word8
$sel:source:Header :: HostAddress
$sel:target:Header :: Word64
$sel:resRequired:Header :: Bool
$sel:ackRequired:Header :: Bool
$sel:sequenceCounter:Header :: Word8
tagged :: Bool
ackRequired :: Bool
sequenceCounter :: Word8
source :: HostAddress
target :: Word64
protocol :: Word16
addressable :: Bool
origin :: Word8
resRequired :: Bool
..
            }
  where
    target :: Word64
target = Word64
0 :: Word64
    protocol :: Word16
protocol = Word16
1024 :: Word16
    addressable :: Bool
addressable = Bool
True
    origin :: Word8
origin = Word8
0 :: Word8
    resRequired :: Bool
resRequired = Bool
False

putMessagePayload :: Message r -> Put
putMessagePayload :: forall r. Message r -> Put
putMessagePayload = \case
    Message r
GetService -> Put
forall a. Monoid a => a
mempty
    Message r
GetHostFirmware -> Put
forall a. Monoid a => a
mempty
    Message r
GetPower -> Put
forall a. Monoid a => a
mempty
    SetPower Bool
b ->
        Word16 -> Put
putWord16le if Bool
b then Word16
forall a. Bounded a => a
maxBound else Word16
forall a. Bounded a => a
minBound
    SetLabel Text
t -> do
        ByteString -> Put
putByteString ByteString
b
        Int -> Put -> Put
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (ByteString -> Int
BS.length ByteString
b) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ Word8 -> Put
putWord8 Word8
0
      where
        b :: ByteString
b = Text -> ByteString
encodeUtf8 Text
t
    Message r
GetVersion -> Put
forall a. Monoid a => a
mempty
    Message r
GetGroup -> Put
forall a. Monoid a => a
mempty
    Message r
GetColor -> Put
forall a. Monoid a => a
mempty
    SetColor HSBK{Word16
hue :: Word16
saturation :: Word16
brightness :: Word16
kelvin :: Word16
$sel:hue:HSBK :: HSBK -> Word16
$sel:saturation:HSBK :: HSBK -> Word16
$sel:brightness:HSBK :: HSBK -> Word16
$sel:kelvin:HSBK :: HSBK -> Word16
..} NominalDiffTime
d -> do
        Word8 -> Put
putWord8 Word8
0
        Word16 -> Put
putWord16le Word16
hue
        Word16 -> Put
putWord16le Word16
saturation
        Word16 -> Put
putWord16le Word16
brightness
        Word16 -> Put
putWord16le Word16
kelvin
        HostAddress -> Put
putWord32le (HostAddress -> Put) -> HostAddress -> Put
forall a b. (a -> b) -> a -> b
$ forall f a r.
(HasResolution r, f ~ Fixed r, Integral a) =>
NominalDiffTime -> a
nominalDiffTimeToInt @Milli NominalDiffTime
d
    SetLightPower Bool
b NominalDiffTime
d -> do
        Word16 -> Put
putWord16le if Bool
b then Word16
forall a. Bounded a => a
maxBound else Word16
forall a. Bounded a => a
minBound
        HostAddress -> Put
putWord32le (HostAddress -> Put) -> HostAddress -> Put
forall a b. (a -> b) -> a -> b
$ forall f a r.
(HasResolution r, f ~ Fixed r, Integral a) =>
NominalDiffTime -> a
nominalDiffTimeToInt @Milli NominalDiffTime
d

-- | Ask a device for its vendor and product ID, and look up info on it from the official database.
getProductInfo :: forall m. (MonadLifx m) => Device -> m Product
getProductInfo :: forall (m :: * -> *). MonadLifx m => Device -> m Product
getProductInfo Device
dev = do
    StateHostFirmware{Word16
Word64
$sel:build:StateHostFirmware :: StateHostFirmware -> Word64
$sel:versionMinor:StateHostFirmware :: StateHostFirmware -> Word16
$sel:versionMajor:StateHostFirmware :: StateHostFirmware -> Word16
build :: Word64
versionMinor :: Word16
versionMajor :: Word16
..} <- Device -> Message StateHostFirmware -> m StateHostFirmware
forall r. Device -> Message r -> m r
forall (m :: * -> *) r. MonadLifx m => Device -> Message r -> m r
sendMessage Device
dev Message StateHostFirmware
GetHostFirmware
    StateVersion
v <- Device -> Message StateVersion -> m StateVersion
forall r. Device -> Message r -> m r
forall (m :: * -> *) r. MonadLifx m => Device -> Message r -> m r
sendMessage Device
dev Message StateVersion
GetVersion
    (ProductLookupError -> m Product)
-> (Product -> m Product)
-> Either ProductLookupError Product
-> m Product
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MonadLifxError m -> m Product
forall a. MonadLifxError m -> m a
forall (m :: * -> *) a. MonadLifx m => MonadLifxError m -> m a
lifxThrow (MonadLifxError m -> m Product)
-> (ProductLookupError -> MonadLifxError m)
-> ProductLookupError
-> m Product
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadLifx m =>
ProductLookupError -> MonadLifxError m
liftProductLookupError @m) Product -> m Product
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ProductLookupError Product -> m Product)
-> Either ProductLookupError Product -> m Product
forall a b. (a -> b) -> a -> b
$ HostAddress
-> HostAddress
-> Word16
-> Word16
-> Either ProductLookupError Product
productLookup StateVersion
v.vendor StateVersion
v.product Word16
versionMinor Word16
versionMajor

{- Higher-level helpers -}

{- | 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 :: forall (m :: * -> *).
(MonadLifx m, MonadIO m) =>
Device -> Message () -> m ()
sendMessageAndWait Device
d Message ()
m = do
    Device -> Message () -> m ()
forall r. Device -> Message r -> m r
forall (m :: * -> *) r. MonadLifx m => Device -> Message r -> m r
sendMessage Device
d Message ()
m
    m () -> (NominalDiffTime -> m ()) -> Maybe NominalDiffTime -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (NominalDiffTime -> IO ()) -> NominalDiffTime -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay (Int -> IO ())
-> (NominalDiffTime -> Int) -> NominalDiffTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Int
forall {a} {b}. (RealFrac a, Integral b) => a -> b
timeMicros) Maybe NominalDiffTime
mt
  where
    mt :: Maybe NominalDiffTime
mt = case Message ()
m of
        SetPower{} -> Maybe NominalDiffTime
forall a. Maybe a
Nothing
        SetLabel{} -> Maybe NominalDiffTime
forall a. Maybe a
Nothing
        SetColor HSBK
_ NominalDiffTime
t -> NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
t
        SetLightPower Bool
_ NominalDiffTime
t -> NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
t
    timeMicros :: a -> b
timeMicros a
t = a -> b
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
t a -> a -> a
forall a. Num a => a -> a -> a
* a
1_000_000

{- Util -}

fromIntegralSafe :: forall a b. (Integral a, Integral b, Bounded b) => a -> Maybe b
fromIntegralSafe :: forall a b. (Integral a, Integral b, Bounded b) => a -> Maybe b
fromIntegralSafe a
x =
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
        ( a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @b)
            Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
minBound @b)
        )
        Maybe () -> b -> Maybe b
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x

headerSize :: (Num a) => a
headerSize :: forall a. Num a => a
headerSize = a
36

nominalDiffTimeToInt :: forall f a r. (HasResolution r, f ~ Fixed r, Integral a) => NominalDiffTime -> a
nominalDiffTimeToInt :: forall f a r.
(HasResolution r, f ~ Fixed r, Integral a) =>
NominalDiffTime -> a
nominalDiffTimeToInt NominalDiffTime
t = Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
n
  where
    MkFixed Integer
n = forall a b. (Real a, Fractional b) => a -> b
realToFrac @Pico @f (Pico -> f) -> Pico -> f
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Pico
nominalDiffTimeToSeconds NominalDiffTime
t

-- | Inverted 'whileM'.
untilM :: (Monad m) => m Bool -> m ()
untilM :: forall (m :: * -> *). Monad m => m Bool -> m ()
untilM = m Bool -> m ()
forall (m :: * -> *). Monad m => m Bool -> m ()
whileM (m Bool -> m ()) -> (m Bool -> m Bool) -> m Bool -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not

checkPort :: (MonadLifxIO f) => PortNumber -> f ()
checkPort :: forall (f :: * -> *). MonadLifxIO f => PortNumber -> f ()
checkPort PortNumber
port = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PortNumber
port PortNumber -> PortNumber -> Bool
forall a. Eq a => a -> a -> Bool
/= PortNumber
lifxPort) (f () -> f ()) -> (LifxError -> f ()) -> LifxError -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LifxError -> f ()
forall a. LifxError -> f a
forall (m :: * -> *) a. MonadLifxIO m => LifxError -> m a
lifxThrowIO (LifxError -> f ()) -> LifxError -> f ()
forall a b. (a -> b) -> a -> b
$ PortNumber -> LifxError
UnexpectedPort PortNumber
port

-- these helpers are all used by 'sendMessage' and 'broadcastMessage'
decodeMessage :: forall b m. (Response b, MonadLifxIO m) => BS.ByteString -> m (Maybe b) -- Nothing means counter mismatch
decodeMessage :: forall b (m :: * -> *).
(Response b, MonadLifxIO m) =>
ByteString -> m (Maybe b)
decodeMessage ByteString
bs = do
    Word8
counter <- m Word8
forall (m :: * -> *). MonadLifxIO m => m Word8
getCounter
    case Get Header
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, Header)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail Get Header
forall t. Binary t => Get t
Binary.get (ByteString
 -> Either
      (ByteString, ByteOffset, String) (ByteString, ByteOffset, Header))
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, Header)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
bs of
        Left (ByteString, ByteOffset, String)
e -> (ByteString, ByteOffset, String) -> m (Maybe b)
forall {m :: * -> *} {a}.
MonadLifxIO m =>
(ByteString, ByteOffset, String) -> m a
throwDecodeFailure (ByteString, ByteOffset, String)
e
        Right (ByteString
bs', ByteOffset
_, Header{Word16
$sel:packetType:Header :: Header -> Word16
packetType :: Word16
packetType, Word8
$sel:sequenceCounter:Header :: Header -> Word8
sequenceCounter :: Word8
sequenceCounter}) ->
            if Word8
sequenceCounter Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
counter
                then Word8 -> Word8 -> Word16 -> ByteString -> m ()
forall (m :: * -> *).
MonadLifxIO m =>
Word8 -> Word8 -> Word16 -> ByteString -> m ()
handleOldMessage Word8
counter Word8
sequenceCounter Word16
packetType ByteString
bs' m () -> m (Maybe b) -> m (Maybe b)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe b -> m (Maybe b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing
                else do
                    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
packetType Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= forall a. Response a => Word16
expectedPacketType @b) (m () -> m ()) -> (LifxError -> m ()) -> LifxError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LifxError -> m ()
forall a. LifxError -> m a
forall (m :: * -> *) a. MonadLifxIO m => LifxError -> m a
lifxThrowIO (LifxError -> m ()) -> LifxError -> m ()
forall a b. (a -> b) -> a -> b
$
                        Word16 -> Word16 -> LifxError
WrongPacketType (forall a. Response a => Word16
expectedPacketType @b) Word16
packetType
                    case Get b
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, b)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail Get b
forall a. Response a => Get a
getBody ByteString
bs' of
                        Left (ByteString, ByteOffset, String)
e -> (ByteString, ByteOffset, String) -> m (Maybe b)
forall {m :: * -> *} {a}.
MonadLifxIO m =>
(ByteString, ByteOffset, String) -> m a
throwDecodeFailure (ByteString, ByteOffset, String)
e
                        Right (ByteString
_, ByteOffset
_, b
res) -> Maybe b -> m (Maybe b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe b -> m (Maybe b)) -> Maybe b -> m (Maybe b)
forall a b. (a -> b) -> a -> b
$ b -> Maybe b
forall a. a -> Maybe a
Just b
res
  where
    throwDecodeFailure :: (ByteString, ByteOffset, String) -> m a
throwDecodeFailure (ByteString
bs', ByteOffset
bo, String
e) = LifxError -> m a
forall a. LifxError -> m a
forall (m :: * -> *) a. MonadLifxIO m => LifxError -> m a
lifxThrowIO (LifxError -> m a) -> LifxError -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteOffset -> String -> LifxError
DecodeFailure (ByteString -> ByteString
BL.toStrict ByteString
bs') ByteOffset
bo String
e
sendMessage' :: (MonadLifxIO m) => Bool -> HostAddress -> Message r -> m ()
sendMessage' :: forall (m :: * -> *) r.
MonadLifxIO m =>
Bool -> HostAddress -> Message r -> m ()
sendMessage' Bool
tagged HostAddress
receiver Message r
msg = do
    Socket
sock <- m Socket
forall (m :: * -> *). MonadLifxIO m => m Socket
getSocket
    Word8
counter <- m Word8
forall (m :: * -> *). MonadLifxIO m => m Word8
getCounter
    HostAddress
source <- m HostAddress
forall (m :: * -> *). MonadLifxIO m => m HostAddress
getSource
    m Int -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Int -> m ()) -> (IO Int -> m Int) -> IO Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m ()) -> IO Int -> m ()
forall a b. (a -> b) -> a -> b
$
        Socket -> ByteString -> SockAddr -> IO Int
sendTo
            Socket
sock
            (ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Word8 -> HostAddress -> Message r -> ByteString
forall r.
Bool -> Bool -> Word8 -> HostAddress -> Message r -> ByteString
encodeMessage Bool
tagged Bool
False Word8
counter HostAddress
source Message r
msg)
            (PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
lifxPort HostAddress
receiver)
hostAddressFromSock :: (MonadLifxIO m) => SockAddr -> m HostAddress
hostAddressFromSock :: forall (m :: * -> *). MonadLifxIO m => SockAddr -> m HostAddress
hostAddressFromSock = \case
    SockAddrInet PortNumber
port HostAddress
ha -> PortNumber -> m ()
forall (f :: * -> *). MonadLifxIO f => PortNumber -> f ()
checkPort PortNumber
port m () -> m HostAddress -> m HostAddress
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HostAddress -> m HostAddress
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HostAddress
ha
    SockAddr
addr -> LifxError -> m HostAddress
forall a. LifxError -> m a
forall (m :: * -> *) a. MonadLifxIO m => LifxError -> m a
lifxThrowIO (LifxError -> m HostAddress) -> LifxError -> m HostAddress
forall a b. (a -> b) -> a -> b
$ SockAddr -> LifxError
UnexpectedSockAddrType SockAddr
addr
receiveMessage :: (MonadLifxIO m) => Int -> Int -> m (Maybe (BS.ByteString, SockAddr))
receiveMessage :: forall (m :: * -> *).
MonadLifxIO m =>
Int -> Int -> m (Maybe (ByteString, SockAddr))
receiveMessage Int
t Int
size = do
    Socket
sock <- m Socket
forall (m :: * -> *). MonadLifxIO m => m Socket
getSocket
    IO (Maybe (ByteString, SockAddr))
-> m (Maybe (ByteString, SockAddr))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        (IO (Maybe (ByteString, SockAddr))
 -> m (Maybe (ByteString, SockAddr)))
-> (Int -> IO (Maybe (ByteString, SockAddr)))
-> Int
-> m (Maybe (ByteString, SockAddr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> IO (ByteString, SockAddr) -> IO (Maybe (ByteString, SockAddr))
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
t
        (IO (ByteString, SockAddr) -> IO (Maybe (ByteString, SockAddr)))
-> (Int -> IO (ByteString, SockAddr))
-> Int
-> IO (Maybe (ByteString, SockAddr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> Int -> IO (ByteString, SockAddr)
recvFrom Socket
sock
        (Int -> m (Maybe (ByteString, SockAddr)))
-> Int -> m (Maybe (ByteString, SockAddr))
forall a b. (a -> b) -> a -> b
$ Int
forall a. Num a => a
headerSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size

broadcast :: (MonadLifxIO m) => Message r -> m ()
broadcast :: forall (m :: * -> *) r. MonadLifxIO m => Message r -> m ()
broadcast Message r
msg = do
    m ()
forall (m :: * -> *). MonadLifxIO m => m ()
incrementCounter
    Bool -> HostAddress -> Message r -> m ()
forall (m :: * -> *) r.
MonadLifxIO m =>
Bool -> HostAddress -> Message r -> m ()
sendMessage' Bool
False ((Word8, Word8, Word8, Word8) -> HostAddress
tupleToHostAddress (Word8
255, Word8
255, Word8
255, Word8
255)) Message r
msg

showDecodeError :: UnicodeException -> String
showDecodeError :: UnicodeException -> String
showDecodeError = \case
    DecodeError String
s Maybe Word8
_ -> String
s
    UnicodeException
_ -> String
"impossible"