{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
#ifdef USE_TEMPLATE_HASKELL
{-# LANGUAGE TemplateHaskell #-}
#endif
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Reflex.Dom.WebSocket
  ( module Reflex.Dom.WebSocket
  , jsonDecode
  ) where

import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)

import Reflex.Class
import Reflex.Dom.Class
import Reflex.Dom.WebSocket.Foreign
import Reflex.PerformEvent.Class
import Reflex.PostBuild.Class
import Reflex.TriggerEvent.Class

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Lens
import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
import Control.Monad.IO.Class
import Control.Monad.State
import Data.Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Default
import Data.IORef
import Data.JSString.Text
import Data.Maybe (isJust)
import Data.Text
import Data.Text.Encoding
import Foreign.JavaScript.Utils (jsonDecode)
import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)
import GHCJS.DOM.WebSocket (getReadyState)
import GHCJS.Marshal
import qualified Language.Javascript.JSaddle.Monad as JS (catch)

data WebSocketConfig t a
   = WebSocketConfig { WebSocketConfig t a -> Event t [a]
_webSocketConfig_send :: Event t [a]
                     , WebSocketConfig t a -> Event t (Word, Text)
_webSocketConfig_close :: Event t (Word, Text)
                     , WebSocketConfig t a -> Bool
_webSocketConfig_reconnect :: Bool
                     , WebSocketConfig t a -> [Text]
_webSocketConfig_protocols :: [Text]
                     }

instance Reflex t => Default (WebSocketConfig t a) where
  def :: WebSocketConfig t a
def = Event t [a]
-> Event t (Word, Text) -> Bool -> [Text] -> WebSocketConfig t a
forall k (t :: k) a.
Event t [a]
-> Event t (Word, Text) -> Bool -> [Text] -> WebSocketConfig t a
WebSocketConfig Event t [a]
forall k (t :: k) a. Reflex t => Event t a
never Event t (Word, Text)
forall k (t :: k) a. Reflex t => Event t a
never Bool
True []

type WebSocket t = RawWebSocket t ByteString

data RawWebSocket t a
   = RawWebSocket { RawWebSocket t a -> Event t a
_webSocket_recv :: Event t a
                  , RawWebSocket t a -> Event t ()
_webSocket_open :: Event t ()
                  , RawWebSocket t a -> Event t ()
_webSocket_error :: Event t () -- eror event does not carry any data and is always
                                                   -- followed by termination of the connection
                                                   -- for details see the close event
                  , RawWebSocket t a -> Event t (Bool, Word, Text)
_webSocket_close :: Event t ( Bool -- wasClean
                                                , Word -- code
                                                , Text -- reason
                                                )
                  }

webSocket :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)
webSocket :: Text -> WebSocketConfig t a -> m (WebSocket t)
webSocket url :: Text
url config :: WebSocketConfig t a
config = Text
-> WebSocketConfig t a
-> (Either ByteString JSVal -> JSM ByteString)
-> m (WebSocket t)
forall (m :: * -> *) t a b.
(MonadJSM m, MonadJSM (Performable m), HasJSContext m,
 PerformEvent t m, TriggerEvent t m, PostBuild t m,
 IsWebSocketMessage a) =>
Text
-> WebSocketConfig t a
-> (Either ByteString JSVal -> JSM b)
-> m (RawWebSocket t b)
webSocket' Text
url WebSocketConfig t a
config Either ByteString JSVal -> JSM ByteString
onBSMessage

webSocket' :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> JSM b) -> m (RawWebSocket t b)
webSocket' :: Text
-> WebSocketConfig t a
-> (Either ByteString JSVal -> JSM b)
-> m (RawWebSocket t b)
webSocket' url :: Text
url config :: WebSocketConfig t a
config onRawMessage :: Either ByteString JSVal -> JSM b
onRawMessage = do
  JSContextRef
