module Lifx.Lan where

import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import Data.Binary
import Data.Binary.Put
import Data.Bits
import Data.ByteString.Lazy qualified as BL
import GHC.Generics (Generic)
import Network.Socket
import Network.Socket.ByteString
import System.Random

{- Core -}

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

sendMessage :: MonadLifx m => HostAddress -> Message -> m ()
sendMessage :: HostAddress -> Message -> m ()
sendMessage HostAddress
lightAddr Message
msg = do
    Socket
sock <- m Socket
forall (m :: * -> *). MonadLifx m => m Socket
getSocket
    HostAddress
source <- m HostAddress
forall (m :: * -> *). MonadLifx m => m HostAddress
getSource
    Word8
sequenceCounter <- m Word8
forall (m :: * -> *). MonadLifx m => m Word8
getCounter
    m ()
forall (m :: * -> *). MonadLifx m => m ()
incrementCounter
    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 (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 -> Word8 -> HostAddress -> Message -> ByteString
encodeMessage Bool
False Word8
sequenceCounter HostAddress
source Message
msg)
            (PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
lifxPort HostAddress
lightAddr)

data HSBK = HSBK
    { HSBK -> Word16
hue :: Word16
    , HSBK -> Word16
saturation :: Word16
    , HSBK -> Word16
brightness :: Word16
    , HSBK -> Word16
kelvin :: Word16
    }
    deriving (HSBK -> HSBK -> Bool
(HSBK -> HSBK -> Bool) -> (HSBK -> HSBK -> Bool) -> Eq HSBK
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HSBK -> HSBK -> Bool
$c/= :: HSBK -> HSBK -> Bool
== :: HSBK -> HSBK -> Bool
$c== :: HSBK -> HSBK -> Bool
Eq, Eq HSBK
Eq HSBK
-> (HSBK -> HSBK -> Ordering)
-> (HSBK -> HSBK -> Bool)
-> (HSBK -> HSBK -> Bool)
-> (HSBK -> HSBK -> Bool)
-> (HSBK -> HSBK -> Bool)
-> (HSBK -> HSBK -> HSBK)
-> (HSBK -> HSBK -> HSBK)
-> Ord HSBK
HSBK -> HSBK -> Bool
HSBK -> HSBK -> Ordering
HSBK -> HSBK -> HSBK
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
min :: HSBK -> HSBK -> HSBK
$cmin :: HSBK -> HSBK -> HSBK
max :: HSBK -> HSBK -> HSBK
$cmax :: HSBK -> HSBK -> HSBK
>= :: HSBK -> HSBK -> Bool
$c>= :: HSBK -> HSBK -> Bool
> :: HSBK -> HSBK -> Bool
$c> :: HSBK -> HSBK -> Bool
<= :: HSBK -> HSBK -> Bool
$c<= :: HSBK -> HSBK -> Bool
< :: HSBK -> HSBK -> Bool
$c< :: HSBK -> HSBK -> Bool
compare :: HSBK -> HSBK -> Ordering
$ccompare :: HSBK -> HSBK -> Ordering
$cp1Ord :: Eq HSBK
Ord, Int -> HSBK -> ShowS
[HSBK] -> ShowS
HSBK -> String
(Int -> HSBK -> ShowS)
-> (HSBK -> String) -> ([HSBK] -> ShowS) -> Show HSBK
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HSBK] -> ShowS
$cshowList :: [HSBK] -> ShowS
show :: HSBK -> String
$cshow :: HSBK -> String
showsPrec :: Int -> HSBK -> ShowS
$cshowsPrec :: Int -> HSBK -> ShowS
Show, (forall x. HSBK -> Rep HSBK x)
-> (forall x. Rep HSBK x -> HSBK) -> Generic HSBK
forall x. Rep HSBK x -> HSBK
forall x. HSBK -> Rep HSBK x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HSBK x -> HSBK
$cfrom :: forall x. HSBK -> Rep HSBK x
Generic)
newtype Duration = Duration Word32
    deriving (Duration -> Duration -> Bool
(Duration -> Duration -> Bool)
-> (Duration -> Duration -> Bool) -> Eq Duration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Duration -> Duration -> Bool
$c/= :: Duration -> Duration -> Bool
== :: Duration -> Duration -> Bool
$c== :: Duration -> Duration -> Bool
Eq, Eq Duration
Eq Duration
-> (Duration -> Duration -> Ordering)
-> (Duration -> Duration -> Bool)
-> (Duration -> Duration -> Bool)
-> (Duration -> Duration -> Bool)
-> (Duration -> Duration -> Bool)
-> (Duration -> Duration -> Duration)
-> (Duration -> Duration -> Duration)
-> Ord Duration
Duration -> Duration -> Bool
Duration -> Duration -> Ordering
Duration -> Duration -> Duration
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
min :: Duration -> Duration -> Duration
$cmin :: Duration -> Duration -> Duration
max :: Duration -> Duration -> Duration
$cmax :: Duration -> Duration -> Duration
>= :: Duration -> Duration -> Bool
$c>= :: Duration -> Duration -> Bool
> :: Duration -> Duration -> Bool
$c> :: Duration -> Duration -> Bool
<= :: Duration -> Duration -> Bool
$c<= :: Duration -> Duration -> Bool
< :: Duration -> Duration -> Bool
$c< :: Duration -> Duration -> Bool
compare :: Duration -> Duration -> Ordering
$ccompare :: Duration -> Duration -> Ordering
$cp1Ord :: Eq Duration
Ord, Int -> Duration -> ShowS
[Duration] -> ShowS
Duration -> String
(Int -> Duration -> ShowS)
-> (Duration -> String) -> ([Duration] -> ShowS) -> Show Duration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Duration] -> ShowS
$cshowList :: [Duration] -> ShowS
show :: Duration -> String
$cshow :: Duration -> String
showsPrec :: Int -> Duration -> ShowS
$cshowsPrec :: Int -> Duration -> ShowS
Show, (forall x. Duration -> Rep Duration x)
-> (forall x. Rep Duration x -> Duration) -> Generic Duration
forall x. Rep Duration x -> Duration
forall x. Duration -> Rep Duration x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Duration x -> Duration
$cfrom :: forall x. Duration -> Rep Duration x
Generic)

