{-# LANGUAGE OverloadedStrings, RecordWildCards, GeneralizedNewtypeDeriving #-}
module Lighthouse.Connection
    ( -- * The LighthouseIO monad
      LighthouseIO (..), Listener (..)
    , runLighthouseApp, runLighthouseIO, getUserState, putUserState, modifyUserState
      -- * Communication with the lighthouse
    , sendRequest, sendDisplay, requestStream, sendClose
    , receiveEvent
    ) where

import Control.Monad ((<=<), when)
import Control.Monad.State.Class (MonadState (..), gets, modify)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Control.Monad.Trans.State (StateT, evalStateT)
import qualified Data.ByteString.Lazy as BL
import Data.Foldable (traverse_)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.MessagePack as MP
import qualified Data.Text as T
import Lighthouse.Display
import Lighthouse.Options
import Lighthouse.Protocol
import Lighthouse.Utils.General (whileM_)
import Lighthouse.Utils.Logging
import Lighthouse.Utils.Serializable
import Network.Socket (withSocketsDo)
import qualified Network.WebSockets as WS
import qualified Wuss as WSS

-- | Stores the WebSocket connection and the credentials.
data ConnectionState s = ConnectionState
    { forall s. ConnectionState s -> Connection
csConnection :: WS.Connection
    , forall s. ConnectionState s -> Options s
csOptions    :: Options s
    , forall s. ConnectionState s -> Int
csRequestId  :: Int
    , forall s. ConnectionState s -> Bool
csClosed     :: Bool
    , forall s. ConnectionState s -> s
csUserState  :: s
    }

-- Implementation note: We use the trick from https://stackoverflow.com/a/32572657 to
-- define our monad transformer stack using a newtype and derive most instances with
-- GeneralizedNewtypeDeriving.

-- | The central IO-ish monad to be used by lighthouse applications. Holds a connection.
newtype LighthouseIO s a = LighthouseIO (StateT (ConnectionState s) IO a)
    deriving ((forall a b. (a -> b) -> LighthouseIO s a -> LighthouseIO s b)
-> (forall a b. a -> LighthouseIO s b -> LighthouseIO s a)
-> Functor (LighthouseIO s)
forall a b. a -> LighthouseIO s b -> LighthouseIO s a
forall a b. (a -> b) -> LighthouseIO s a -> LighthouseIO s b
forall s a b. a -> LighthouseIO s b -> LighthouseIO s a
forall s a b. (a -> b) -> LighthouseIO s a -> LighthouseIO s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall s a b. (a -> b) -> LighthouseIO s a -> LighthouseIO s b
fmap :: forall a b. (a -> b) -> LighthouseIO s a -> LighthouseIO s b
$c<$ :: forall s a b. a -> LighthouseIO s b -> LighthouseIO s a
<$ :: forall a b. a -> LighthouseIO s b -> LighthouseIO s a
Functor, Functor (LighthouseIO s)
Functor (LighthouseIO s) =>
(forall a. a -> LighthouseIO s a)
-> (forall a b.
    LighthouseIO s (a -> b) -> LighthouseIO s a -> LighthouseIO s b)
-> (forall a b c.
    (a -> b -> c)
    -> LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s c)
-> (forall a b.
    LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b)
-> (forall a b.
    LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s a)
-> Applicative (LighthouseIO s)
forall s. Functor (LighthouseIO s)
forall a. a -> LighthouseIO s a
forall s a. a -> LighthouseIO s a
forall a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s a
forall a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b
forall a b.
LighthouseIO s (a -> b) -> LighthouseIO s a -> LighthouseIO s b
forall s a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s a
forall s a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b
forall s a b.
LighthouseIO s (a -> b) -> LighthouseIO s a -> LighthouseIO s b
forall a b c.
(a -> b -> c)
-> LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s c
forall s a b c.
(a -> b -> c)
-> LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s 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
$cpure :: forall s a. a -> LighthouseIO s a
pure :: forall a. a -> LighthouseIO s a
$c<*> :: forall s a b.
LighthouseIO s (a -> b) -> LighthouseIO s a -> LighthouseIO s b
<*> :: forall a b.
LighthouseIO s (a -> b) -> LighthouseIO s a -> LighthouseIO s b
$cliftA2 :: forall s a b c.
(a -> b -> c)
-> LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s c
liftA2 :: forall a b c.
(a -> b -> c)
-> LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s c
$c*> :: forall s a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b
*> :: forall a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b
$c<* :: forall s a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s a
<* :: forall a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s a
Applicative, Applicative (LighthouseIO s)
Applicative (LighthouseIO s) =>
(forall a b.
 LighthouseIO s a -> (a -> LighthouseIO s b) -> LighthouseIO s b)
-> (forall a b.
    LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b)
-> (forall a. a -> LighthouseIO s a)
-> Monad (LighthouseIO s)
forall s. Applicative (LighthouseIO s)
forall a. a -> LighthouseIO s a
forall s a. a -> LighthouseIO s a
forall a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b
forall a b.
LighthouseIO s a -> (a -> LighthouseIO s b) -> LighthouseIO s b
forall s a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b
forall s a b.
LighthouseIO s a -> (a -> LighthouseIO s b) -> LighthouseIO s 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
$c>>= :: forall s a b.
LighthouseIO s a -> (a -> LighthouseIO s b) -> LighthouseIO s b
>>= :: forall a b.
LighthouseIO s a -> (a -> LighthouseIO s b) -> LighthouseIO s b
$c>> :: forall s a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b
>> :: forall a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b
$creturn :: forall s a. a -> LighthouseIO s a
return :: forall a. a -> LighthouseIO s a
Monad, Monad (LighthouseIO s)
Monad (LighthouseIO s) =>
(forall a. IO a -> LighthouseIO s a) -> MonadIO (LighthouseIO s)
forall s. Monad (LighthouseIO s)
forall a. IO a -> LighthouseIO s a
forall s a. IO a -> LighthouseIO s a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall s a. IO a -> LighthouseIO s a
liftIO :: forall a. IO a -> LighthouseIO s a
MonadIO, MonadState (ConnectionState s))

instance MonadLogger (LighthouseIO s) where
    logMessage :: LogMessage -> LighthouseIO s ()
logMessage LogMessage
m = do
        LogHandler
handleMessage <- (ConnectionState s -> LogHandler) -> LighthouseIO s LogHandler
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Options s -> LogHandler
forall s. Options s -> LogHandler
optLogHandler (Options s -> LogHandler)
-> (ConnectionState s -> Options s)
-> ConnectionState s
-> LogHandler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionState s -> Options s
forall s. ConnectionState s -> Options s
csOptions)
        IO () -> LighthouseIO s ()