wv <- (JSContextSingleton (JSContextPhantom m) -> JSContextRef)
-> m (JSContextSingleton (JSContextPhantom m)) -> m JSContextRef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JSContextSingleton (JSContextPhantom m) -> JSContextRef
forall x. JSContextSingleton x -> JSContextRef
unJSContextSingleton m (JSContextSingleton (JSContextPhantom m))
forall (m :: * -> *).
HasJSContext m =>
m (JSContextSingleton (JSContextPhantom m))
askJSContext
  (eRecv :: Event t b
eRecv, onMessage :: b -> IO ()
onMessage) <- m (Event t b, b -> IO ())
forall t (m :: * -> *) a.
TriggerEvent t m =>
m (Event t a, a -> IO ())
newTriggerEvent
  IORef (Maybe JSWebSocket)
currentSocketRef <- IO (IORef (Maybe JSWebSocket)) -> m (IORef (Maybe JSWebSocket))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe JSWebSocket)) -> m (IORef (Maybe JSWebSocket)))
-> IO (IORef (Maybe JSWebSocket)) -> m (IORef (Maybe JSWebSocket))
forall a b. (a -> b) -> a -> b
$ Maybe JSWebSocket -> IO (IORef (Maybe JSWebSocket))
forall a. a -> IO (IORef a)
newIORef Maybe JSWebSocket
forall a. Maybe a
Nothing
  (eOpen :: Event t ()
eOpen, triggerEOpen :: () -> IO () -> IO ()
triggerEOpen) <- m (Event t (), () -> IO () -> IO ())
forall t (m :: * -> *) a.
TriggerEvent t m =>
m (Event t a, a -> IO () -> IO ())
newTriggerEventWithOnComplete
  (eError :: Event t ()
eError, triggerEError :: () -> IO ()
triggerEError) <- m (Event t (), () -> IO ())
forall t (m :: * -> *) a.
TriggerEvent t m =>
m (Event t a, a -> IO ())
newTriggerEvent
  (eClose :: Event t (Bool, Word, Text)
eClose, triggerEClose :: (Bool, Word, Text) -> IO ()
triggerEClose) <- m (Event t (Bool, Word, Text), (Bool, Word, Text) -> IO ())
forall t (m :: * -> *) a.
TriggerEvent t m =>
m (Event t a, a -> IO ())
newTriggerEvent
  TQueue a
payloadQueue <- IO (TQueue a) -> m (TQueue a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TQueue a)
forall a. IO (TQueue a)
newTQueueIO
  TMVar ()
isOpen       <- IO (TMVar ()) -> m (TMVar ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMVar ())
forall a. IO (TMVar a)
newEmptyTMVarIO
  let onOpen :: IO ()
onOpen = () -> IO () -> IO ()
triggerEOpen () (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
isOpen ()
      onError :: IO ()
onError = () -> IO ()
triggerEError ()
      onClose :: (Bool, Word, Text) -> JSM ()
onClose args :: (Bool, Word, Text)
args = do
        IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ (Bool, Word, Text) -> IO ()
triggerEClose (Bool, Word, Text)
args
        Maybe ()
_ <- IO (Maybe ()) -> JSM (Maybe ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ()) -> JSM (Maybe ()))
-> IO (Maybe ()) -> JSM (Maybe ())
forall a b. (a -> b) -> a -> b
$ STM (Maybe ()) -> IO (Maybe ())
forall a. STM a -> IO a
atomically (STM (Maybe ()) -> IO (Maybe ()))
-> STM (Maybe ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM (Maybe ())
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar ()
isOpen
        IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe JSWebSocket) -> Maybe JSWebSocket -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe JSWebSocket)
currentSocketRef Maybe JSWebSocket
forall a. Maybe a
Nothing
        Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WebSocketConfig t a -> Bool
