{-# LANGUAGE OverloadedStrings, RecordWildCards, TupleSections, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE RankNTypes    #-}

module CDP.Runtime 
    ( module CDP.Runtime
    , module CDP.Endpoints
    , module CDP.Internal.Utils
    ) where

import           Control.Applicative  ((<$>))
import           Control.Monad
import           Control.Monad.Loops
import           Control.Monad.Trans  (liftIO)
import qualified Data.Map             as M
import           Data.Maybe
import Data.Foldable (for_)
import Data.Functor.Identity
import Data.String
import qualified Data.Text as T
import qualified Data.List as List
import qualified Data.Text.IO         as TI
import qualified Data.Vector          as V
import Data.Aeson.Types (Parser(..))
import           Data.Aeson           (FromJSON (..), ToJSON (..), (.:), (.:?), (.=), (.!=), (.:!))
import qualified Data.Aeson           as A
import qualified Network.WebSockets as WS
import Control.Concurrent
import qualified Data.ByteString.Lazy as BS
import qualified Data.Map as Map
import Data.Proxy
import Control.Applicative
import Data.Default
import Control.Exception
import System.Timeout
import Data.Char
import qualified System.IO as IO
import qualified Data.IORef as IORef
import qualified Network.HTTP.Simple  as Http

import CDP.Internal.Utils
import CDP.Endpoints

type ClientApp b  = Handle -> IO b

-- | Runs a client application. 
-- By default, the connection is made to the browser. See the `path` field in `Config`.
-- The connection is closed once the IO action completes
runClient :: forall b. Config -> ClientApp b -> IO b
runClient :: Config -> ClientApp b -> IO b
runClient Config
config ClientApp b
app = do
    MVar CommandId
commandNextId  <- CommandId -> IO (MVar CommandId)
forall a. a -> IO (MVar a)
newMVar (Int -> CommandId
CommandId Int
0)
    IORef Subscriptions
subscriptions  <- Subscriptions -> IO (IORef Subscriptions)
forall a. a -> IO (IORef a)
IORef.newIORef (Subscriptions -> IO (IORef Subscriptions))
-> Subscriptions -> IO (IORef Subscriptions)
forall a b. (a -> b) -> a -> b
$ Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
-> Int -> Subscriptions
Subscriptions Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
forall k a. Map k a
Map.empty Int
0
    IORef (Map CommandId (MVar (Either ProtocolError Value)))
commandBuffer  <- Map CommandId (MVar (Either ProtocolError Value))
-> IO (IORef (Map CommandId (MVar (Either ProtocolError Value))))
forall a. a -> IO (IORef a)
IORef.newIORef Map CommandId (MVar (Either ProtocolError Value))
forall k a. Map k a
Map.empty
    MVar [(String, ByteString)]
responseBuffer <- [(String, ByteString)] -> IO (MVar [(String, ByteString)])
forall a. a -> IO (MVar a)
newMVar []

    (String
host, Int
port, String
path) <- do
        let hp :: (String, Int)
hp = Config -> (String, Int)
hostPort Config
config
        if Config -> Bool
connectToBrowser Config
config
            then (String, Int) -> IO (String, Int, String)
browserAddress (String, Int)
hp
            else (String, Int) -> IO (String, Int, String)
pageAddress (String, Int)
hp

    String -> Int -> String -> ClientApp b -> IO b
forall a. String -> Int -> String -> ClientApp a -> IO a
WS.runClient String
host Int
port String
path (ClientApp b -> IO b) -> ClientApp b -> IO b
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
        let listen :: IO ThreadId
listen = IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
                ThreadId
listenThread <- IO ThreadId
myThreadId
                IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    ByteString
bs <- DataMessage -> ByteString
forall a. WebSocketsData a => DataMessage -> a
WS.fromDataMessage (DataMessage -> ByteString) -> IO DataMessage -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO DataMessage
WS.receiveDataMessage Connection
conn
                    case ByteString -> Maybe IncomingMessage
forall a. FromJSON a => ByteString -> Maybe a
A.decode ByteString
bs of
                        Maybe IncomingMessage
Nothing -> Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String
"Could not parse message: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
bs
                        Just IncomingMessage
im | Just String
method <- IncomingMessage -> Maybe String
imMethod IncomingMessage
im -> do
                            Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"dispatching with method " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
method
                            Handle -> Maybe SessionId -> String -> Maybe Value -> IO ()
dispatchEvent Handle :: Config
-> MVar CommandId
-> IORef Subscriptions
-> IORef (Map CommandId (MVar (Either ProtocolError Value)))
-> Connection
-> ThreadId
-> MVar [(String, ByteString)]
-> Handle
Handle{ThreadId
IORef (Map CommandId (MVar (Either ProtocolError Value)))
IORef Subscriptions
MVar [(String, ByteString)]
MVar CommandId
Connection
Config
responseBuffer :: MVar [(String, ByteString)]
listenThread :: ThreadId
conn :: Connection
commandBuffer :: IORef (Map CommandId (MVar (Either ProtocolError Value)))
subscriptions :: IORef Subscriptions
commandNextId :: MVar CommandId
config :: Config
listenThread :: ThreadId
conn :: Connection
responseBuffer :: MVar [(String, ByteString)]
commandBuffer :: IORef (Map CommandId (MVar (Either ProtocolError Value)))
subscriptions :: IORef Subscriptions
commandNextId :: MVar CommandId
config :: Config
..} (IncomingMessage -> Maybe SessionId
imSessionId IncomingMessage
im) String
method (IncomingMessage -> Maybe Value
imParams IncomingMessage
im)
                        Just IncomingMessage
im | Just CommandId
id' <- IncomingMessage -> Maybe CommandId
imId IncomingMessage
im ->
                            Handle -> CommandId -> Maybe ProtocolError -> Maybe Value -> IO ()
dispatchCommandResponse Handle :: Config
-> MVar CommandId
-> IORef Subscriptions
-> IORef (Map CommandId (MVar (Either ProtocolError Value)))
-> Connection
-> ThreadId
-> MVar [(String, ByteString)]
-> Handle
Handle {ThreadId
IORef (Map CommandId (MVar (Either ProtocolError Value)))
IORef Subscriptions
MVar [(String, ByteString)]
MVar CommandId
Connection
Config
responseBuffer :: MVar [(String, ByteString)]
listenThread :: ThreadId
conn :: Connection
commandBuffer :: IORef (Map CommandId (MVar (Either ProtocolError Value)))
subscriptions :: IORef Subscriptions
commandNextId :: MVar CommandId
config :: Config
listenThread :: ThreadId
conn :: Connection
responseBuffer :: MVar [(String, ByteString)]
commandBuffer :: IORef (Map CommandId (MVar (Either ProtocolError Value)))
subscriptions :: IORef Subscriptions
commandNextId :: MVar CommandId
config :: Config
..} CommandId
id'
                            (IncomingMessage -> Maybe ProtocolError
imError IncomingMessage
im) (IncomingMessage -> Maybe Value
imResult IncomingMessage
im)
          
        IO ThreadId -> (ThreadId -> IO ()) -> (ThreadId -> IO b) -> IO b
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO ThreadId
listen ThreadId -> IO ()
killThread (\ThreadId
listenThread -> ClientApp b
app Handle :: Config
-> MVar CommandId
-> IORef Subscriptions
-> IORef (Map CommandId (MVar (Either ProtocolError Value)))
-> Connection
-> ThreadId
-> MVar [(String, ByteString)]
-> Handle
Handle{ThreadId
IORef (Map CommandId (MVar (Either ProtocolError Value)))
IORef Subscriptions
MVar [(String, ByteString)]
MVar CommandId
Connection
Config
listenThread :: ThreadId
responseBuffer :: MVar [(String, ByteString)]
listenThread :: ThreadId
conn :: Connection
commandBuffer :: IORef (Map CommandId (MVar (Either ProtocolError Value)))
subscriptions :: IORef Subscriptions
commandNextId :: MVar CommandId
config :: Config
conn :: Connection
responseBuffer :: MVar [(String, ByteString)]
commandBuffer :: IORef (Map CommandId (MVar (Either ProtocolError Value)))
subscriptions :: IORef Subscriptions
commandNextId :: MVar CommandId
config :: Config
..})

-- | A message from the browser.  We don't know yet if this is a command
-- response or an event
data IncomingMessage = IncomingMessage
    { IncomingMessage -> Maybe String
imMethod    :: Maybe String
    , IncomingMessage -> Maybe Value
imParams    :: Maybe A.Value
    , IncomingMessage -> Maybe SessionId
imSessionId :: Maybe SessionId
    , IncomingMessage -> Maybe CommandId
imId        :: Maybe CommandId
    , IncomingMessage -> Maybe ProtocolError
imError     :: Maybe ProtocolError
    , IncomingMessage -> Maybe Value
imResult    :: Maybe A.Value
    }

instance FromJSON IncomingMessage where
    parseJSON :: Value -> Parser IncomingMessage
parseJSON = String
-> (Object -> Parser IncomingMessage)
-> Value
-> Parser IncomingMessage
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"IncomingMessage" ((Object -> Parser IncomingMessage)
 -> Value -> Parser IncomingMessage)
-> (Object -> Parser IncomingMessage)
-> Value
-> Parser IncomingMessage
forall a b. (a -> b) -> a -> b
$ \Object
obj -> Maybe String
-> Maybe Value
-> Maybe SessionId
-> Maybe CommandId
-> Maybe ProtocolError
-> Maybe Value
-> IncomingMessage
IncomingMessage
        (Maybe String
 -> Maybe Value
 -> Maybe SessionId
 -> Maybe CommandId
 -> Maybe ProtocolError
 -> Maybe Value
 -> IncomingMessage)
-> Parser (Maybe String)
-> Parser
     (Maybe Value
      -> Maybe SessionId
      -> Maybe CommandId
      -> Maybe ProtocolError
      -> Maybe Value
      -> IncomingMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> SessionId -> Parser (Maybe String)
forall a. FromJSON a => Object -> SessionId -> Parser (Maybe a)
A..:? SessionId
"method"
        Parser
  (Maybe Value
   -> Maybe SessionId
   -> Maybe CommandId
   -> Maybe ProtocolError
   -> Maybe Value
   -> IncomingMessage)
-> Parser (Maybe Value)
-> Parser
     (Maybe SessionId
      -> Maybe CommandId
      -> Maybe ProtocolError
      -> Maybe Value
      -> IncomingMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> SessionId -> Parser (Maybe Value)
forall a. FromJSON a => Object -> SessionId -> Parser (Maybe a)
A..:? SessionId
"params"
        Parser
  (Maybe SessionId
   -> Maybe CommandId
   -> Maybe ProtocolError
   -> Maybe Value
   -> IncomingMessage)
-> Parser (Maybe SessionId)
-> Parser
     (Maybe CommandId
      -> Maybe ProtocolError -> Maybe Value -> IncomingMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> SessionId -> Parser (Maybe SessionId)
forall a. FromJSON a => Object -> SessionId -> Parser (Maybe a)
A..:? SessionId
"sessionId"
        Parser
  (Maybe CommandId
   -> Maybe ProtocolError -> Maybe Value -> IncomingMessage)
-> Parser (Maybe CommandId)
-> Parser (Maybe ProtocolError -> Maybe Value -> IncomingMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> SessionId -> Parser (Maybe CommandId)
forall a. FromJSON a => Object -> SessionId -> Parser (Maybe a)
A..:? SessionId
"id"
        Parser (Maybe ProtocolError -> Maybe Value -> IncomingMessage)
-> Parser (Maybe ProtocolError)
-> Parser (Maybe Value -> IncomingMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> SessionId -> Parser (Maybe ProtocolError)
forall a. FromJSON a => Object -> SessionId -> Parser (Maybe a)
A..:? SessionId
"error"
        Parser (Maybe Value -> IncomingMessage)
-> Parser (Maybe Value) -> Parser IncomingMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> SessionId -> Parser (Maybe Value)
forall a. FromJSON a => Object -> SessionId -> Parser (Maybe a)
A..:? SessionId
"result"

dispatchCommandResponse
    :: Handle -> CommandId -> Maybe ProtocolError -> Maybe A.Value -> IO ()
dispatchCommandResponse :: Handle -> CommandId -> Maybe ProtocolError -> Maybe Value -> IO ()
dispatchCommandResponse Handle
handle CommandId
commandId Maybe ProtocolError
mbErr Maybe Value
mbVal = do
    Maybe (MVar (Either ProtocolError Value))
mbMVar <- IORef (Map CommandId (MVar (Either ProtocolError Value)))
-> (Map CommandId (MVar (Either ProtocolError Value))
    -> (Map CommandId (MVar (Either ProtocolError Value)),
        Maybe (MVar (Either ProtocolError Value))))
-> IO (Maybe (MVar (Either ProtocolError Value)))
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' (Handle -> IORef (Map CommandId (MVar (Either ProtocolError Value)))
commandBuffer Handle
handle) ((Map CommandId (MVar (Either ProtocolError Value))
  -> (Map CommandId (MVar (Either ProtocolError Value)),
      Maybe (MVar (Either ProtocolError Value))))
 -> IO (Maybe (MVar (Either ProtocolError Value))))
-> (Map CommandId (MVar (Either ProtocolError Value))
    -> (Map CommandId (MVar (Either ProtocolError Value)),
        Maybe (MVar (Either ProtocolError Value))))
-> IO (Maybe (MVar (Either ProtocolError Value)))
forall a b. (a -> b) -> a -> b
$ \Map CommandId (MVar (Either ProtocolError Value))
buffer ->
        case CommandId
-> Map CommandId (MVar (Either ProtocolError Value))
-> Maybe (MVar (Either ProtocolError Value))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CommandId
commandId Map CommandId (MVar (Either ProtocolError Value))
buffer of
            Maybe (MVar (Either ProtocolError Value))
Nothing -> (Map CommandId (MVar (Either ProtocolError Value))
buffer, Maybe (MVar (Either ProtocolError Value))
forall a. Maybe a
Nothing)
            Just MVar (Either ProtocolError Value)
mv -> (CommandId
-> Map CommandId (MVar (Either ProtocolError Value))
-> Map CommandId (MVar (Either ProtocolError Value))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete CommandId
commandId Map CommandId (MVar (Either ProtocolError Value))
buffer, MVar (Either ProtocolError Value)
-> Maybe (MVar (Either ProtocolError Value))
forall a. a -> Maybe a
Just MVar (Either ProtocolError Value)
mv)
    case Maybe (MVar (Either ProtocolError Value))
mbMVar of
        Maybe (MVar (Either ProtocolError Value))
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just MVar (Either ProtocolError Value)
mv -> MVar (Either ProtocolError Value)
-> Either ProtocolError Value -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either ProtocolError Value)
mv (Either ProtocolError Value -> IO ())
-> Either ProtocolError Value -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe ProtocolError
mbErr of
            Just ProtocolError
err -> ProtocolError -> Either ProtocolError Value
forall a b. a -> Either a b
Left ProtocolError
err
            Maybe ProtocolError
Nothing -> case Maybe Value
mbVal of
                Just Value
val -> Value -> Either ProtocolError Value
forall a b. b -> Either a b
Right Value
val
                Maybe Value
Nothing  -> Value -> Either ProtocolError Value
forall a b. b -> Either a b
Right Value
A.Null

dispatchEvent :: Handle -> Maybe SessionId -> String -> Maybe A.Value -> IO ()
dispatchEvent :: Handle -> Maybe SessionId -> String -> Maybe Value -> IO ()
dispatchEvent Handle
handle Maybe SessionId
mbSessionId String
method Maybe Value
mbParams = do
    Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
byMethod <- Subscriptions
-> Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
subscriptionsHandlers (Subscriptions
 -> Map (String, Maybe SessionId) (Map Int (Value -> IO ())))
-> IO Subscriptions
-> IO (Map (String, Maybe SessionId) (Map Int (Value -> IO ())))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Subscriptions -> IO Subscriptions
forall a. IORef a -> IO a
IORef.readIORef (Handle -> IORef Subscriptions
subscriptions Handle
handle)
    case (String, Maybe SessionId)
-> Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
-> Maybe (Map Int (Value -> IO ()))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String
method, Maybe SessionId
mbSessionId) Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
byMethod of
        Maybe (Map Int (Value -> IO ()))
Nothing -> Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"No handler for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
method String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (SessionId -> String) -> Maybe SessionId -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((String
", " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (SessionId -> String) -> SessionId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId -> String
forall a. Show a => a -> String
show) Maybe SessionId
mbSessionId
        Just Map Int (Value -> IO ())
byId -> case Maybe Value
mbParams of
            Maybe Value
Nothing -> Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"No params for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
method
            Just Value
params -> do
                Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Calling handler for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
method
                Map Int (Value -> IO ()) -> ((Value -> IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Map Int (Value -> IO ())
byId ((Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Value
params)

data Subscription = Subscription
    { Subscription -> String
subscriptionEventName :: String
    , Subscription -> Maybe SessionId
subscriptionSessionId :: Maybe SessionId
    , Subscription -> Int
subscriptionId        :: Int
    }

-- | Subscribes to an event
subscribe :: forall a. Event a => Handle -> (a -> IO ()) -> IO Subscription
subscribe :: Handle -> (a -> IO ()) -> IO Subscription
subscribe Handle
handle a -> IO ()
handler = Handle -> Maybe SessionId -> (a -> IO ()) -> IO Subscription
forall a.
Event a =>
Handle -> Maybe SessionId -> (a -> IO ()) -> IO Subscription
subscribe_ Handle
handle Maybe SessionId
forall a. Maybe a
Nothing a -> IO ()
handler

-- | Subscribes to an event for a given session
subscribeForSession :: forall a. Event a => Handle -> SessionId -> (a -> IO ()) -> IO Subscription
subscribeForSession :: Handle -> SessionId -> (a -> IO ()) -> IO Subscription
subscribeForSession Handle
handle SessionId
sessionId a -> IO ()
handler = Handle -> Maybe SessionId -> (a -> IO ()) -> IO Subscription
forall a.
Event a =>
Handle -> Maybe SessionId -> (a -> IO ()) -> IO Subscription
subscribe_ Handle
handle (SessionId -> Maybe SessionId
forall a. a -> Maybe a
Just SessionId
sessionId) a -> IO ()
handler

subscribe_ :: forall a. Event a => Handle -> Maybe SessionId -> (a -> IO ()) -> IO Subscription
subscribe_ :: Handle -> Maybe SessionId -> (a -> IO ()) -> IO Subscription
subscribe_ Handle
handle Maybe SessionId
mbSessionId a -> IO ()
handler1 = do
    Int
id' <- IORef Subscriptions
-> (Subscriptions -> (Subscriptions, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' (Handle -> IORef Subscriptions
subscriptions Handle
handle) ((Subscriptions -> (Subscriptions, Int)) -> IO Int)
-> (Subscriptions -> (Subscriptions, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Subscriptions
s ->
        let id' :: Int
id' = Subscriptions -> Int
subscriptionsNextId Subscriptions
s in
        ( Subscriptions
s { subscriptionsNextId :: Int
subscriptionsNextId   = Int
id' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            , subscriptionsHandlers :: Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
subscriptionsHandlers = (Map Int (Value -> IO ())
 -> Map Int (Value -> IO ()) -> Map Int (Value -> IO ()))
-> (String, Maybe SessionId)
-> Map Int (Value -> IO ())
-> Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
-> Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith
                Map Int (Value -> IO ())
-> Map Int (Value -> IO ()) -> Map Int (Value -> IO ())
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
                (String
ename, Maybe SessionId
mbSessionId)
                (Int -> (Value -> IO ()) -> Map Int (Value -> IO ())
forall k a. k -> a -> Map k a
Map.singleton Int
id' Value -> IO ()
handler2)
                (Subscriptions
-> Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
subscriptionsHandlers Subscriptions
s)
            }
        , Int
id'
        )

    Subscription -> IO Subscription
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Subscription -> IO Subscription)
-> Subscription -> IO Subscription
forall a b. (a -> b) -> a -> b
$ String -> Maybe SessionId -> Int -> Subscription
Subscription String
ename Maybe SessionId
mbSessionId Int
id'
  where
    ename :: String
ename = Proxy a -> String
forall a. Event a => Proxy a -> String
eventName (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

    handler2 :: A.Value -> IO ()
    handler2 :: Value -> IO ()
handler2 Value
val = case Value -> Result a
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
val :: A.Result a of
        A.Error   String
err -> do
            Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error parsing JSON: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
            Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
val
        A.Success a
x   -> a -> IO ()
handler1 a
x

-- | Unsubscribes to an event
unsubscribe :: Handle -> Subscription -> IO ()
unsubscribe :: Handle -> Subscription -> IO ()
unsubscribe Handle
handle (Subscription String
ename Maybe SessionId
mbSessionId Int
id') =
    IORef Subscriptions
-> (Subscriptions -> (Subscriptions, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' (Handle -> IORef Subscriptions
subscriptions Handle
handle) ((Subscriptions -> (Subscriptions, ())) -> IO ())
-> (Subscriptions -> (Subscriptions, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Subscriptions
s ->
        ( Subscriptions
s { subscriptionsHandlers :: Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
subscriptionsHandlers =
                (Map Int (Value -> IO ()) -> Map Int (Value -> IO ()))
-> (String, Maybe SessionId)
-> Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
-> Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Int -> Map Int (Value -> IO ()) -> Map Int (Value -> IO ())
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int
id') (String
ename, Maybe SessionId
mbSessionId) (Subscriptions
-> Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
subscriptionsHandlers Subscriptions
s)
            }
        , ()
        )

data Promise a where
    Promise :: MVar tmp -> (tmp -> Either Error a) -> Promise a

-- | Resolves a promise to its value 
readPromise :: Promise a -> IO a
readPromise :: Promise a -> IO a
readPromise (Promise MVar tmp
mv tmp -> Either Error a
f) = do
    tmp
x <- MVar tmp -> IO tmp
forall a. MVar a -> IO a
readMVar MVar tmp
mv
    (Error -> IO a) -> (a -> IO a) -> Either Error a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error a -> IO a) -> Either Error a -> IO a
forall a b. (a -> b) -> a -> b
$ tmp -> Either Error a
f tmp
x

nextCommandId :: Handle -> IO CommandId
nextCommandId :: Handle -> IO CommandId
nextCommandId Handle
handle = MVar CommandId
-> (CommandId -> IO (CommandId, CommandId)) -> IO CommandId
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (Handle -> MVar CommandId
commandNextId Handle
handle) (\CommandId
x -> (CommandId, CommandId) -> IO (CommandId, CommandId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> CommandId
CommandId (Int -> CommandId) -> (CommandId -> Int) -> CommandId -> CommandId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> (CommandId -> Int) -> CommandId -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandId -> Int
unCommandId (CommandId -> CommandId) -> CommandId -> CommandId
forall a b. (a -> b) -> a -> b
$ CommandId
x, CommandId
x))

data CommandObj a = CommandObj
    { CommandObj a -> Maybe SessionId
coSessionId :: Maybe SessionId
    , CommandObj a -> CommandId
coId        :: CommandId
    , CommandObj a -> String
coMethod    :: String
    , CommandObj a -> a
coParams    :: a
    } deriving Int -> CommandObj a -> String -> String
[CommandObj a] -> String -> String
CommandObj a -> String
(Int -> CommandObj a -> String -> String)
-> (CommandObj a -> String)
-> ([CommandObj a] -> String -> String)
-> Show (CommandObj a)
forall a. Show a => Int -> CommandObj a -> String -> String
forall a. Show a => [CommandObj a] -> String -> String
forall a. Show a => CommandObj a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CommandObj a] -> String -> String
$cshowList :: forall a. Show a => [CommandObj a] -> String -> String
show :: CommandObj a -> String
$cshow :: forall a. Show a => CommandObj a -> String
showsPrec :: Int -> CommandObj a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> CommandObj a -> String -> String
Show

instance (ToJSON a) => ToJSON (CommandObj a) where
    toJSON :: CommandObj a -> Value
toJSON CommandObj a
cmd = [Pair] -> Value
A.object ([Pair] -> Value) -> ([[Pair]] -> [Pair]) -> [[Pair]] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Pair]] -> [Pair]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Pair]] -> Value) -> [[Pair]] -> Value
forall a b. (a -> b) -> a -> b
$
        [ [Pair] -> (SessionId -> [Pair]) -> Maybe SessionId -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\SessionId
sid -> [ SessionId
"sessionId" SessionId -> SessionId -> Pair
forall kv v. (KeyValue kv, ToJSON v) => SessionId -> v -> kv
.= SessionId
sid ]) (Maybe SessionId -> [Pair]) -> Maybe SessionId -> [Pair]
forall a b. (a -> b) -> a -> b
$ CommandObj a -> Maybe SessionId
forall a. CommandObj a -> Maybe SessionId
coSessionId CommandObj a
cmd
        , [ SessionId
"id"     SessionId -> CommandId -> Pair
forall kv v. (KeyValue kv, ToJSON v) => SessionId -> v -> kv
.= CommandObj a -> CommandId
forall a. CommandObj a -> CommandId
coId CommandObj a
cmd ]
        , [ SessionId
"method" SessionId -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => SessionId -> v -> kv
.= CommandObj a -> String
forall a. CommandObj a -> String
coMethod CommandObj a
cmd ]
        , case a -> Value
forall a. ToJSON a => a -> Value
toJSON (CommandObj a -> a
forall a. CommandObj a -> a
coParams CommandObj a
cmd) of
            Value
A.Null -> []
            Value
params -> [ SessionId
"params" SessionId -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => SessionId -> v -> kv
.= Value
params ]
        ]

-- | Sends a command to the browser and waits until a response is received,
--   for the timeout duration configured
sendCommandWait
    :: Command cmd
    => Handle -> cmd -> IO (CommandResponse cmd)
sendCommandWait :: Handle -> cmd -> IO (CommandResponse cmd)
sendCommandWait Handle
handle cmd
params = Handle -> Maybe SessionId -> cmd -> IO (CommandResponse cmd)
forall cmd.
Command cmd =>
Handle -> Maybe SessionId -> cmd -> IO (CommandResponse cmd)
sendCommandWait_ Handle
handle Maybe SessionId
forall a. Maybe a
Nothing cmd
params

-- | Sends a command to the browser for a given session
--   and waits until a response is received, for the timeout duration configured
sendCommandForSessionWait
    :: Command cmd
    => Handle -> SessionId -> cmd -> IO (CommandResponse cmd)
sendCommandForSessionWait :: Handle -> SessionId -> cmd -> IO (CommandResponse cmd)
sendCommandForSessionWait Handle
handle SessionId
sessionId cmd
params = Handle -> Maybe SessionId -> cmd -> IO (CommandResponse cmd)
forall cmd.
Command cmd =>
Handle -> Maybe SessionId -> cmd -> IO (CommandResponse cmd)
sendCommandWait_ Handle
handle (SessionId -> Maybe SessionId
forall a. a -> Maybe a
Just SessionId
sessionId) cmd
params

sendCommandWait_
    :: Command cmd
    => Handle -> Maybe SessionId -> cmd -> IO (CommandResponse cmd)
sendCommandWait_ :: Handle -> Maybe SessionId -> cmd -> IO (CommandResponse cmd)
sendCommandWait_ Handle
handle Maybe SessionId
mbSessionId cmd
params = do
    Promise (CommandResponse cmd)
promise <- Handle -> cmd -> IO (Promise (CommandResponse cmd))
forall cmd.
Command cmd =>
Handle -> cmd -> IO (Promise (CommandResponse cmd))
sendCommand Handle
handle cmd
params
    let r :: IO (CommandResponse cmd)
r = Promise (CommandResponse cmd) -> IO (CommandResponse cmd)
forall a. Promise a -> IO a
readPromise Promise (CommandResponse cmd)
promise
    Maybe (CommandResponse cmd)
mbRes <- IO (Maybe (CommandResponse cmd))
-> (Int -> IO (Maybe (CommandResponse cmd)))
-> Maybe Int
-> IO (Maybe (CommandResponse cmd))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((CommandResponse cmd -> Maybe (CommandResponse cmd))
-> IO (CommandResponse cmd) -> IO (Maybe (CommandResponse cmd))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CommandResponse cmd -> Maybe (CommandResponse cmd)
forall a. a -> Maybe a
Just IO (CommandResponse cmd)
r) ((Int
 -> IO (CommandResponse cmd) -> IO (Maybe (CommandResponse cmd)))
-> IO (CommandResponse cmd)
-> Int
-> IO (Maybe (CommandResponse cmd))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> IO (CommandResponse cmd) -> IO (Maybe (CommandResponse cmd))
forall a. Int -> IO a -> IO (Maybe a)
timeout IO (CommandResponse cmd)
r) (Config -> Maybe Int
commandTimeout (Config -> Maybe Int) -> (Handle -> Config) -> Handle -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Config
config (Handle -> Maybe Int) -> Handle -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Handle
handle)
    IO (CommandResponse cmd)
-> (CommandResponse cmd -> IO (CommandResponse cmd))
-> Maybe (CommandResponse cmd)
-> IO (CommandResponse cmd)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Error -> IO (CommandResponse cmd)
forall e a. Exception e => e -> IO a
throwIO Error
ERRNoResponse) CommandResponse cmd -> IO (CommandResponse cmd)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CommandResponse cmd)
mbRes
  where
    proxy :: Proxy cmd
proxy = forall cmd. Proxy cmd
forall k (t :: k). Proxy t
Proxy :: Proxy cmd

-- | Sends a command to the browser
sendCommand
    :: forall cmd. Command cmd
    => Handle -> cmd -> IO (Promise (CommandResponse cmd))
sendCommand :: Handle -> cmd -> IO (Promise (CommandResponse cmd))
sendCommand Handle
handle cmd
params = Handle
-> Maybe SessionId -> cmd -> IO (Promise (CommandResponse cmd))
forall cmd.
Command cmd =>
Handle
-> Maybe SessionId -> cmd -> IO (Promise (CommandResponse cmd))
sendCommand_ Handle
handle Maybe SessionId
forall a. Maybe a
Nothing cmd
params

-- | Sends a command to the browser for a given session
sendCommandForSession
    :: forall cmd. Command cmd
    => Handle -> SessionId -> cmd -> IO (Promise (CommandResponse cmd))
sendCommandForSession :: Handle -> SessionId -> cmd -> IO (Promise (CommandResponse cmd))
sendCommandForSession Handle
handle SessionId
sessionId cmd
params = Handle
-> Maybe SessionId -> cmd -> IO (Promise (CommandResponse cmd))
forall cmd.
Command cmd =>
Handle
-> Maybe SessionId -> cmd -> IO (Promise (CommandResponse cmd))
sendCommand_ Handle
handle (SessionId -> Maybe SessionId
forall a. a -> Maybe a
Just SessionId
sessionId) cmd
params

sendCommand_
    :: forall cmd. Command cmd
    => Handle -> Maybe SessionId -> cmd -> IO (Promise (CommandResponse cmd))
sendCommand_ :: Handle
-> Maybe SessionId -> cmd -> IO (Promise (CommandResponse cmd))
sendCommand_ Handle
handle Maybe SessionId
mbSessionId cmd
params = do
    CommandId
id <- Handle -> IO CommandId
nextCommandId Handle
handle
    let co :: CommandObj cmd
co = Maybe SessionId -> CommandId -> String -> cmd -> CommandObj cmd
forall a.
Maybe SessionId -> CommandId -> String -> a -> CommandObj a
CommandObj Maybe SessionId
mbSessionId CommandId
id (Proxy cmd -> String
forall cmd. Command cmd => Proxy cmd -> String
commandName Proxy cmd
proxy) cmd
params
    MVar (Either ProtocolError Value)
mv <- IO (MVar (Either ProtocolError Value))
forall a. IO (MVar a)
newEmptyMVar
    IORef (Map CommandId (MVar (Either ProtocolError Value)))
-> (Map CommandId (MVar (Either ProtocolError Value))
    -> (Map CommandId (MVar (Either ProtocolError Value)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' (Handle -> IORef (Map CommandId (MVar (Either ProtocolError Value)))
commandBuffer Handle
handle) ((Map CommandId (MVar (Either ProtocolError Value))
  -> (Map CommandId (MVar (Either ProtocolError Value)), ()))
 -> IO ())
-> (Map CommandId (MVar (Either ProtocolError Value))
    -> (Map CommandId (MVar (Either ProtocolError Value)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map CommandId (MVar (Either ProtocolError Value))
buffer ->
        (CommandId
-> MVar (Either ProtocolError Value)
-> Map CommandId (MVar (Either ProtocolError Value))
-> Map CommandId (MVar (Either ProtocolError Value))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert CommandId
id MVar (Either ProtocolError Value)
mv Map CommandId (MVar (Either ProtocolError Value))
buffer, ())
    Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData (Handle -> Connection
conn Handle
handle) (ByteString -> IO ())
-> (CommandObj cmd -> ByteString) -> CommandObj cmd -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandObj cmd -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (CommandObj cmd -> IO ()) -> CommandObj cmd -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandObj cmd
co
    Promise (CommandResponse cmd) -> IO (Promise (CommandResponse cmd))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Promise (CommandResponse cmd)
 -> IO (Promise (CommandResponse cmd)))
-> Promise (CommandResponse cmd)
-> IO (Promise (CommandResponse cmd))
forall a b. (a -> b) -> a -> b
$ MVar (Either ProtocolError Value)
-> (Either ProtocolError Value
    -> Either Error (CommandResponse cmd))
-> Promise (CommandResponse cmd)
forall tmp a. MVar tmp -> (tmp -> Either Error a) -> Promise a
Promise MVar (Either ProtocolError Value)
mv ((Either ProtocolError Value -> Either Error (CommandResponse cmd))
 -> Promise (CommandResponse cmd))
-> (Either ProtocolError Value
    -> Either Error (CommandResponse cmd))
-> Promise (CommandResponse cmd)
forall a b. (a -> b) -> a -> b
$ \case
        Left ProtocolError
err -> Error -> Either Error (CommandResponse cmd)
forall a b. a -> Either a b
Left (Error -> Either Error (CommandResponse cmd))
-> Error -> Either Error (CommandResponse cmd)
forall a b. (a -> b) -> a -> b
$ ProtocolError -> Error
ERRProtocol ProtocolError
err
        Right Value
v  -> case Proxy cmd -> Value -> Result (CommandResponse cmd)
forall cmd.
Command cmd =>
Proxy cmd -> Value -> Result (CommandResponse cmd)
fromJSON Proxy cmd
proxy Value
v of
            A.Error   String
err -> Error -> Either Error (CommandResponse cmd)
forall a b. a -> Either a b
Left (Error -> Either Error (CommandResponse cmd))
-> Error -> Either Error (CommandResponse cmd)
forall a b. (a -> b) -> a -> b
$ String -> Error
ERRParse String
err
            A.Success CommandResponse cmd
x   -> CommandResponse cmd -> Either Error (CommandResponse cmd)
forall a b. b -> Either a b
Right CommandResponse cmd
x
  where
    proxy :: Proxy cmd
proxy = Proxy cmd
forall k (t :: k). Proxy t
Proxy :: Proxy cmd

data SomeCommand where
    SomeCommand :: Command cmd => cmd -> SomeCommand

fromSomeCommand :: (forall cmd. Command cmd => cmd -> r) -> SomeCommand -> r
fromSomeCommand :: (forall cmd. Command cmd => cmd -> r) -> SomeCommand -> r
fromSomeCommand forall cmd. Command cmd => cmd -> r
f (SomeCommand cmd
c) = cmd -> r
forall cmd. Command cmd => cmd -> r
f cmd
c