forall a. IO a -> LighthouseIO s a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LighthouseIO s ()) -> IO () -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ LogHandler
handleMessage LogMessage
m

-- | A listener for events from the server.
data Listener s = Listener
    { forall s. Listener s -> LighthouseIO s ()
onConnect :: LighthouseIO s ()
    , forall s. Listener s -> InputEvent -> LighthouseIO s ()
onInput   :: InputEvent -> LighthouseIO s ()
    }

instance Semigroup (Listener s) where
    Listener s
l1 <> :: Listener s -> Listener s -> Listener s
<> Listener s
l2 = Listener
        { onConnect :: LighthouseIO s ()
onConnect = Listener s -> LighthouseIO s ()
forall s. Listener s -> LighthouseIO s ()
onConnect Listener s
l1 LighthouseIO s () -> LighthouseIO s () -> LighthouseIO s ()
forall a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Listener s -> LighthouseIO s ()
forall s. Listener s -> LighthouseIO s ()
onConnect Listener s
l2
        , onInput :: InputEvent -> LighthouseIO s ()
onInput   = \InputEvent
i -> Listener s -> InputEvent -> LighthouseIO s ()
forall s. Listener s -> InputEvent -> LighthouseIO s ()
onInput Listener s
l1 InputEvent
i LighthouseIO s () -> LighthouseIO s () -> LighthouseIO s ()
forall a b.
LighthouseIO s a -> LighthouseIO s b -> LighthouseIO s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Listener s -> InputEvent -> LighthouseIO s ()
forall s. Listener s -> InputEvent -> LighthouseIO s ()
onInput Listener s
l2 InputEvent
i
        }