forall k (t :: k) a. WebSocketConfig t a -> Bool
_webSocketConfig_reconnect WebSocketConfig t a
config) (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSM () -> JSM ()
forkJSM (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
          IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay 1000000
          JSM ()
start
      start :: JSM ()
start = do
        JSWebSocket
ws <- JSContextRef
-> Text
-> [Text]
-> (Either ByteString JSVal -> JSM ())
-> JSM ()
-> JSM ()
-> ((Bool, Word, Text) -> JSM ())
-> JSM JSWebSocket
forall a.
a
-> Text
-> [Text]
-> (Either ByteString JSVal -> JSM ())
-> JSM ()
-> JSM ()
-> ((Bool, Word, Text) -> JSM ())
-> JSM JSWebSocket
newWebSocket JSContextRef
wv Text
url (WebSocketConfig t a -> [Text]
forall k (t :: k) a. WebSocketConfig t a -> [Text]
_webSocketConfig_protocols WebSocketConfig t a
config) (Either ByteString JSVal -> JSM b
onRawMessage (Either ByteString JSVal -> JSM b)
-> (b -> JSM ()) -> Either ByteString JSVal -> JSM ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> (b -> IO ()) -> b -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> IO ()
onMessage) (IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
onOpen) (IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
onError) (Bool, Word, Text) -> JSM ()
onClose
        IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe JSWebSocket) -> Maybe JSWebSocket -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe JSWebSocket)
currentSocketRef (Maybe JSWebSocket -> IO ()) -> Maybe JSWebSocket -> IO ()
forall a b. (a -> b) -> a -> b
$ JSWebSocket -> Maybe JSWebSocket
forall a. a -> Maybe a
Just JSWebSocket
ws
        () -> JSM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> (Event t () -> Event t (Performable m ())) -> Event t () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JSM () -> Performable m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM JSM ()
start Performable m () -> Event t () -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (Event t () -> m ()) -> m (Event t ()) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> Event t (Performable m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Event t [a]
-> ([a] -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (WebSocketConfig t a -> Event t [a]
forall k (t :: k) a. WebSocketConfig t a -> Event t [a]
_webSocketConfig_send WebSocketConfig t a
config) (([a] -> Performable m ()) -> Event t (Performable m ()))
-> ([a] -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \payloads :: [a]
payloads -> [a] -> (a -> Performable m ()) -> Performable m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [a]
payloads ((a -> Performable m ()) -> Performable m ())
-> (a -> Performable m ()) -> Performable m ()
forall a b. (a -> b) -> a -> b
$ \payload :: a
payload ->
    IO () -> Performable m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue a
payloadQueue a
payload
  Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> Event t (Performable m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Event t (Word, Text)
-> ((Word, Text) -> Performable m ()) -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor (WebSocketConfig t a -> Event t (Word, Text)
forall k (t :: k) a. WebSocketConfig t a -> Event t (Word, Text)
_webSocketConfig_close WebSocketConfig t a
config) (((Word, Text) -> Performable m ()) -> Event t (Performable m ()))
-> ((Word, Text) -> Performable m ()) -> Event t (Performable m ())
forall a b. (a -> b) -> a -> b
$ \(code :: Word
code,reason :: Text
reason) -> JSM () -> Performable m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> Performable m ()) -> JSM () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe JSWebSocket
mws <- IO (Maybe JSWebSocket) -> JSM (Maybe JSWebSocket)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe JSWebSocket) -> JSM (Maybe JSWebSocket))
-> IO (Maybe JSWebSocket) -> JSM (Maybe JSWebSocket)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe JSWebSocket) -> IO (Maybe JSWebSocket)
forall a. IORef a -> IO a
readIORef IORef (Maybe JSWebSocket)
currentSocketRef
    case Maybe JSWebSocket
mws of
      Nothing -> () -> JSM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just ws :: JSWebSocket
ws -> JSWebSocket -> Word -> Text -> JSM ()
closeWebSocket JSWebSocket
ws (Word -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
code) Text
reason

  JSContextRef
ctx <- m JSContextRef
forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
  ThreadId
_ <- IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ 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
    a
payload <- STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> STM a -> IO a
forall a b. (a -> b) -> a -> b
$ do
      a
pl     <- TQueue a -> STM a
forall a. TQueue a -> STM a
readTQueue TQueue a
payloadQueue
      Maybe ()
open   <- TMVar () -> STM (Maybe ())
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar ()
isOpen
      if Maybe () -> Bool
forall a. Maybe a -> Bool
isJust Maybe ()
open then a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
pl else STM a
forall a. STM a
retry

    Maybe JSWebSocket
