Merge pull request #94 from purescript-contrib/ws

Add more of the WebSocket API

Author: garyb

.eslintrc.json

@@ -4,7 +4,8 @@
   },
   "extends": "eslint:recommended",
   "env": {
-    "commonjs": true
+    "commonjs": true,
+    "browser": true
   },
   "rules": {
     "strict": [2, "global"],

bower.json

@@ -20,6 +20,7 @@
     "package.json"
   ],
   "dependencies": {
+    "purescript-arraybuffer-types": "^1.0.0",
     "purescript-datetime": "^3.0.0",
     "purescript-enums": "^3.0.0",
     "purescript-exceptions": "^3.0.0",

src/DOM/Websocket/BinaryType.purs

@@ -0,0 +1,48 @@
+module DOM.Websocket.BinaryType where
+
+import Prelude
+import Data.Enum (Cardinality(..), class BoundedEnum, defaultPred, defaultSucc, class Enum)
+import Data.Maybe (Maybe(..))
+
+data BinaryType
+  = Blob
+  | ArrayBuffer
+
+derive instance eqBinaryType :: Eq BinaryType
+derive instance ordBinaryType :: Ord BinaryType
+
+instance boundedBinaryType :: Bounded BinaryType where
+  bottom = Blob
+  top = ArrayBuffer
+
+instance enumBinaryType :: Enum BinaryType where
+  succ = defaultSucc toEnumBinaryType fromEnumBinaryType
+  pred = defaultPred toEnumBinaryType fromEnumBinaryType
+
+instance boundedEnumBinaryType :: BoundedEnum BinaryType where
+  cardinality = Cardinality 3
+  toEnum = toEnumBinaryType
+  fromEnum = fromEnumBinaryType
+
+instance showBinaryType :: Show BinaryType where
+  show Blob = "Blob"
+  show ArrayBuffer = "ArrayBuffer"
+
+toEnumBinaryType :: Int -> Maybe BinaryType
+toEnumBinaryType =
+  case _ of
+    0 -> Just Blob
+    1 -> Just ArrayBuffer
+    _ -> Nothing
+
+fromEnumBinaryType :: BinaryType -> Int
+fromEnumBinaryType =
+  case _ of
+    Blob -> 0
+    ArrayBuffer -> 1
+
+printBinaryType :: BinaryType -> String
+printBinaryType =
+  case _ of
+    Blob -> "blob"
+    ArrayBuffer -> "arraybuffer"

src/DOM/Websocket/Event/EventTypes.purs

@@ -0,0 +1,15 @@
+module DOM.Websocket.Event.EventTypes where
+
+import DOM.Event.Types (EventType(..))
+
+onOpen :: EventType
+onOpen = EventType "open"
+
+onMessage :: EventType
+onMessage = EventType "message"
+
+onError :: EventType
+onError = EventType "error"
+
+onClose :: EventType
+onClose = EventType "close"

src/DOM/Websocket/Event/MessageEvent.js

@@ -0,0 +1,13 @@
+"use strict";
+
+exports.data_ = function (e) {
+  return e.data;
+};
+
+exports.origin = function (e) {
+  return e.origin;
+};
+
+exports.lastEventId = function (e) {
+  return e.lastEventId;
+};

src/DOM/Websocket/Event/MessageEvent.purs

@@ -0,0 +1,8 @@
+module DOM.Websocket.Event.MessageEvent where
+
+import Data.Foreign (Foreign)
+import DOM.Websocket.Event.Types (MessageEvent)
+
+foreign import data_ :: MessageEvent -> Foreign
+foreign import origin :: MessageEvent -> String
+foreign import lastEventId :: MessageEvent -> String

src/DOM/Websocket/ReadyState.purs

@@ -0,0 +1,50 @@
+module DOM.Websocket.ReadyState where
+
+import Prelude
+import Data.Enum (Cardinality(..), class BoundedEnum, defaultPred, defaultSucc, class Enum)
+import Data.Maybe (Maybe(..))
+
+data ReadyState
+  = Connecting
+  | Open
+  | Closing
+  | Closed
+
+derive instance eqReadyState :: Eq ReadyState
+derive instance ordReadyState :: Ord ReadyState
+
+instance boundedReadyState :: Bounded ReadyState where
+  bottom = Connecting
+  top = Closed
+
+instance enumReadyState :: Enum ReadyState where
+  succ = defaultSucc toEnumReadyState fromEnumReadyState
+  pred = defaultPred toEnumReadyState fromEnumReadyState
+
+instance boundedEnumReadyState :: BoundedEnum ReadyState where
+  cardinality = Cardinality 3
+  toEnum = toEnumReadyState
+  fromEnum = fromEnumReadyState
+
+instance showReadyState :: Show ReadyState where
+  show Connecting = "Connecting"
+  show Open = "Open"
+  show Closing = "Closing"
+  show Closed = "Closed"
+
+toEnumReadyState :: Int -> Maybe ReadyState
+toEnumReadyState =
+  case _ of
+    0 -> Just Connecting
+    1 -> Just Open
+    2 -> Just Closing
+    3 -> Just Closed
+    _ -> Nothing
+
+fromEnumReadyState :: ReadyState -> Int
+fromEnumReadyState =
+  case _ of
+    Connecting -> 0
+    Open -> 1
+    Closing -> 2
+    Closed -> 3

src/DOM/Websocket/Types.purs

@@ -0,0 +1,28 @@
+module DOM.Websocket.Types
+  ( module DOM.Websocket.Types
+  , module DOM.HTML.History
+  ) where
+
+import Prelude
+
+import Data.Foreign (F, Foreign, unsafeReadTagged)
+import Data.Newtype (class Newtype)
+
+import DOM.Event.Types (EventTarget)
+import DOM.HTML.History (URL(..))
+
+import Unsafe.Coerce (unsafeCoerce)
+
+foreign import data WebSocket :: Type
+
+readWebSocket :: Foreign -> F WebSocket
+readWebSocket = unsafeReadTagged "WebSocket"
+
+socketToEventTarget :: WebSocket -> EventTarget
+socketToEventTarget = unsafeCoerce
+
+newtype Protocol = Protocol String
+
+derive newtype instance eqProtocol :: Eq Protocol
+derive newtype instance ordProtocol :: Ord Protocol
+derive instance newtypeProtocol :: Newtype Protocol _

src/DOM/Websocket/WebSocket.js

@@ -0,0 +1,67 @@
+"use strict";
+
+exports.create = function (url) {
+  return function (protocols) {
+    return function () {
+      return new WebSocket(url, protocols);
+    };
+  };
+};
+
+exports.url = function (ws) {
+  return function () {
+    return ws.url;
+  };
+};
+
+exports.readyStateImpl = function (ws) {
+  return function () {
+    return ws.readyStateImpl;
+  };
+};
+
+exports.bufferedAmount = function (ws) {
+  return function () {
+    return ws.bufferedAmount;
+  };
+};
+
+exports.extensions = function (ws) {
+  return function () {
+    return ws.extensions;
+  };
+};
+
+exports.protocol = function (ws) {
+  return function () {
+    return ws.protocol;
+  };
+};
+
+exports.close = function (ws) {
+  return function () {
+    return ws.close();
+  };
+};
+
+exports.getBinaryTypeImpl = function (ws) {
+  return function () {
+    return ws.binaryType;
+  };
+};
+
+exports.setBinaryTypeImpl = function (ws) {
+  return function (bt) {
+    return function () {
+      ws.binaryType = bt;
+    };
+  };
+};
+
+exports.sendImpl = function (ws) {
+  return function (value) {
+    return function () {
+      ws.send(value);
+    };
+  };
+};

src/DOM/Websocket/WebSocket.purs

@@ -0,0 +1,80 @@
+module DOM.Websocket.WebSocket
+  ( create
+  , url
+  , readyState
+  , bufferedAmount
+  , extensions
+  , protocol
+  , close
+  , getBinaryType
+  , setBinaryType
+  , sendString
+  , sendBlob
+  , sendArrayBuffer
+  , sendArrayBufferView
+  , module DOM.Websocket.BinaryType
+  , module DOM.Websocket.Event.Types
+  , module DOM.Websocket.ReadyState
+  , module DOM.Websocket.Types
+  ) where
+
+import Prelude
+
+import Control.Monad.Eff (Eff)
+
+import Data.ArrayBuffer.Types (ArrayBuffer, ArrayView)
+import Data.Foreign (Foreign, toForeign)
+import Data.Maybe (fromJust)
+
+import DOM (DOM)
+import DOM.File.Types (Blob)
+import DOM.Websocket.BinaryType (BinaryType(..), fromEnumBinaryType, printBinaryType, toEnumBinaryType)
+import DOM.Websocket.Event.Types (CloseEvent, MessageEvent, readCloseEvent, readMessageEvent)
+import DOM.Websocket.ReadyState (ReadyState(..), fromEnumReadyState, toEnumReadyState)
+import DOM.Websocket.Types (Protocol(..), URL(..), WebSocket, readWebSocket, socketToEventTarget)
+
+import Partial.Unsafe (unsafePartial)
+
+foreign import create :: forall eff. URL -> Array Protocol -> Eff (dom :: DOM | eff) WebSocket
+
+foreign import url :: forall eff. WebSocket -> Eff (dom :: DOM | eff) String
+
+foreign import readyStateImpl :: forall eff. WebSocket -> Eff (dom :: DOM | eff) Int
+
+readyState :: forall eff. WebSocket -> Eff (dom :: DOM | eff) ReadyState
+readyState ws = do
+  rs <- readyStateImpl ws
+  pure $ unsafePartial $ fromJust $ toEnumReadyState rs
+
+foreign import bufferedAmount :: forall eff. WebSocket -> Eff (dom :: DOM | eff) Number
+
+foreign import extensions :: forall eff. WebSocket -> Eff (dom :: DOM | eff) String
+foreign import protocol :: forall eff. WebSocket -> Eff (dom :: DOM | eff) String
+
+foreign import close :: forall eff. WebSocket -> Eff (dom :: DOM | eff) Unit
+
+foreign import getBinaryTypeImpl :: forall eff. WebSocket -> Eff (dom :: DOM | eff) String
+foreign import setBinaryTypeImpl :: forall eff. WebSocket -> String -> Eff (dom :: DOM | eff) Unit
+
+getBinaryType :: forall eff. WebSocket -> Eff (dom :: DOM | eff) BinaryType
+getBinaryType ws = unsafePartial do
+  getBinaryTypeImpl ws <#> case _ of
+    "blob" -> Blob
+    "arraybuffer" -> ArrayBuffer
+
+setBinaryType :: forall eff. WebSocket -> BinaryType -> Eff (dom :: DOM | eff) Unit
+setBinaryType ws = setBinaryTypeImpl ws <<< printBinaryType
+
+foreign import sendImpl :: forall eff. WebSocket -> Foreign -> Eff (dom :: DOM | eff) Unit
+
+sendString :: forall eff. WebSocket -> String -> Eff (dom :: DOM | eff) Unit
+sendString ws = sendImpl ws <<< toForeign
+
+sendBlob :: forall eff. WebSocket -> Blob -> Eff (dom :: DOM | eff) Unit
+sendBlob ws = sendImpl ws <<< toForeign
+
+sendArrayBuffer :: forall eff. WebSocket -> ArrayBuffer -> Eff (dom :: DOM | eff) Unit
+sendArrayBuffer ws = sendImpl ws <<< toForeign
+
+sendArrayBufferView :: forall t eff. WebSocket -> ArrayView t -> Eff (dom :: DOM | eff) Unit
+sendArrayBufferView ws = sendImpl ws <<< toForeign