instance Monoid (Listener s) where
    mempty :: Listener s
mempty = Listener
        { onConnect :: LighthouseIO s ()
onConnect = () -> LighthouseIO s ()
forall a. a -> LighthouseIO s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        , onInput :: InputEvent -> LighthouseIO s ()
onInput   = \InputEvent
_ -> () -> LighthouseIO s ()
forall a. a -> LighthouseIO s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        }

-- | Passes an event to the given listener.
notifyListener :: ServerEvent -> Listener s -> LighthouseIO s ()
notifyListener :: forall s. ServerEvent -> Listener s -> LighthouseIO s ()
notifyListener ServerEvent
e Listener s
l = case ServerEvent
e of
    ServerInputEvent {InputEvent
seEvent :: InputEvent
seEvent :: ServerEvent -> InputEvent
..} -> Listener s -> InputEvent -> LighthouseIO s ()
forall s. Listener s -> InputEvent -> LighthouseIO s ()
onInput Listener s
l InputEvent
seEvent
    ServerEvent
_                     -> () -> LighthouseIO s ()
forall a. a -> LighthouseIO s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Runs a lighthouse application using the given credentials.
runLighthouseApp :: Listener s -> Options s -> IO ()
runLighthouseApp :: forall s. Listener s -> Options s -> IO ()
runLighthouseApp Listener s
listener = LighthouseIO s () -> Options s -> IO ()
forall s a. LighthouseIO s a -> Options s -> IO a
runLighthouseIO (LighthouseIO s () -> Options s -> IO ())
-> LighthouseIO s () -> Options s -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Listener s -> LighthouseIO s ()
forall s. Listener s -> LighthouseIO s ()
onConnect Listener s
listener

    -- Run event loop
    LighthouseIO s Bool -> LighthouseIO s () -> LighthouseIO s ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m ()
whileM_ (Bool -> Bool
not (Bool -> Bool) -> LighthouseIO s Bool -> LighthouseIO s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConnectionState s -> Bool) -> LighthouseIO s Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConnectionState s -> Bool
forall s. ConnectionState s -> Bool
csClosed) (LighthouseIO s () -> LighthouseIO s ())
-> LighthouseIO s () -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> Text -> LighthouseIO s ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logDebug Text
"runLighthouseApp" Text
"Receiving event..."
        Either Text ServerEvent
eventOrErr <- LighthouseIO s (Either Text ServerEvent)
forall s. LighthouseIO s (Either Text ServerEvent)
receiveEvent

        case Either Text ServerEvent
eventOrErr of
            Left Text
err -> Text -> Text -> LighthouseIO s ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logWarn Text
"runLighthouseApp" (Text -> LighthouseIO s ()) -> Text -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse event: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err

            Right ServerErrorEvent {Int
[Text]
Maybe Text
seCode :: Int
seWarnings :: [Text]
seError :: Maybe Text
seCode :: ServerEvent -> Int
seWarnings :: ServerEvent -> [Text]
seError :: ServerEvent -> Maybe Text
..} -> do
                (Text -> LighthouseIO s ()) -> [Text] -> LighthouseIO s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Text -> LighthouseIO s ()
forall {m :: * -> *}. MonadLogger m => Text -> m ()
onWarning [Text]
seWarnings
                (Text -> LighthouseIO s ()) -> Maybe Text -> LighthouseIO s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Text -> LighthouseIO s ()
forall {m :: * -> *}. MonadLogger m => Text -> m ()
onError Maybe Text
seError

                Bool
