{-# LANGUAGE UndecidableInstances #-}

module Lifx.Lan.Internal where

import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Binary.Get
import Data.List
import Data.Tuple.Extra
import Data.Word
import Network.Socket

import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import GHC.Generics (Generic)

import Lifx.Internal.ProductInfoMap (ProductLookupError)

-- | A LIFX device, such as a bulb.
newtype Device = Device {Device -> HostAddress
unwrap :: HostAddress}
    deriving newtype (Device -> Device -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Device -> Device -> Bool
$c/= :: Device -> Device -> Bool
== :: Device -> Device -> Bool
$c== :: Device -> Device -> Bool
Eq, Eq Device
Device -> Device -> Bool
Device -> Device -> Ordering
Device -> Device -> Device
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 :: Device -> Device -> Device
$cmin :: Device -> Device -> Device
max :: Device -> Device -> Device
$cmax :: Device -> Device -> Device
>= :: Device -> Device -> Bool
$c>= :: Device -> Device -> Bool
> :: Device -> Device -> Bool
$c> :: Device -> Device -> Bool
<= :: Device -> Device -> Bool
$c<= :: Device -> Device -> Bool
< :: Device -> Device -> Bool
$c< :: Device -> Device -> Bool
compare :: Device -> Device -> Ordering
$ccompare :: Device -> Device -> Ordering
Ord)

instance Show Device where
    show :: Device -> String
show (Device HostAddress
ha) = let (Word8
a, Word8
b, Word8
c, Word8
d) = HostAddress -> (Word8, Word8, Word8, Word8)
hostAddressToTuple HostAddress
ha in forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Word8
a, Word8
b, Word8
c, Word8
d]

-- | A colour. See https://lan.developer.lifx.com/docs/representing-color-with-hsbk.
data HSBK = HSBK
    { HSBK -> Word16
hue :: Word16
    , HSBK -> Word16
saturation :: Word16
    , HSBK -> Word16
brightness :: Word16
    , HSBK -> Word16
kelvin :: Word16
    -- ^ takes values in the range 1500 to 9000
    }
    deriving (HSBK -> HSBK -> Bool
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
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
Ord, Int -> HSBK -> ShowS
[HSBK] -> ShowS
HSBK -> String
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. 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)

data LifxError
    = DecodeFailure BS.ByteString ByteOffset String
    | RecvTimeout
    | BroadcastTimeout [HostAddress] -- contains the addresses which we have received valid responses from
    | WrongPacketType Word16 Word16 -- expected, then actual
    | WrongSender Device HostAddress -- expected, then actual
    | UnexpectedSockAddrType SockAddr
    | UnexpectedPort PortNumber
    | ProductLookupError ProductLookupError
    deriving (LifxError -> LifxError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LifxError -> LifxError -> Bool
$c/= :: LifxError -> LifxError -> Bool
== :: LifxError -> LifxError -> Bool
$c== :: LifxError -> LifxError -> Bool
Eq, Eq LifxError
LifxError -> LifxError -> Bool
LifxError -> LifxError -> Ordering
LifxError -> LifxError -> LifxError
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 :: LifxError -> LifxError -> LifxError
$cmin :: LifxError -> LifxError -> LifxError
max :: LifxError -> LifxError -> LifxError
$cmax :: LifxError -> LifxError -> LifxError
>= :: LifxError -> LifxError -> Bool
$c>= :: LifxError -> LifxError -> Bool
> :: LifxError -> LifxError -> Bool
$c> :: LifxError -> LifxError -> Bool
<= :: LifxError -> LifxError -> Bool
$c<= :: LifxError -> LifxError -> Bool
< :: LifxError -> LifxError -> Bool
$c< :: LifxError -> LifxError -> Bool
compare :: LifxError -> LifxError -> Ordering
$ccompare :: LifxError -> LifxError -> Ordering
Ord, Int -> LifxError -> ShowS
[LifxError] -> ShowS
LifxError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LifxError] -> ShowS
$cshowList :: [LifxError] -> ShowS
show :: LifxError -> String
$cshow :: LifxError -> String
showsPrec :: Int -> LifxError -> ShowS
$cshowsPrec :: Int -> LifxError -> ShowS
Show, forall x. Rep LifxError x -> LifxError
forall x. LifxError -> Rep LifxError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LifxError x -> LifxError
$cfrom :: forall x. LifxError -> Rep LifxError x
Generic)

-- | A monad for sending and receiving LIFX messages.
class MonadIO m => MonadLifxIO m where
    getSocket :: m Socket
    getSource :: m Word32
    getTimeout :: m Int
    incrementCounter :: m ()
    getCounter :: m Word8
    lifxThrowIO :: LifxError -> m a
    handleOldMessage ::
        -- | expected counter value
        Word8 ->
        -- | actual counter value
        Word8 ->
        -- | packet type
        Word16 ->
        -- | payload
        BL.ByteString ->
        m ()
    handleOldMessage Word8