mws <- IO (Maybe JSWebSocket) -> IO (Maybe JSWebSocket)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe JSWebSocket) -> IO (Maybe JSWebSocket))
-> IO (Maybe JSWebSocket) -> IO (Maybe JSWebSocket)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe JSWebSocket) -> IO (Maybe JSWebSocket)
forall a. IORef a -> IO a
readIORef IORef (Maybe JSWebSocket)
currentSocketRef
    Bool
success <- case Maybe JSWebSocket
mws of
      Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Just ws :: JSWebSocket
ws -> (JSM Bool -> JSContextRef -> IO Bool)
-> JSContextRef -> JSM Bool -> IO Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip JSM Bool -> JSContextRef -> IO Bool
forall (m :: * -> *) a. MonadIO m => JSM a -> JSContextRef -> m a
runJSM JSContextRef
ctx (JSM Bool -> IO Bool) -> JSM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
        Word
rs <- WebSocket -> JSM Word
forall (m :: * -> *). MonadDOM m => WebSocket -> m Word
getReadyState (WebSocket -> JSM Word) -> WebSocket -> JSM Word
forall a b. (a -> b) -> a -> b
$ JSWebSocket -> WebSocket
unWebSocket JSWebSocket
ws
        if Word
rs Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== 1
          then (JSWebSocket -> a -> JSM ()
forall a. IsWebSocketMessage a => JSWebSocket -> a -> JSM ()
webSocketSend JSWebSocket
ws a
payload JSM () -> JSM Bool -> JSM Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> JSM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) JSM Bool -> (SomeException -> JSM Bool) -> JSM Bool
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`JS.catch` (\(SomeException
_ :: SomeException) -> Bool -> JSM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
          else Bool -> JSM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
unGetTQueue TQueue a
payloadQueue a
payload
  RawWebSocket t b -> m (RawWebSocket t b)
forall (m :: * -> *) a. Monad m => a -> m a
return (RawWebSocket t b -> m (RawWebSocket t b))
-> RawWebSocket t b -> m (RawWebSocket t b)
forall a b. (a -> b) -> a -> b
$ Event t b
-> Event t ()
-> Event t ()
-> Event t (Bool, Word, Text)
-> RawWebSocket t b
forall k (t :: k) a.
Event t a
-> Event t ()
-> Event t ()
-> Event t (Bool, Word, Text)
-> RawWebSocket t a
RawWebSocket Event t b
eRecv Event t ()
eOpen Event t ()
eError Event t (Bool, Word, Text)
eClose

textWebSocket :: (IsWebSocketMessage a, MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t a -> m (RawWebSocket t Text)
textWebSocket :: Text -> WebSocketConfig t a -> m (RawWebSocket t Text)
textWebSocket url :: Text
url cfg :: WebSocketConfig t a
cfg = Text
-> WebSocketConfig t a
-> (Either ByteString JSVal -> JSM Text)
-> m (RawWebSocket t Text)
forall (m :: * -> *) t a b.
(MonadJSM m, MonadJSM (Performable m), HasJSContext m,
 PerformEvent t m, TriggerEvent t m, PostBuild t m,
 IsWebSocketMessage a) =>
Text
-> WebSocketConfig t a
-> (Either ByteString JSVal -> JSM b)
-> m (RawWebSocket t b)
webSocket' Text
url WebSocketConfig t a
cfg ((ByteString -> JSM Text)
-> (JSVal -> JSM Text) -> Either ByteString JSVal -> JSM Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> JSM Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> JSM Text)
-> (ByteString -> Text) -> ByteString -> JSM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8) JSVal -> JSM Text
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)