closeOnError <- (ConnectionState s -> Bool) -> LighthouseIO s Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Options s -> Bool
forall s. Options s -> Bool
optCloseOnError (Options s -> Bool)
-> (ConnectionState s -> Options s) -> ConnectionState s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionState s -> Options s
forall s. ConnectionState s -> Options s
csOptions)
                Bool -> LighthouseIO s () -> LighthouseIO s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
seError Bool -> Bool -> Bool
&& Bool
closeOnError)
                    LighthouseIO s ()
forall s. LighthouseIO s ()
sendClose

            Right ServerUnknownEvent {Object
sePayload :: Object
sePayload :: ServerEvent -> Object
..} -> Text -> Text -> LighthouseIO s ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logDebug Text
"runLighthouseApp" (Text -> LighthouseIO s ()) -> Text -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ Text
"Got unknown event: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Object -> String
forall a. Show a => a -> String
show Object
sePayload)

            Right ServerEvent
event -> do
                Text -> Text -> LighthouseIO s ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logDebug Text
"runLighthouseApp" (Text -> LighthouseIO s ()) -> Text -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ Text
"Got event: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ServerEvent -> String
forall a. Show a => a -> String
show ServerEvent
event)
                ServerEvent -> Listener s -> LighthouseIO s ()
forall s. ServerEvent -> Listener s -> LighthouseIO s ()
notifyListener ServerEvent
event Listener s
listener
    
    where onWarning :: Text -> m ()
onWarning Text
w = Text -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logWarn Text
"runLighthouseApp" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Server warning: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
w
          onError :: Text -> m ()
onError   Text
e = Text -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logError Text
"runLighthouseApp" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Server error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e

-- | Runs a single LighthouseIO using the given credentials.
runLighthouseIO :: LighthouseIO s a -> Options s -> IO a
runLighthouseIO :: forall s a. LighthouseIO s a -> Options s -> IO a
runLighthouseIO (LighthouseIO StateT (ConnectionState s) IO a
lio) Options s
opts = IO a -> IO a
forall a. IO a -> IO a
withSocketsDo (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
    String -> PortNumber -> String -> ClientApp a -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> PortNumber -> String -> ClientApp a -> m a
WSS.runSecureClient String
"lighthouse.uni-kiel.de" PortNumber
443 String
"/websocket" (ClientApp a -> IO a) -> ClientApp a -> IO a
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
        let state :: ConnectionState s
state = ConnectionState { csConnection :: Connection
csConnection = Connection
conn
                                    , csOptions :: Options s
csOptions = Options s
opts
                                    , csClosed :: Bool
csClosed = Bool
False
                                    , csRequestId :: Int
csRequestId = Int
0
                                    , csUserState :: s
csUserState = Options s -> s
forall s. Options s -> s
optInitialState Options s
opts
                                    }
        StateT (ConnectionState s) IO a -> ConnectionState s -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (ConnectionState s) IO a
lio ConnectionState s
state

-- | Fetches the user state from the LighthouseIO monad.
getUserState :: LighthouseIO s s
getUserState :: forall s. LighthouseIO s s
getUserState = (ConnectionState s -> s) -> LighthouseIO s s
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConnectionState s -> s
forall s. ConnectionState s -> s
csUserState

-- | Updates the user state from the LighthouseIO monad.
putUserState :: s -> LighthouseIO s ()
putUserState :: forall s. s -> LighthouseIO s ()
putUserState = (s -> s) -> LighthouseIO s ()
forall s. (s -> s) -> LighthouseIO s ()
modifyUserState ((s -> s) -> LighthouseIO s ())
-> (s -> s -> s) -> s -> LighthouseIO s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s -> s
forall a b. a -> b -> a
const

-- | Modifies the user state from the LighthouseIO monad.
modifyUserState :: (s -> s) -> LighthouseIO s ()
modifyUserState :: forall s. (s -> s) -> LighthouseIO s ()
modifyUserState s -> s
f = (ConnectionState s -> ConnectionState s) -> LighthouseIO s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ConnectionState s -> ConnectionState s) -> LighthouseIO s ())
-> (ConnectionState s -> ConnectionState s) -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ \ConnectionState s
cs -> ConnectionState s
cs { csUserState = f (csUserState cs) }