-- | https://lan.developer.lifx.com/docs/changing-a-device
data Message
    = SetPower Bool
    | SetColor HSBK Duration
    | SetLightPower Bool Duration

{- Monad -}

type Lifx = LifxT IO
newtype LifxT m a = LifxT {LifxT m a -> StateT Word8 (ReaderT (Socket, HostAddress) m) a
unLifxT :: StateT Word8 (ReaderT (Socket, Word32) m) a}
    deriving newtype (a -> LifxT m b -> LifxT m a
(a -> b) -> LifxT m a -> LifxT m b
(forall a b. (a -> b) -> LifxT m a -> LifxT m b)
-> (forall a b. a -> LifxT m b -> LifxT m a) -> Functor (LifxT m)
forall a b. a -> LifxT m b -> LifxT m a
forall a b. (a -> b) -> LifxT m a -> LifxT m b
forall (m :: * -> *) a b. Functor m => a -> LifxT m b -> LifxT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LifxT m a -> LifxT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> LifxT m b -> LifxT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> LifxT m b -> LifxT m a
fmap :: (a -> b) -> LifxT m a -> LifxT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LifxT m a -> LifxT m b
Functor, Functor (LifxT m)
a -> LifxT m a
Functor (LifxT m)
-> (forall a. a -> LifxT m a)
-> (forall a b. LifxT m (a -> b) -> LifxT m a -> LifxT m b)
-> (forall a b c.
    (a -> b -> c) -> LifxT m a -> LifxT m b -> LifxT m c)
-> (forall a b. LifxT m a -> LifxT m b -> LifxT m b)
-> (forall a b. LifxT m a -> LifxT m b -> LifxT m a)
-> Applicative (LifxT m)
LifxT m a -> LifxT m b -> LifxT m b
LifxT m a -> LifxT m b -> LifxT m a
LifxT m (a -> b) -> LifxT m a -> LifxT m b
(a -> b -> c) -> LifxT m a -> LifxT m b -> LifxT m c
forall a. a -> LifxT m a
forall a b. LifxT m a -> LifxT m b -> LifxT m a
forall a b. LifxT m a -> LifxT m b -> LifxT m b
forall a b. LifxT m (a -> b) -> LifxT m a -> LifxT m b
forall a b c. (a -> b -> c) -> LifxT m a -> LifxT m b -> LifxT m c
forall (m :: * -> *). Monad m => Functor (LifxT m)
forall (m :: * -> *) a. Monad m => a -> LifxT m a
forall (m :: * -> *) a b.
Monad m =>
LifxT m a -> LifxT m b -> LifxT m a
forall (m :: * -> *) a b.
Monad m =>
LifxT m a -> LifxT m b -> LifxT m b
forall (m :: * -> *) a b.
Monad m =>
LifxT m (a -> b) -> LifxT m a -> LifxT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> LifxT m a -> LifxT m b -> LifxT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: LifxT m a -> LifxT m b -> LifxT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
LifxT m a -> LifxT m b -> LifxT m a
*> :: LifxT m a -> LifxT m b -> LifxT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
LifxT m a -> LifxT m b -> LifxT m b
liftA2 :: (a -> b -> c) -> LifxT m a -> LifxT m b -> LifxT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> LifxT m a -> LifxT m b -> LifxT m c
<*> :: LifxT m (a -> b) -> LifxT m a -> LifxT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
LifxT m (a -> b) -> LifxT m a -> LifxT m b
pure :: a -> LifxT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> LifxT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (LifxT m)
Applicative, Applicative (LifxT m)
a -> LifxT m a
Applicative (LifxT m)
-> (forall a b. LifxT m a -> (a -> LifxT m b) -> LifxT m b)
-> (forall a b. LifxT m a -> LifxT m b -> LifxT m b)
-> (forall a. a -> LifxT m a)
-> Monad (LifxT m)
LifxT m a -> (a -> LifxT m b) -> LifxT m b
LifxT m a -> LifxT m b -> LifxT m b
forall a. a -> LifxT m a
forall a b. LifxT m a -> LifxT m b -> LifxT m b
forall a b. LifxT m a -> (a -> LifxT m b) -> LifxT m b
forall (m :: * -> *). Monad m => Applicative (LifxT m)
forall (m :: * -> *) a. Monad m => a -> LifxT m a
forall (m :: * -> *) a b.
Monad m =>
LifxT m a -> LifxT m b -> LifxT m b
forall (m :: * -> *) a b.
Monad m =>
LifxT m a -> (a -> LifxT m b) -> LifxT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> LifxT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> LifxT m a
>> :: LifxT m a -> LifxT m b -> LifxT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
LifxT m a -> LifxT m b -> LifxT m b
>>= :: LifxT m a -> (a -> LifxT m b) -> LifxT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
LifxT m a -> (a -> LifxT m b) -> LifxT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (LifxT m)
Monad, Monad (LifxT m)
Monad (LifxT m)
-> (forall a. IO a -> LifxT m a) -> MonadIO (LifxT m)
IO a -> LifxT m a
forall a. IO a -> LifxT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (LifxT m)
forall (m :: * -> *) a. MonadIO m => IO a -> LifxT m a
liftIO :: IO a -> LifxT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> LifxT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (LifxT m)
MonadIO, MonadReader (Socket, Word32), MonadState Word8)

