WebSockets.hs

{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleInstances #-}
-- | WebSockets API for Haste.
module Haste.WebSockets
  ( module Haste.Concurrent
  , WebSocket, WebSocketConfig (..), WebSocketCloseEvent (..)
  , WebSocketData (..)
  , noHandlers
  , wsOpenSync
  , wsClose
  , withWebSocket, withBinaryWebSocket, wsSendBlob
  ) where
import Haste
import Haste.Prim.Foreign
import Haste.Concurrent
import Haste.Binary (Blob)

-- | A WebSocket, parameterized over the type of data that can be sent and
--   received over it.
newtype WebSocket a = WebSocket JSAny deriving (ToAny, FromAny)

instance Eq (WebSocket a) where
  (WebSocket a) == (WebSocket b) = a == b

-- | Some data that can be sent and received over a WebSocket.
class WebSocketData a where
  -- | Send a piece of data to a WebSocket of the appropriate type.
  --   Returns @False@ if the data could not be sent, for instance due to a
  --   closed socket.
  wsSend :: WebSocket a -> a -> CIO Bool

  -- | Open a new WebSocket connection, returning @Just socket@ when successful.
  wsOpen :: WebSocketConfig a -> CIO (Maybe (WebSocket a))

instance WebSocketData Blob where
  wsSend ws b = liftIO $ sendB ws b
  wsOpen = open newBin

instance WebSocketData JSString where
  wsSend ws s = liftIO $ sendS ws s
  wsOpen = open new

open mkNew (WebSocketConfig url close msg) = do
  sock <- newEmptyMVar
  liftIO $ mkNew url
    (\s d -> concurrent $ msg s d)
    (concurrent . putMVar sock . Just)
    (concurrent . close)
    (concurrent $ putMVar sock Nothing)
  takeMVar sock

-- | The various event handlers supported by WebSockets.
data WebSocketConfig t = WebSocketConfig
  { -- | URL to which to attempt a WebSocket connection.
    wsOpenURL   :: URL
    -- | Called when the connection is closed by the server.
  , wsOnClose   :: WebSocketCloseEvent -> CIO ()
    -- | Called when a new message arrives.
  , wsOnMessage :: WebSocket t -> t -> CIO ()
  }

-- | Event describing the remote closing of a WebSocket.
data WebSocketCloseEvent = WebSocketCloseEvent
  { -- | Reason for close event, computer-readable version.
    wsCloseCode   :: Int
    -- | Reason for close event, human-readable version.
  , wsCloseReason :: JSString
    -- | Was the socket closed cleanly?
  , wsCloseClean  :: Bool
  }

instance FromAny WebSocketCloseEvent where
  fromAny o = WebSocketCloseEvent <$> get o "code"
                                  <*> get o "reason"
                                  <*> get o "wasClean"

-- | No-op handlers for all WebSocket events.
noHandlers :: WebSocketConfig t
noHandlers = WebSocketConfig
  { wsOpenURL   = ""
  , wsOnClose   = \_ -> return ()
  , wsOnMessage = \_ _ -> return ()
  }

-- | Open a WebSocket, returning the socket as well as a blocking CIO
--   computation to await incoming data on the socket.
--   When data arrives on the socket, the waiting computation will return
--   @Right received_data@. When the socket is closed, the waiting computation
--   will return @Left close_event@.
wsOpenSync :: WebSocketData t
           => URL
           -> CIO (Maybe (WebSocket t, CIO (Either WebSocketCloseEvent t)))
wsOpenSync url = do
  incoming <- newEmptyMVar
  msock <- wsOpen (WebSocketConfig
                   { wsOpenURL     = url
                   , wsOnClose     = putMVar incoming . Left
                   , wsOnMessage   = \_ -> putMVar incoming . Right
                   })
  case msock of
    Just sock -> return $ Just (sock, takeMVar incoming)
    _         -> return Nothing

-- | Close a WebSocket. Closing a WebSocket which has been previously closed
--   is a no-op. Any associated 'wsOnClose' handler will not be called.
wsClose :: WebSocket a -> CIO ()
wsClose ws = liftIO $ close ws



-- * Legacy API

-- | Run a computation with a WebSocket. The computation will not be executed
--   until a connection to the server has been established.
--   The WebSocket will not be closed after the computation finishes.
withWebSocket :: URL
              -- ^ URL to bind the WebSocket to
              -> (WebSocket JSString -> JSString -> CIO ())
              -- ^ Computation to run when new data arrives
              -> CIO a
              -- ^ Computation to run when an error occurs
              -> (WebSocket JSString -> CIO a)
              -- ^ Computation using the WebSocket
              -> CIO a
withWebSocket = withWS

-- | Run a computation with a WebSocket. The computation will not be executed
--   until a connection to the server has been established.
--   The WebSocket will not be closed after the computation finishes.
withBinaryWebSocket :: URL
                    -- ^ URL to bind the WebSocket to
                    -> (WebSocket Blob -> Blob -> CIO ())
                    -- ^ Computation to run when new data arrives
                    -> CIO a
                    -- ^ Computation to run when an error occurs
                    -> (WebSocket Blob -> CIO a)
                    -- ^ Computation using the WebSocket
                    -> CIO a
withBinaryWebSocket = withWS

-- | Worker for legacy API.
withWS :: WebSocketData t
       => URL
       -> (WebSocket t -> t -> CIO ())
       -> CIO a
       -> (WebSocket t -> CIO a)
       -> CIO a
withWS url cb err f = do
  mws <- wsOpen (noHandlers {wsOpenURL = url, wsOnMessage = cb})
  case mws of
    Just ws -> f ws
    _       -> err

-- | Send a Blob over a WebSocket.
wsSendBlob :: WebSocket Blob -> Blob -> CIO Bool
wsSendBlob = wsSend



-- * Hairy internals

-- | Open a new WebSocket in text mode.
new :: URL
    -> (WebSocket JSString -> JSString -> IO ())
    -> (WebSocket JSString -> IO ())
    -> (WebSocketCloseEvent -> IO ())
    -> IO ()
    -> IO ()
new = ffi "(function(url, cb, f, close, err) {\
             \var ws = new WebSocket(url);\
             \ws.onmessage = function(e) {cb(ws,e.data);};\
             \ws.onopen = function(e) {f(ws);};\
             \ws.onclose = function(e) {close(e.data);};\
             \ws.error = function(e) {err();};\
             \return ws;\
           \})" 

-- | Open a new WebSocket in binary mode.
newBin :: URL
       -> (WebSocket Blob -> Blob -> IO ())
       -> (WebSocket Blob -> IO ())
       -> (WebSocketCloseEvent -> IO ())
       -> IO ()
       -> IO ()
newBin = ffi "(function(url, cb, f, close, err) {\
                \var ws = new WebSocket(url);\
                \ws.binaryType = 'blob';\
                \ws.onmessage = function(e) {cb(ws,e.data);};\
                \ws.onopen = function(e) {f(ws);};\
                \ws.onclose = function(e) {close(e.data);};\
                \ws.onerror = function(e) {err();};\
                \return ws;\
              \})" 

-- | Send text over a WebSocket.
sendS :: WebSocket JSString -> JSString -> IO Bool
sendS = ffi "(function(s, msg) {if(s.readyState != 1) {return false;} else {s.send(msg); return true;}})"

-- | Send a blob over a WebSocket.
sendB :: WebSocket Blob -> Blob -> IO Bool
sendB = ffi "(function(s, msg) {if(s.readyState != 1) {return false;} else {s.send(msg); return true;}})"

-- | Close a WebSocket.
close :: WebSocket a -> IO ()
close = ffi "(function(ws){ws.onclose = ws.onerror = function(){}; ws.close();})"