-- | Sends raw, binary data directly to the lighthouse.
sendBinaryData :: BL.ByteString -> LighthouseIO s ()
sendBinaryData :: forall s. ByteString -> LighthouseIO s ()
sendBinaryData ByteString
d = do
    Connection
conn <- (ConnectionState s -> Connection) -> LighthouseIO s Connection
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConnectionState s -> Connection
forall s. ConnectionState s -> Connection
csConnection
    IO () -> LighthouseIO s ()
forall a. IO a -> LighthouseIO s a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LighthouseIO s ()) -> IO () -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendBinaryData Connection
conn ByteString
d

-- | Receives raw, binary data directly from the lighthouse.
receiveBinaryData :: LighthouseIO s BL.ByteString
receiveBinaryData :: forall s. LighthouseIO s ByteString
receiveBinaryData = do
    Connection
conn <- (ConnectionState s -> Connection) -> LighthouseIO s Connection
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConnectionState s -> Connection
forall s. ConnectionState s -> Connection
csConnection
    IO ByteString -> LighthouseIO s ByteString
forall a. IO a -> LighthouseIO s a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> LighthouseIO s ByteString)
-> IO ByteString -> LighthouseIO s ByteString
forall a b. (a -> b) -> a -> b
$ Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
conn

-- | Send a serializable value to the lighthouse.
send :: Serializable a => a -> LighthouseIO s ()
send :: forall a s. Serializable a => a -> LighthouseIO s ()
send = ByteString -> LighthouseIO s ()
forall s. ByteString -> LighthouseIO s ()
sendBinaryData (ByteString -> LighthouseIO s ())
-> (a -> ByteString) -> a -> LighthouseIO s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall t. Serializable t => t -> ByteString
serialize

-- | Receives a deserializable value from the lighthouse.
receive :: Deserializable a => LighthouseIO s (Either T.Text a)
receive :: forall a s. Deserializable a => LighthouseIO s (Either Text a)
receive = ByteString -> Either Text a
forall t. Deserializable t => ByteString -> Either Text t
deserialize (ByteString -> Either Text a)
-> LighthouseIO s ByteString -> LighthouseIO s (Either Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LighthouseIO s ByteString
forall s. LighthouseIO s ByteString
receiveBinaryData

-- | Sends a request to the lighthouse.
sendRequest :: ClientRequest -> LighthouseIO s ()
sendRequest :: forall s. ClientRequest -> LighthouseIO s ()
sendRequest ClientRequest
r = do
    Authentication
auth <- (ConnectionState s -> Authentication)
-> LighthouseIO s Authentication
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Options s -> Authentication
forall s. Options s -> Authentication
optAuthentication (Options s -> Authentication)
-> (ConnectionState s -> Options s)
-> ConnectionState s
-> Authentication
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionState s -> Options s
forall s. ConnectionState s -> Options s
csOptions)
    Int
reqId <- (ConnectionState s -> Int) -> LighthouseIO s Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConnectionState s -> Int
forall s. ConnectionState s -> Int
csRequestId
    (ConnectionState s -> ConnectionState s) -> LighthouseIO s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ConnectionState s -> ConnectionState s) -> LighthouseIO s ())
-> (ConnectionState s -> ConnectionState s) -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ \ConnectionState s
cs -> ConnectionState s
cs { csRequestId = reqId + 1 }
    ClientMessage -> LighthouseIO s ()
forall a s. Serializable a => a -> LighthouseIO s ()
send (ClientMessage -> LighthouseIO s ())
-> ClientMessage -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ Int -> Authentication -> ClientRequest -> ClientMessage
encodeRequest Int
reqId Authentication
auth ClientRequest
r