runLifx :: Lifx a -> IO a
runLifx :: Lifx a -> IO a
runLifx = Lifx a -> IO a
forall (m :: * -> *) a. MonadIO m => LifxT m a -> m a
runLifxT
runLifxT :: MonadIO m => LifxT m a -> m a
runLifxT :: LifxT m a -> m a
runLifxT (LifxT StateT Word8 (ReaderT (Socket, HostAddress) m) a
x) = do
    Socket
sock <- IO Socket -> m Socket
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 (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 HostAddress
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
    ReaderT (Socket, HostAddress) m a -> (Socket, HostAddress) -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT Word8 (ReaderT (Socket, HostAddress) m) a
-> Word8 -> ReaderT (Socket, HostAddress) m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT Word8 (ReaderT (Socket, HostAddress) m) a
x Word8
0) (Socket
sock, HostAddress
source)

class MonadIO m => MonadLifx m where
    getSocket :: m Socket
    getSource :: m Word32
    incrementCounter :: m ()
    getCounter :: m Word8
instance MonadIO m => MonadLifx (LifxT m) where
    getSocket :: LifxT m Socket
getSocket = ((Socket, HostAddress) -> Socket) -> LifxT m Socket
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Socket, HostAddress) -> Socket
forall a b. (a, b) -> a
fst
    getSource :: LifxT m HostAddress