_ Word8
_ Word16
_ ByteString
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance MonadIO m => MonadLifxIO (LifxT m) where
    getSocket :: LifxT m Socket
getSocket = forall (m :: * -> *) a.
StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
-> LifxT m a
LifxT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b c. (a, b, c) -> a
fst3
    getSource :: LifxT m HostAddress
getSource = forall (m :: * -> *) a.
StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
-> LifxT m a
LifxT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b c. (a, b, c) -> b
snd3
    getTimeout :: LifxT m Int
getTimeout = forall (m :: * -> *) a.
StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
-> LifxT m a
LifxT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b c. (a, b, c) -> c
thd3
    incrementCounter :: LifxT m ()
incrementCounter = forall (m :: * -> *) a.
StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
-> LifxT m a
LifxT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a. (Eq a, Bounded a, Enum a) => a -> a
succ'
    getCounter :: LifxT m Word8
getCounter = forall (m :: * -> *) a.
StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
-> LifxT m a
LifxT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. a -> a
id
    lifxThrowIO :: forall a. LifxError -> LifxT m a
lifxThrowIO = forall (m :: * -> *) a.
StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
-> LifxT m a
LifxT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

newtype LifxT m a = LifxT
    { forall (m :: * -> *) a.
LifxT m a
-> StateT
     Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
unwrap ::
        StateT
            Word8
            ( ReaderT
                (Socket, Word32, Int)
                ( ExceptT
                    LifxError
                    m
                )
            )
            a
    }
    deriving newtype
        ( 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
<$ :: forall a b. a -> LifxT m b -> LifxT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> LifxT m b -> LifxT m a
fmap :: forall a b. (a -> b) -> LifxT m a -> LifxT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LifxT m a -> LifxT m b
Functor
        , 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
<* :: forall a b. 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
*> :: forall a b. 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 :: forall a b c. (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
<*> :: forall a b. 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 :: forall a. a -> LifxT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> LifxT m a
Applicative
        , 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 :: forall a. a -> LifxT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> LifxT m a
>> :: forall a b. 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
>>= :: forall a 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
Monad
        , 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 :: forall a. IO a -> LifxT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> LifxT m a
MonadIO
        )

instance MonadTrans LifxT where
    lift :: forall (m :: * -> *) a. Monad m => m a -> LifxT m a
lift = forall (m :: * -> *) a.
StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
-> LifxT m a
LifxT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
instance MonadReader s m => MonadReader s (LifxT m) where
    ask :: LifxT m s
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
    local :: forall a. (s -> s) -> LifxT m a -> LifxT m a
local s -> s
f LifxT m a
m = forall (m :: * -> *) a.
StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
-> LifxT m a
LifxT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT \Word8
s -> forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT \(Socket, HostAddress, Int)
e ->
        forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local s -> s
f forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(Socket, HostAddress, Int)
-> Word8 -> LifxT m a -> m (Either LifxError (a, Word8))
unLifx (Socket, HostAddress, Int)
e Word8
s LifxT m a
m
instance MonadState s m => MonadState s (LifxT m) where
    state :: forall a. (s -> (a, s)) -> LifxT m a
state = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state
instance MonadError e m => MonadError e (LifxT m) where
    throwError :: forall a. e -> LifxT m a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError @e @m
    catchError :: forall a. LifxT m a -> (e -> LifxT m a) -> LifxT m a
catchError LifxT m a
m e -> LifxT m a
h = forall (m :: * -> *) a.
StateT
  Word8 (ReaderT (Socket, HostAddress, Int) (ExceptT LifxError m)) a
-> LifxT m a
LifxT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT \Word8
s -> forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT \(Socket, HostAddress, Int)
e ->
        forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError @e @m (forall (m :: * -> *) a.
(Socket, HostAddress, Int)
-> Word8 -> LifxT m a -> m (Either LifxError (a, Word8))
unLifx (Socket, HostAddress, Int)
e Word8
s LifxT m a
m) (forall (m :: * -> *) a.
(Socket, HostAddress, Int)
-> Word8 -> LifxT m a -> m (Either LifxError (a, Word8))
unLifx (Socket, HostAddress, Int)
e Word8
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> LifxT m a
h)

unLifx :: (Socket, Word32, Int) -> Word8 -> LifxT m a -> m (Either LifxError (a, Word8))
unLifx :: forall (m :: * -> *) a.
(Socket, HostAddress, Int)
-> Word8 -> LifxT m a -> m (Either LifxError (a, Word8))
unLifx (Socket, HostAddress, Int)
e Word8
s = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Socket, HostAddress, Int)
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Word8
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.unwrap)

{- Util -}

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