jsonWebSocket :: (ToJSON a, FromJSON b, MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t a -> m (RawWebSocket t (Maybe b))
jsonWebSocket :: Text -> WebSocketConfig t a -> m (RawWebSocket t (Maybe b))
jsonWebSocket url :: Text
url cfg :: WebSocketConfig t a
cfg = do
  RawWebSocket t Text
ws <- Text -> WebSocketConfig t Text -> m (RawWebSocket t Text)
forall a (m :: * -> *) t.
(IsWebSocketMessage a, MonadJSM m, MonadJSM (Performable m),
 HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m,
 MonadHold t m, Reflex t) =>
Text -> WebSocketConfig t a -> m (RawWebSocket t Text)
textWebSocket Text
url (WebSocketConfig t Text -> m (RawWebSocket t Text))
-> WebSocketConfig t Text -> m (RawWebSocket t Text)
forall a b. (a -> b) -> a -> b
$ WebSocketConfig t a
cfg { _webSocketConfig_send :: Event t [Text]
_webSocketConfig_send = (a -> Text) -> [a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode) ([a] -> [Text]) -> Event t [a] -> Event t [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WebSocketConfig t a -> Event t [a]
forall k (t :: k) a. WebSocketConfig t a -> Event t [a]
_webSocketConfig_send WebSocketConfig t a
cfg }
  RawWebSocket t (Maybe b) -> m (RawWebSocket t (Maybe b))
forall (m :: * -> *) a. Monad m => a -> m a
return RawWebSocket t Text
ws { _webSocket_recv :: Event t (Maybe b)
_webSocket_recv = JSString -> Maybe b
forall a. FromJSON a => JSString -> Maybe a
jsonDecode (JSString -> Maybe b) -> (Text -> JSString) -> Text -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JSString
textToJSString (Text -> Maybe b) -> Event t Text -> Event t (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawWebSocket t Text -> Event t Text
forall k (t :: k) a. RawWebSocket t a -> Event t a
_webSocket_recv RawWebSocket t Text
ws }

forkJSM :: JSM () -> JSM ()
forkJSM :: JSM () -> JSM ()
forkJSM a :: JSM ()
a = do
  JSContextRef
jsm <- JSM JSContextRef
forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
  JSM ThreadId -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM ThreadId -> JSM ()) -> JSM ThreadId -> JSM ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> JSM ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> JSM ThreadId) -> IO ThreadId -> JSM ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ JSM () -> JSContextRef -> IO ()
forall (m :: * -> *) a. MonadIO m => JSM a -> JSContextRef -> m a
runJSM JSM ()
a JSContextRef
jsm

#ifdef USE_TEMPLATE_HASKELL
makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
makeLensesWith (lensRules & simpleLenses .~ True) ''RawWebSocket
#else

webSocketConfig_send :: Lens' (WebSocketConfig t a) (Event t [a])
webSocketConfig_send f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig y x2 x3 x4) <$> f x1
{-# INLINE webSocketConfig_send #-}

webSocketConfig_close :: Lens' (WebSocketConfig t a) (Event t (Word, Text))
webSocketConfig_close f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig x1 y x3 x4) <$> f x2
{-# INLINE webSocketConfig_close #-}

webSocketConfig_reconnect :: Lens' (WebSocketConfig t a) Bool
webSocketConfig_reconnect f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig x1 x2 y x4) <$> f x3
{-# INLINE webSocketConfig_reconnect #-}

webSocketConfig_protocols :: Lens' (WebSocketConfig t a) [Text]
webSocketConfig_protocols f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig x1 x2 x3 y) <$> f x4
{-# INLINE webSocketConfig_protocols #-}

webSocket_recv :: Lens' (RawWebSocket t a) (Event t a)
webSocket_recv f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket y x2 x3 x4) <$> f x1
{-# INLINE webSocket_recv #-}

webSocket_open :: Lens' (RawWebSocket t a) (Event t ())
webSocket_open f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket x1 y x3 x4) <$> f x2
{-# INLINE webSocket_open #-}

webSocket_error :: Lens' (RawWebSocket t a) (Event t ())
webSocket_error f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket x1 x2 y x4) <$> f x3
{-# INLINE webSocket_error #-}

webSocket_close :: Lens' (RawWebSocket t a) (Event t (Bool, Word, Text))
webSocket_close f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket x1 x2 x3 y) <$> f x4
{-# INLINE webSocket_close #-}

#endif