diff options
| -rw-r--r-- | erebos-webapp.cabal | 8 | ||||
| -rw-r--r-- | src/JavaScript.hs | 23 | ||||
| -rw-r--r-- | src/Main.hs | 17 | ||||
| -rw-r--r-- | src/WebSocket.hs | 70 |
4 files changed, 109 insertions, 9 deletions
diff --git a/erebos-webapp.cabal b/erebos-webapp.cabal index a040a0a..5da31ee 100644 --- a/erebos-webapp.cabal +++ b/erebos-webapp.cabal @@ -19,15 +19,18 @@ common warnings executable erebos-webapp import: warnings - main-is: Main.hs ghc-options: -no-hs-main -optl-mexec-model=reactor -optl-Wl,--export=hs_init,--export=setup + -fdefer-typed-holes extra-libraries: blake2b-ref - -- other-modules: + main-is: Main.hs + other-modules: + JavaScript + WebSocket default-extensions: DefaultSignatures @@ -52,6 +55,7 @@ executable erebos-webapp -- other-extensions: build-depends: base ^>= { 4.21 }, + bytestring ^>= { 0.12 }, erebos ^>= { 0.1.8 }, ghc-experimental ^>= { 9.1201 }, mtl ^>= { 2.3 }, 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 () |