WebSocket API wrappers for Haskell

3 files changed, 103 insertions, 7 deletions

diff --git a/src/JavaScript.hs b/src/JavaScript.hs
new file mode 100644
index 0000000..7f1c0f9
--- /dev/null
+++ b/src/JavaScript.hs
@@ -0,0 +1,23 @@
+module JavaScript (
+    asEventListener,
+    addEventListener,
+
+    consoleLog,
+    consoleLogVal,
+) where
+
+import GHC.Wasm.Prim
+
+foreign import javascript "wrapper"
+    asEventListener :: (JSVal -> IO ()) -> IO JSVal
+
+foreign import javascript unsafe "$1.addEventListener($2, $3)"
+    addEventListener :: JSVal -> JSString -> JSVal -> IO ()
+
+consoleLog :: String -> IO ()
+consoleLog = js_consoleLog . toJSString
+foreign import javascript unsafe "console.log($1)"
+    js_consoleLog :: JSString -> IO ()
+
+foreign import javascript unsafe "console.log($1)"
+    consoleLogVal :: JSVal -> IO ()
diff --git a/src/Main.hs b/src/Main.hs
index d201708..83d2d8a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,6 +2,7 @@ module Main (main, setup) where
 
 import Control.Monad.Reader
 
+import Data.ByteString qualified as B
 import Data.Maybe
 import Data.Proxy
 import Data.Text qualified as T
@@ -15,6 +16,9 @@ import Erebos.Storage
 
 import System.IO.Unsafe
 
+import JavaScript qualified as JS
+import WebSocket
+
 main :: IO ()
 main = error "unused"
 
@@ -39,9 +43,9 @@ setup = do
         js_set_textContent nameElem $ toJSString $ T.unpack $ displayIdentity $ headLocalIdentity ls
 
     buttonElem <- js_document_getElementById (toJSString "some_button")
-    buttonCallback <- asEventListener onButtonClick
+    buttonCallback <- JS.asEventListener onButtonClick
 
-    js_addEventListener buttonElem (toJSString "click") buttonCallback
+    JS.addEventListener buttonElem (toJSString "click") buttonCallback
 
     let name = T.pack "My Name"
         devName = T.pack "WebApp"
@@ -66,6 +70,10 @@ setup = do
                 , lsShared = [ shared ]
                 , lsOther = []
                 }
+
+    startClient "localhost" 9160 "" $ \conn -> do
+        sendMessage conn $ B.pack [ 98 .. 107 ]
+
     return ()
 
 
@@ -100,8 +108,3 @@ foreign import javascript unsafe "document.createTextNode($1)"
 foreign import javascript unsafe "$1.value"
     js_get_value :: JSVal -> IO JSString
 
-foreign import javascript unsafe "$1.addEventListener($2, $3)"
-    js_addEventListener :: JSVal -> JSString -> JSVal -> IO ()
-
-foreign import javascript "wrapper"
-    asEventListener :: (JSVal -> IO ()) -> IO JSVal
diff --git a/src/WebSocket.hs b/src/WebSocket.hs
new file mode 100644
index 0000000..273be85
--- /dev/null
+++ b/src/WebSocket.hs
@@ -0,0 +1,70 @@
+module WebSocket (
+    Connection,
+    startClient,
+    sendMessage,
+    receiveMessage,
+) where
+
+import Control.Concurrent.Chan
+
+import Data.ByteString (ByteString)
+import Data.ByteString.Unsafe
+import Data.Word
+
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+
+import GHC.Wasm.Prim
+
+import JavaScript qualified as JS
+
+
+data Connection = Connection
+    { connJS :: JSVal
+    , connInQueue :: Chan ByteString
+    }
+
+startClient :: String -> Int -> String -> (Connection -> IO ()) -> IO ()
+startClient addr port path fun = do
+    connJS <- js_initWebSocket (toJSString $ "ws://" <> addr <> ":" <> show port <> "/" <> path)
+    connInQueue <- newChan
+    let conn = Connection {..}
+
+    onOpen <- JS.asEventListener $ \_ -> do
+        fun conn
+
+    onMessage <- JS.asEventListener $ \ev -> do
+        bytes <- js_get_data ev
+        len <- js_get_byteLength bytes
+        ptr <- mallocBytes len
+        js_copyBytes ptr bytes
+        bs <- unsafePackCStringFinalizer ptr len (free ptr)
+        writeChan connInQueue bs
+
+    JS.addEventListener connJS (toJSString "open") onOpen
+    JS.addEventListener connJS (toJSString "message") onMessage
+
+sendMessage :: Connection -> ByteString -> IO ()
+sendMessage Connection {..} bs = do
+    unsafeUseAsCStringLen bs $ \( ptr, len ) -> do
+        js_send connJS (castPtr ptr) len
+
+receiveMessage :: Connection -> IO ByteString
+receiveMessage Connection {..} = do
+    readChan connInQueue
+
+
+foreign import javascript unsafe "const ws = new WebSocket($1); ws.binaryType = 'arraybuffer'; return ws"
+    js_initWebSocket :: JSString -> IO JSVal
+
+foreign import javascript unsafe "$1.send(new Uint8Array(globalThis.wasi_memory.buffer, $2, $3))"
+    js_send :: JSVal -> Ptr Word8 -> Int -> IO ()
+
+foreign import javascript unsafe "$1.data"
+    js_get_data :: JSVal -> IO JSVal
+
+foreign import javascript unsafe "$1.byteLength"
+    js_get_byteLength :: JSVal -> IO Int
+
+foreign import javascript unsafe "new Uint8Array(globalThis.wasi_memory.buffer, $1, $2.byteLength).set(new Uint8Array($2))"
+    js_copyBytes :: Ptr Word8 -> JSVal -> IO ()