-- | Receives an event from the lighthouse.
receiveEvent :: LighthouseIO s (Either T.Text ServerEvent)
receiveEvent :: forall s. LighthouseIO s (Either Text ServerEvent)
receiveEvent = ExceptT Text (LighthouseIO s) ServerEvent
-> LighthouseIO s (Either Text ServerEvent)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text (LighthouseIO s) ServerEvent
 -> LighthouseIO s (Either Text ServerEvent))
-> ExceptT Text (LighthouseIO s) ServerEvent
-> LighthouseIO s (Either Text ServerEvent)
forall a b. (a -> b) -> a -> b
$ do
    ServerMessage
raw <- LighthouseIO s (Either Text ServerMessage)
-> ExceptT Text (LighthouseIO s) ServerMessage
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT LighthouseIO s (Either Text ServerMessage)
forall a s. Deserializable a => LighthouseIO s (Either Text a)
receive
    Text -> Text -> ExceptT Text (LighthouseIO s) ()
forall (m :: * -> *). MonadLogger m => Text -> Text -> m ()
logTrace Text
"receiveEvent" (Text -> ExceptT Text (LighthouseIO s) ())
-> Text -> ExceptT Text (LighthouseIO s) ()
forall a b. (a -> b) -> a -> b
$ Text
"Got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ServerMessage -> String
forall a. Show a => a -> String
show ServerMessage
raw)
    LighthouseIO s (Either Text ServerEvent)
-> ExceptT Text (LighthouseIO s) ServerEvent
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (LighthouseIO s (Either Text ServerEvent)
 -> ExceptT Text (LighthouseIO s) ServerEvent)
-> LighthouseIO s (Either Text ServerEvent)
-> ExceptT Text (LighthouseIO s) ServerEvent
forall a b. (a -> b) -> a -> b
$ Either Text ServerEvent -> LighthouseIO s (Either Text ServerEvent)
forall a. a -> LighthouseIO s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text ServerEvent
 -> LighthouseIO s (Either Text ServerEvent))
-> Either Text ServerEvent
-> LighthouseIO s (Either Text ServerEvent)
forall a b. (a -> b) -> a -> b
$ ServerMessage -> Either Text ServerEvent
decodeEvent ServerMessage
raw

-- | Sends a display request with the given display.
sendDisplay :: Display -> LighthouseIO s ()
sendDisplay :: forall s. Display -> LighthouseIO s ()
sendDisplay = ClientRequest -> LighthouseIO s ()
forall s. ClientRequest -> LighthouseIO s ()
sendRequest (ClientRequest -> LighthouseIO s ())
-> (Display -> ClientRequest) -> Display -> LighthouseIO s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> ClientRequest
DisplayRequest

-- | Requests a stream of the model, including input events and the display (though the latter is undocumented).
requestStream :: LighthouseIO s ()
requestStream :: forall s. LighthouseIO s ()
requestStream = ClientRequest -> LighthouseIO s ()
forall s. ClientRequest -> LighthouseIO s ()
sendRequest ClientRequest
StreamRequest

-- | Sends a close message.
sendClose :: LighthouseIO s ()
sendClose :: forall s. LighthouseIO s ()
sendClose = do
    Connection
conn <- (ConnectionState s -> Connection) -> LighthouseIO s Connection
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConnectionState s -> Connection
forall s. ConnectionState s -> Connection
csConnection
    (ConnectionState s -> ConnectionState s) -> LighthouseIO s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ConnectionState s -> ConnectionState s) -> LighthouseIO s ())
-> (ConnectionState s -> ConnectionState s) -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ \ConnectionState s
cs -> ConnectionState s
cs { csClosed = True }
    IO () -> LighthouseIO s ()
forall a. IO a -> LighthouseIO s a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LighthouseIO s ()) -> IO () -> LighthouseIO s ()
forall a b. (a -> b) -> a -> b
$ Connection -> Word16 -> Text -> IO ()
forall a. WebSocketsData a => Connection -> Word16 -> a -> IO ()
WS.sendCloseCode Connection
conn Word16
status (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
"end of data"
    where status :: Word16
status = Word16
1000 -- normal