getSource = ((Socket, HostAddress) -> HostAddress) -> LifxT m HostAddress
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Socket, HostAddress) -> HostAddress
forall a b. (a, b) -> b
snd
    incrementCounter :: LifxT m ()
incrementCounter = (Word8 -> Word8) -> LifxT m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify Word8 -> Word8
forall a. (Eq a, Bounded a, Enum a) => a -> a
succ'
    getCounter :: LifxT m Word8
getCounter = (Word8 -> Word8) -> LifxT m Word8
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Word8 -> Word8
forall a. a -> a
id
instance MonadLifx m => MonadLifx (StateT s m) where
    getSocket :: StateT s m Socket
getSocket = m Socket -> StateT s m Socket
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Socket
forall (m :: * -> *). MonadLifx m => m Socket
getSocket
    getSource :: StateT s m HostAddress
getSource = m HostAddress -> StateT s m HostAddress
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m HostAddress
forall (m :: * -> *). MonadLifx m => m HostAddress
getSource
    incrementCounter :: StateT s m ()
incrementCounter = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
forall (m :: * -> *). MonadLifx m => m ()
incrementCounter
    getCounter :: StateT s m Word8
getCounter = m Word8 -> StateT s m Word8
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Word8
forall (m :: * -> *). MonadLifx m => m Word8
getCounter
instance MonadLifx m => MonadLifx (ReaderT e m) where
    getSocket :: ReaderT e m Socket
getSocket = m Socket -> ReaderT e m Socket
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Socket
forall (m :: * -> *). MonadLifx m => m Socket
getSocket
    getSource :: ReaderT e m HostAddress
getSource = m HostAddress -> ReaderT e m HostAddress
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m HostAddress
forall (m :: * -> *). MonadLifx m => m HostAddress
getSource
    incrementCounter :: ReaderT e m ()
incrementCounter = m () -> ReaderT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ()
forall (m :: * -> *). MonadLifx m => m ()
incrementCounter
    getCounter :: ReaderT e m Word8
getCounter = m Word8 -> ReaderT e m Word8
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Word8
forall (m :: * -> *). MonadLifx m => m Word8
getCounter

{- Low level -}

encodeMessage :: Bool -> Word8 -> Word32 -> Message -> BL.ByteString
encodeMessage :: Bool -> Word8 -> HostAddress -> Message -> ByteString
encodeMessage Bool
ackRequired Word8
sequenceCounter HostAddress
source Message
msg =
    Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Header -> Put
putHeader (Bool -> Word8 -> HostAddress -> Message -> Header
messageHeader Bool
ackRequired Word8
sequenceCounter HostAddress
source Message
msg) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Message -> Put
putMessagePayload Message
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
    }

