{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE InterruptibleFFI #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE UnboxedTuples #-}
module JavaScript.Web.WebSocket ( WebSocket
, WebSocketRequest(..)
, ReadyState(..)
, BinaryType(..)
, connect
, close
, send
, sendArrayBuffer
, sendBlob
, getBufferedAmount
, getExtensions
, getProtocol
, getReadyState
, getBinaryType
, setBinaryType
, getUrl
) where
import GHCJS.Concurrent
import GHCJS.Prim
import GHCJS.Foreign.Callback.Internal (Callback(..))
import qualified GHCJS.Foreign.Callback as CB
import GHC.Exts
import Control.Exception
import Control.Monad
import Data.Data
import Data.Maybe
import Data.Typeable
import System.IO
import Data.JSString (JSString)
import qualified Data.JSString as JSS
import JavaScript.Array (JSArray)
import qualified JavaScript.Array as JSA
import JavaScript.TypedArray.ArrayBuffer (ArrayBuffer)
import JavaScript.Web.Blob (Blob)
import JavaScript.Web.MessageEvent
import JavaScript.Web.MessageEvent.Internal
import JavaScript.Web.CloseEvent
import JavaScript.Web.CloseEvent.Internal
import JavaScript.Web.ErrorEvent
import JavaScript.Web.ErrorEvent.Internal
import Unsafe.Coerce
data WebSocketRequest = WebSocketRequest
{ url :: JSString
, protocols :: [JSString]
, onClose :: Maybe (CloseEvent -> IO ())
, onMessage :: Maybe (MessageEvent -> IO ())
}
newtype WebSocket = WebSocket JSVal
data ReadyState = Connecting | Open | Closing | Closed
deriving (Data, Typeable, Enum, Eq, Ord, Show)
data BinaryType = Blob | ArrayBuffer
deriving (Data, Typeable, Enum, Eq, Ord, Show)
connect :: WebSocketRequest -> IO WebSocket
connect req = do
mcb <- maybeCallback MessageEvent (onMessage req)
ccb <- maybeCallback CloseEvent (onClose req)
withoutPreemption $ do
ws <- case protocols req of
[] -> js_createDefault (url req)
[x] -> js_createStr (url req) x
(js_open ws mcb ccb >>= handleOpenErr >> return ws) `onException` js_close 1000 "Haskell Exception" ws
maybeCallback :: (JSVal -> a) -> Maybe (a -> IO ()) -> IO JSVal
maybeCallback _ Nothing = return jsNull
maybeCallback f (Just g) = do
Callback cb <- CB.syncCallback1 CB.ContinueAsync (g . f)
return cb
handleOpenErr :: JSVal -> IO ()
handleOpenErr r
| isNull r = return ()
| otherwise = throwIO (userError "WebSocket failed to connect")
close :: Maybe Int -> Maybe JSString -> WebSocket -> IO ()
close value reason ws =
js_close (fromMaybe 1000 value) (fromMaybe JSS.empty reason) ws
{-# INLINE close #-}
send :: JSString -> WebSocket -> IO ()
send xs ws = js_send xs ws
{-# INLINE send #-}
sendBlob :: Blob -> WebSocket -> IO ()
sendBlob = js_sendBlob
{-# INLINE sendBlob #-}
sendArrayBuffer :: ArrayBuffer -> WebSocket -> IO ()
sendArrayBuffer = js_sendArrayBuffer
{-# INLINE sendArrayBuffer #-}
getBufferedAmount :: WebSocket -> IO Int
getBufferedAmount ws = js_getBufferedAmount ws
{-# INLINE getBufferedAmount #-}
getExtensions :: WebSocket -> IO JSString
getExtensions ws = js_getExtensions ws
{-# INLINE getExtensions #-}
getProtocol :: WebSocket -> IO JSString
getProtocol ws = js_getProtocol ws
{-# INLINE getProtocol #-}
getReadyState :: WebSocket -> IO ReadyState
getReadyState ws = fmap toEnum (js_getReadyState ws)
{-# INLINE getReadyState #-}
getBinaryType :: WebSocket -> IO BinaryType
getBinaryType ws = fmap toEnum (js_getBinaryType ws)
{-# INLINE getBinaryType #-}
getUrl :: WebSocket -> JSString
getUrl ws = js_getUrl ws
{-# INLINE getUrl #-}
getLastError :: WebSocket -> IO (Maybe ErrorEvent)
getLastError ws = do
le <- js_getLastError ws
return $ if isNull le then Nothing else Just (ErrorEvent le)
{-# INLINE getLastError #-}
setBinaryType :: BinaryType -> WebSocket -> IO ()
setBinaryType Blob = js_setBinaryType (JSS.pack "blob")
setBinaryType ArrayBuffer = js_setBinaryType (JSS.pack "arraybuffer")
foreign import javascript safe
"new WebSocket($1)" js_createDefault :: JSString -> IO WebSocket
foreign import javascript safe
"new WebSocket($1, $2)" js_createStr :: JSString -> JSString -> IO WebSocket
foreign import javascript safe
"new WebSocket($1, $2)" js_createArr :: JSString -> JSArray -> IO WebSocket
foreign import javascript interruptible
"h$openWebSocket($1, $2, $3, $c);"
js_open :: WebSocket -> JSVal -> JSVal -> IO JSVal
foreign import javascript safe
"h$closeWebSocket($1, $2, $3);"
js_close :: Int -> JSString -> WebSocket -> IO ()
foreign import javascript unsafe
"$2.send($1);" js_send :: JSString -> WebSocket -> IO ()
foreign import javascript unsafe
"$2.send($1);" js_sendBlob :: Blob -> WebSocket -> IO ()
foreign import javascript unsafe
"$2.send($1);" js_sendArrayBuffer :: ArrayBuffer -> WebSocket -> IO ()
foreign import javascript unsafe
"$1.bufferedAmount" js_getBufferedAmount :: WebSocket -> IO Int
foreign import javascript unsafe
"$1.readyState" js_getReadyState :: WebSocket -> IO Int
foreign import javascript unsafe
"$1.protocol" js_getProtocol :: WebSocket -> IO JSString
foreign import javascript unsafe
"$1.extensions" js_getExtensions :: WebSocket -> IO JSString
foreign import javascript unsafe
"$1.url" js_getUrl :: WebSocket -> JSString
foreign import javascript unsafe
"$1.binaryType === 'blob' ? 0 : 1"
js_getBinaryType :: WebSocket -> IO Int
foreign import javascript unsafe
"$1.lastError" js_getLastError :: WebSocket -> IO JSVal
foreign import javascript unsafe
"$2.binaryType = $1"
js_setBinaryType :: JSString -> WebSocket -> IO ()