putHeader :: Header -> Put
putHeader :: Header -> Put
putHeader Header{Bool
Word8
Word16
HostAddress
Word64
packetType :: Word16
sequenceCounter :: Word8
ackRequired :: Bool
resRequired :: Bool
target :: Word64
source :: HostAddress
origin :: Word8
tagged :: Bool
addressable :: Bool
protocol :: Word16
size :: Word16
packetType :: Header -> Word16
sequenceCounter :: Header -> Word8
ackRequired :: Header -> Bool
resRequired :: Header -> Bool
target :: Header -> Word64
source :: Header -> HostAddress
origin :: Header -> Word8
tagged :: Header -> Bool
addressable :: Header -> Bool
protocol :: Header -> Word16
size :: Header -> 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 p. Bits p => Bool -> Int -> p
bitIf Bool
addressable Int
12
            Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Bool -> Int -> Word16
forall p. Bits p => Bool -> Int -> p
bitIf Bool
tagged Int
13
            Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Bool -> Int -> Word16
forall p. Bits p => Bool -> Int -> p
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 p. Bits p => Bool -> Int -> p
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 p. Bits p => Bool -> Int -> p
bitIf Bool
resRequired Int
0
            Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Bool -> Int -> Word8
forall p. Bits p => Bool -> Int -> p
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 -> p
bitIf Bool
b Int
n = if Bool
b then Int -> p
forall a. Bits a => Int -> a
bit Int
n else p
forall a. Bits a => a
zeroBits

messageHeader :: Bool -> Word8 -> Word32 -> Message -> Header
messageHeader :: Bool -> Word8 -> HostAddress -> Message -> Header
messageHeader Bool
ackRequired Word8
sequenceCounter HostAddress
source = \case
    SetPower{} ->
        Header :: Word16
-> Word16
-> Bool
-> Bool
-> Word8
-> HostAddress
-> Word64
-> Bool
-> Bool
-> Word8
-> Word16
-> Header
Header
            { size :: Word16
size = Word16
headerSize Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
2
            , packetType :: Word16
packetType = Word16
21
            , Bool
Word8
Word16
HostAddress
Word64
resRequired :: Bool
origin :: Word8
addressable :: Bool
tagged :: Bool
protocol :: Word16
target :: Word64
source :: HostAddress
sequenceCounter :: Word8
ackRequired :: Bool
sequenceCounter :: Word8
ackRequired :: Bool
resRequired :: Bool
target :: Word64
source :: HostAddress
origin :: Word8
tagged :: Bool
addressable :: Bool
protocol :: Word16
..
            }
    SetColor{} ->
        Header :: Word16
-> Word16
-> Bool
-> Bool
-> Word8
-> HostAddress
-> Word64
-> Bool
-> Bool
-> Word8
-> Word16
-> Header
Header
            { size :: Word16
size = Word16
headerSize Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
13
            , packetType :: Word16
packetType = Word16
102
            , Bool
Word8
Word16
HostAddress
Word64
resRequired :: Bool
origin :: Word8
addressable :: Bool
tagged :: Bool
protocol :: Word16
target :: Word64
source :: HostAddress
sequenceCounter :: Word8
ackRequired :: Bool
sequenceCounter :: Word8
ackRequired :: Bool
resRequired :: Bool
target :: Word64
source :: HostAddress
origin :: Word8
tagged :: Bool
addressable :: Bool
protocol :: Word16
..
            }
    SetLightPower{} ->
        Header :: Word16
-> Word16
-> Bool
-> Bool
-> Word8
-> HostAddress
-> Word64
-> Bool
-> Bool
-> Word8
-> Word16
-> Header
Header
            { size :: Word16
size = Word16
headerSize Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
6
            , packetType :: Word16
packetType = Word16
117
            , Bool
Word8
Word16
HostAddress
Word64
resRequired :: Bool
origin :: Word8
addressable :: Bool
tagged :: Bool
protocol :: Word16
target :: Word64
source :: HostAddress
sequenceCounter :: Word8
ackRequired :: Bool
sequenceCounter :: Word8
ackRequired :: Bool
resRequired :: Bool
target :: Word64
source :: HostAddress
origin :: Word8
tagged :: Bool
addressable :: Bool
protocol :: Word16
..
            }
  where
    target :: Word64
target = Word64
0
    headerSize :: Word16
headerSize = Word16
36
    protocol :: Word16
protocol = Word16
1024
    tagged :: Bool
tagged = Bool
True
    addressable :: Bool
addressable = Bool
True
    origin :: Word8
origin = Word8
0
    resRequired :: Bool
resRequired = Bool
False

putMessagePayload :: Message -> Put
putMessagePayload :: Message -> Put
putMessagePayload = \case
    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
    SetColor HSBK{Word16
kelvin :: Word16
brightness :: Word16
saturation :: Word16
hue :: Word16
kelvin :: HSBK -> Word16
brightness :: HSBK -> Word16
saturation :: HSBK -> Word16
hue :: HSBK -> Word16
..} (Duration HostAddress
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
d
    SetLightPower Bool
b (Duration HostAddress
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
d

{- Util -}

-- | Safe, wraparound variant of 'succ'.
succ' :: (Eq a, Bounded a, Enum a) => a -> a
succ' :: a -> a
succ' a
e
    | a
e a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
maxBound = a
forall a. Bounded a => a
minBound
    | Bool
otherwise = a -> a
forall a. Enum a => a -> a
succ a
e