From 75150152f51b21db78bd3cef70b47a5ec98a4c87 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 28 Jun 2026 13:26:33 +0200 Subject: Newtype wrappers for some JavaScript values --- erebos-webapp.cabal | 4 ++ src/JavaScript.hs | 45 ++++---------------- src/JavaScript/Element.hs | 38 +++++++++++++++++ src/JavaScript/Event.hs | 38 +++++++++++++++++ src/JavaScript/Val.hs | 24 +++++++++++ src/JavaScript/Window.hs | 25 +++++++++++ src/Main.hs | 104 +++++++++++++++++++++++----------------------- src/WebSocket.hs | 30 ++++++++----- 8 files changed, 208 insertions(+), 100 deletions(-) create mode 100644 src/JavaScript/Element.hs create mode 100644 src/JavaScript/Event.hs create mode 100644 src/JavaScript/Val.hs create mode 100644 src/JavaScript/Window.hs diff --git a/erebos-webapp.cabal b/erebos-webapp.cabal index 14f6eea..d8446fe 100644 --- a/erebos-webapp.cabal +++ b/erebos-webapp.cabal @@ -28,6 +28,10 @@ executable erebos-webapp main-is: Main.hs other-modules: JavaScript + JavaScript.Element + JavaScript.Event + JavaScript.Val + JavaScript.Window Paths_erebos_webapp Storage.Cache Storage.IndexedDB diff --git a/src/JavaScript.hs b/src/JavaScript.hs index 81b3502..6c07370 100644 --- a/src/JavaScript.hs +++ b/src/JavaScript.hs @@ -1,40 +1,18 @@ module JavaScript ( - getElementById, - documentQuerySelector, - querySelector, - - asEventListener, - addEventListener, + module JavaScript.Event, + module JavaScript.Element, + module JavaScript.Window, + toJSVal, consoleLog, consoleLogVal, ) where -import GHC.Wasm.Prim - -getElementById :: String -> IO (Maybe JSVal) -getElementById = fmap nullToNothing . js_document_getElementById . toJSString -foreign import javascript unsafe "document.getElementById($1)" - js_document_getElementById :: JSString -> IO JSVal - -documentQuerySelector :: String -> IO (Maybe JSVal) -documentQuerySelector = fmap nullToNothing . js_document_querySelector . toJSString -foreign import javascript unsafe "document.querySelector($1)" - js_document_querySelector :: JSString -> IO JSVal - -querySelector :: String -> JSVal -> IO (Maybe JSVal) -querySelector sel e = nullToNothing <$> js_querySelector e (toJSString sel) -foreign import javascript unsafe "$1.querySelector($2)" - js_querySelector :: JSVal -> JSString -> IO JSVal +import JavaScript.Element +import JavaScript.Event +import JavaScript.Val +import JavaScript.Window -foreign import javascript "wrapper" - asEventListener :: (JSVal -> IO ()) -> IO JSVal - -addEventListener :: JSVal -> String -> (JSVal -> IO ()) -> IO () -addEventListener obj ev cb = do - js_addEventListener obj (toJSString ev) =<< asEventListener cb -foreign import javascript unsafe "$1.addEventListener($2, $3)" - js_addEventListener :: JSVal -> JSString -> JSVal -> IO () consoleLog :: String -> IO () consoleLog = js_consoleLog . toJSString @@ -43,10 +21,3 @@ foreign import javascript unsafe "console.log($1)" foreign import javascript unsafe "console.log($1)" consoleLogVal :: JSVal -> IO () - - -nullToNothing :: JSVal -> Maybe JSVal -nullToNothing val | isNull val = Nothing - | otherwise = Just val -foreign import javascript unsafe "$1 === null" - isNull :: JSVal -> Bool diff --git a/src/JavaScript/Element.hs b/src/JavaScript/Element.hs new file mode 100644 index 0000000..2eac8f2 --- /dev/null +++ b/src/JavaScript/Element.hs @@ -0,0 +1,38 @@ +module JavaScript.Element ( + Element, IsElement(..), + getElementById, + documentQuerySelector, + querySelector, +) where + +import JavaScript.Event +import JavaScript.Val + + +newtype Element = Element JSVal + deriving (ToJSVal, FromJSVal) + +class IsElement a where + toElement :: a -> Element + +instance IsElement Element where + toElement = id + +instance IsEventTarget Element where + toEventTarget = fromJSValUnchecked . toJSVal + + +getElementById :: String -> IO (Maybe Element) +getElementById = fmap nullToNothing . js_document_getElementById . toJSString +foreign import javascript unsafe "document.getElementById($1)" + js_document_getElementById :: JSString -> IO JSVal + +documentQuerySelector :: String -> IO (Maybe Element) +documentQuerySelector = fmap nullToNothing . js_document_querySelector . toJSString +foreign import javascript unsafe "document.querySelector($1)" + js_document_querySelector :: JSString -> IO JSVal + +querySelector :: IsElement e => String -> e -> IO (Maybe Element) +querySelector sel e = nullToNothing <$> js_querySelector (toJSVal $ toElement e) (toJSString sel) +foreign import javascript unsafe "$1.querySelector($2)" + js_querySelector :: JSVal -> JSString -> IO JSVal diff --git a/src/JavaScript/Event.hs b/src/JavaScript/Event.hs new file mode 100644 index 0000000..4bc61d2 --- /dev/null +++ b/src/JavaScript/Event.hs @@ -0,0 +1,38 @@ +module JavaScript.Event ( + EventTarget, IsEventTarget(..), + Event, IsEvent(..), + asEventListener, + addEventListener, +) where + +import JavaScript.Val + + +newtype EventTarget = EventTarget JSVal + deriving (ToJSVal, FromJSVal) + +class IsEventTarget a where + toEventTarget :: a -> EventTarget + +instance IsEventTarget EventTarget where + toEventTarget = id + + +newtype Event = Event JSVal + deriving (ToJSVal, FromJSVal) + +class IsEvent a where + toEvent :: a -> Event + +instance IsEvent Event where + toEvent = id + + +foreign import javascript "wrapper" + asEventListener :: (JSVal -> IO ()) -> IO JSVal + +addEventListener :: IsEventTarget a => a -> String -> (Event -> IO ()) -> IO () +addEventListener target ev cb = do + js_addEventListener (toJSVal $ toEventTarget target) (toJSString ev) =<< asEventListener (cb . fromJSValUnchecked) +foreign import javascript unsafe "$1.addEventListener($2, $3)" + js_addEventListener :: JSVal -> JSString -> JSVal -> IO () diff --git a/src/JavaScript/Val.hs b/src/JavaScript/Val.hs new file mode 100644 index 0000000..e1879b4 --- /dev/null +++ b/src/JavaScript/Val.hs @@ -0,0 +1,24 @@ +module JavaScript.Val ( + module GHC.Wasm.Prim, + ToJSVal(..), FromJSVal(..), + nullToNothing, +) where + +import GHC.Wasm.Prim + + +class ToJSVal a where + toJSVal :: a -> JSVal + +class FromJSVal a where + fromJSValUnchecked :: JSVal -> a + +instance ToJSVal JSVal where toJSVal = id +instance FromJSVal JSVal where fromJSValUnchecked = id + + +nullToNothing :: FromJSVal a => JSVal -> Maybe a +nullToNothing val | isNull val = Nothing + | otherwise = Just $ fromJSValUnchecked val +foreign import javascript unsafe "$1 === null" + isNull :: JSVal -> Bool diff --git a/src/JavaScript/Window.hs b/src/JavaScript/Window.hs new file mode 100644 index 0000000..db30c9d --- /dev/null +++ b/src/JavaScript/Window.hs @@ -0,0 +1,25 @@ +module JavaScript.Window ( + Window, IsWindow(..), + globalWindow, +) where + +import JavaScript.Event +import JavaScript.Val + + +newtype Window = Window JSVal + deriving (ToJSVal, FromJSVal) + +class IsWindow a where + toWindow :: a -> Window + +instance IsWindow Window where + toWindow = id + +instance IsEventTarget Window where + toEventTarget = fromJSValUnchecked . toJSVal + +globalWindow :: Window +globalWindow = Window js_window +foreign import javascript unsafe "window" + js_window :: JSVal diff --git a/src/Main.hs b/src/Main.hs index beb5683..2900476 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -40,7 +40,7 @@ import Text.Blaze.Html5 qualified as H import Text.Blaze.Html5.Attributes qualified as A import Text.Blaze.Html.Renderer.String -import JavaScript qualified as JS +import JavaScript as JS import Storage.Cache import Storage.IndexedDB import Version @@ -236,8 +236,8 @@ setup = do JS.getElementById "name_set_input" >>= \case Just setNameInput -> JS.getElementById "name_set_form" >>= \case Just setNameForm -> JS.addEventListener setNameForm "submit" $ \_ -> do - name <- T.pack . fromJSString <$> js_get_value setNameInput - js_set_value setNameInput $ toJSString "" + name <- T.pack . fromJSString <$> js_get_value (toJSVal setNameInput) + js_set_value (toJSVal setNameInput) $ toJSString "" Just h <- reloadHead globalHead res <- runExceptT $ flip runReaderT h $ updateSharedIdentity name case res of @@ -248,21 +248,22 @@ setup = do JS.getElementById "msg_list" >>= \case Just messagesList -> do + let messagesList' = toJSVal messagesList void $ watchDirectMessageThreads globalHead $ \prev cur -> do withMVar currentContextVar $ \case SelectedConversation conv | maybe False (msgPeer cur `sameIdentity`) (conversationPeer conv) -> do - scrollTop <- js_get_scrollTop messagesList - scrollHeight <- js_get_scrollHeight messagesList - clientHeight <- js_get_clientHeight messagesList + scrollTop <- js_get_scrollTop messagesList' + scrollHeight <- js_get_scrollHeight messagesList' + clientHeight <- js_get_clientHeight messagesList' - ul <- js_get_firstChild messagesList + ul <- js_get_firstChild messagesList' let ( remove, messages ) = dmThreadToListChange prev cur appendMessages gs ul remove $ map (uncurry $ flip makeMessage) $ reverse messages when (scrollTop + clientHeight >= scrollHeight) $ do - js_set_scrollTop messagesList =<< js_get_scrollHeight messagesList + js_set_scrollTop messagesList' =<< js_get_scrollHeight messagesList' _ -> return () Nothing -> return () @@ -293,8 +294,8 @@ setup = do Just inviteGeneratedUrl <- JS.getElementById "invite_generated_url" Just inviteClipboard <- JS.getElementById "invite_clipboard" JS.addEventListener inviteGenerateForm "submit" $ \_ -> do - name <- T.pack . fromJSString <$> js_get_value inviteGenerateInput - js_set_value inviteGenerateInput $ toJSString "" + name <- T.pack . fromJSString <$> js_get_value (toJSVal inviteGenerateInput) + js_set_value (toJSVal inviteGenerateInput) $ toJSString "" origin <- fromJSString <$> js_get_location_origin pathname <- fromJSString <$> js_get_location_pathname res <- runExceptT $ flip runReaderT globalHead $ do @@ -307,29 +308,29 @@ setup = do throwOtherError "no shared identity" case res of Right inviteText -> do - mapM_ (flip js_classList_add $ toJSString "generated") =<< JS.getElementById "invite_generated" - js_set_textContent inviteGeneratedName $ toJSString $ T.unpack name - js_set_textContent inviteGeneratedUrl $ toJSString inviteText + mapM_ (flip js_classList_add (toJSString "generated") . toJSVal) =<< JS.getElementById "invite_generated" + js_set_textContent (toJSVal inviteGeneratedName) $ toJSString $ T.unpack name + js_set_textContent (toJSVal inviteGeneratedUrl) $ toJSString inviteText Left err -> do JS.consoleLog $ "Failed to send message: " <> showErebosError err - mapM_ (flip js_classList_remove $ toJSString "generated") =<< JS.getElementById "invite_generated" + mapM_ (flip js_classList_remove (toJSString "generated") . toJSVal) =<< JS.getElementById "invite_generated" JS.addEventListener inviteClipboard "click" $ \_ -> do - js_navigator_clipboard_writeText =<< js_get_textContent inviteGeneratedUrl + js_navigator_clipboard_writeText =<< js_get_textContent (toJSVal inviteGeneratedUrl) JS.getElementById "peers" >>= \case Just peersElem -> JS.querySelector "h2" peersElem >>= \case Just header -> do JS.addEventListener header "click" $ \_ -> do - js_classList_toggle peersElem (toJSString "collapsed") + js_classList_toggle (toJSVal peersElem) (toJSString "collapsed") Nothing -> return () Nothing -> return () JS.addEventListener sendForm "submit" $ \_ -> do - js_focus sendText + js_focus (toJSVal sendText) readMVar currentContextVar >>= \case SelectedConversation conv -> do - msg <- T.pack . fromJSString <$> js_get_value sendText - js_set_value sendText $ toJSString "" + msg <- T.pack . fromJSString <$> js_get_value (toJSVal sendText) + js_set_value (toJSVal sendText) $ toJSString "" res <- runExceptT $ flip runReaderT globalHead $ sendMessage conv msg case res of Right _ -> return () @@ -342,12 +343,12 @@ setup = do JS.querySelector ".close-button" experimentalWarning >>= \case Just experimentalAccept -> do JS.addEventListener experimentalAccept "click" $ \_ -> do - js_element_remove experimentalWarning + js_element_remove (toJSVal experimentalWarning) js_storage_setItem (toJSString "experimental-accepted") (toJSString "") Nothing -> return () Nothing -> return () - JS.addEventListener js_window "hashchange" $ \_ -> do + JS.addEventListener globalWindow "hashchange" $ \_ -> do processUrlParams gs server processUrlParams gs server @@ -423,9 +424,9 @@ processUrlParams gs@GlobalState {..} server = do _ -> do modifyMVar_ currentContextVar $ \_ -> do - mapM_ (flip js_classList_remove (toJSString "selected")) =<< + mapM_ (flip js_classList_remove (toJSString "selected") . toJSVal) =<< JS.documentQuerySelector "#sidebar ul li.selected" - mapM_ (\body -> js_removeAttribute body (toJSString "data-selected")) =<< + mapM_ (flip js_removeAttribute (toJSString "data-selected") . toJSVal) =<< JS.getElementById "body" return NoContext @@ -474,7 +475,7 @@ watchConversations GlobalState {..} = do | c `isSameConversation` selected = do when (conversationName c /= conversationName selected) $ do JS.getElementById "msg_header" >>= \case - Just header -> js_set_textContent header $ toJSString $ T.unpack $ conversationName c + Just header -> js_set_textContent (toJSVal header) $ toJSString $ T.unpack $ conversationName c Nothing -> return () return ( SelectedConversation c, ( c, True ) : map (, False) cs ) | otherwise = do @@ -496,7 +497,7 @@ watchConversations GlobalState {..} = do js_set_textContent a $ toJSString $ T.unpack $ conversationName conv js_appendChild li a js_appendChild ul li - js_replaceChildren convList ul + js_replaceChildren (toJSVal convList) ul Nothing -> return () return $ zip [ 1 .. ] conversations @@ -545,22 +546,22 @@ selectConversation gs@GlobalState {..} conv = do appendMessages gs ul 0 $ reverse $ conversationHistory conv JS.getElementById "msg_header" >>= \case - Just header -> js_set_textContent header $ toJSString $ T.unpack $ conversationName conv + Just header -> js_set_textContent (toJSVal header) $ toJSString $ T.unpack $ conversationName conv Nothing -> return () - maybe (return ()) (flip js_replaceChildren ul) =<< JS.getElementById "msg_list" + maybe (return ()) (flip js_replaceChildren ul . toJSVal) =<< JS.getElementById "msg_list" - mapM_ (flip js_classList_remove (toJSString "selected")) =<< + mapM_ (flip js_classList_remove (toJSString "selected") . toJSVal) =<< JS.documentQuerySelector "#sidebar ul li.selected" - mapM_ (flip js_classList_add (toJSString "selected")) =<< + mapM_ (flip js_classList_add (toJSString "selected") . toJSVal) =<< JS.documentQuerySelector ("#conversation_list ul li[data-conv='" <> show (conversationReference conv) <> "']") JS.getElementById "body" >>= \case Just body -> do - js_setAttribute body (toJSString "data-selected") (toJSString "conversation") + js_setAttribute (toJSVal body) (toJSString "data-selected") (toJSString "conversation") Nothing -> return () - mapM_ (\mlist -> js_set_scrollTop mlist =<< js_get_scrollHeight mlist) =<< JS.getElementById "msg_list" - mapM_ js_focus =<< JS.getElementById "msg_text" + mapM_ (\mlist -> js_set_scrollTop (toJSVal mlist) =<< js_get_scrollHeight (toJSVal mlist)) =<< JS.getElementById "msg_list" + mapM_ (js_focus . toJSVal) =<< JS.getElementById "msg_text" return $ SelectedConversation conv @@ -578,14 +579,14 @@ selectPeer GlobalState {..} server dgst = do Nothing -> do return $ SelectedPeer $ Left dgst - mapM_ (flip js_classList_remove (toJSString "selected")) =<< + mapM_ (flip js_classList_remove (toJSString "selected") . toJSVal) =<< JS.documentQuerySelector "#sidebar ul li.selected" - mapM_ (`js_classList_add` toJSString "selected") =<< + mapM_ (flip js_classList_add (toJSString "selected") . toJSVal) =<< JS.documentQuerySelector ("ul#peer_list li[data-peer='" <> show dgst <> "']") JS.getElementById "body" >>= \case Just body -> do - js_setAttribute body (toJSString "data-selected") (toJSString "peer") + js_setAttribute (toJSVal body) (toJSString "data-selected") (toJSString "peer") Nothing -> return () return selected @@ -593,23 +594,23 @@ updatePeerDetails :: Peer -> IO () updatePeerDetails peer = do paddr <- getPeerAddress peer pid <- getPeerIdentity peer - maybe (return ()) (flip js_set_textContent $ toJSString $ showPeer pid) =<< + maybe (return ()) (flip js_set_textContent (toJSString $ showPeer pid) . toJSVal) =<< JS.getElementById "peer_name_value" case pid of PeerIdentityFull pidf -> do - maybe (return ()) (flip js_set_textContent $ toJSString $ show $ refDigest $ storedRef $ idData pidf) =<< JS.getElementById "peer_ref_value" + maybe (return ()) (flip js_set_textContent (toJSString $ show $ refDigest $ storedRef $ idData pidf) . toJSVal) =<< JS.getElementById "peer_ref_value" maybe (return ()) (\dmLinkElem -> - js_setAttribute dmLinkElem (toJSString "href") $ toJSString $ "#conv=" <> drop 7 (show $ refDigest $ storedRef $ head $ idDataF $ finalOwner pidf) + js_setAttribute (toJSVal dmLinkElem) (toJSString "href") $ toJSString $ "#conv=" <> drop 7 (show $ refDigest $ storedRef $ head $ idDataF $ finalOwner pidf) ) =<< JS.getElementById "peer_dm_link" PeerIdentityRef wref _ -> do - maybe (return ()) (flip js_set_textContent $ toJSString $ show $ wrDigest wref) =<< JS.getElementById "peer_ref_value" + maybe (return ()) (flip js_set_textContent (toJSString $ show $ wrDigest wref) . toJSVal) =<< JS.getElementById "peer_ref_value" PeerIdentityUnknown _ -> do - maybe (return ()) (flip js_set_textContent $ toJSString "unknown") =<< JS.getElementById "peer_ref_value" - maybe (return ()) (flip js_set_textContent $ toJSString $ show paddr) =<< + maybe (return ()) (flip js_set_textContent (toJSString "unknown") . toJSVal) =<< JS.getElementById "peer_ref_value" + maybe (return ()) (flip js_set_textContent (toJSString $ show paddr) . toJSVal) =<< JS.getElementById "peer_address_value" -watchPeers :: GlobalState -> Server -> JSVal -> IO () +watchPeers :: GlobalState -> Server -> Element -> IO () watchPeers gs@GlobalState {..} server htmlList = do void $ forkIO $ void $ forever $ do peer <- getNextPeerChange server @@ -637,7 +638,7 @@ watchPeers gs@GlobalState {..} server htmlList = do js_setAttribute li (toJSString "data-peer") $ toJSString $ show $ refDigest $ storedRef $ idData pidf js_set_textContent a $ toJSString shown js_appendChild li a - js_appendChild htmlList li + js_appendChild (toJSVal htmlList) li return [ ( peer, shown, li ) ] update (( p, s, li ) : ps) @@ -659,7 +660,7 @@ watchPeers gs@GlobalState {..} server htmlList = do count <- modifyMVar peerListVar $ \plist -> do plist' <- update plist return ( plist', length plist' ) - maybe (return ()) (flip js_set_textContent $ toJSString $ show count) =<< + maybe (return ()) (flip js_set_textContent (toJSString $ show count) . toJSVal) =<< JS.getElementById "peer_count" readMVar currentContextVar >>= \case @@ -686,11 +687,11 @@ identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid selectSelf :: GlobalState -> Server -> IO () selectSelf GlobalState {..} _ = do modifyMVar_ currentContextVar $ \_ -> do - mapM_ (\body -> js_setAttribute body (toJSString "data-selected") (toJSString "self")) =<< + mapM_ (\body -> js_setAttribute (toJSVal body) (toJSString "data-selected") (toJSString "self")) =<< JS.getElementById "body" - mapM_ (flip js_classList_remove (toJSString "selected")) =<< + mapM_ (flip js_classList_remove (toJSString "selected") . toJSVal) =<< JS.documentQuerySelector "#sidebar ul li.selected" - mapM_ (flip js_classList_add (toJSString "selected")) =<< + mapM_ (flip js_classList_add (toJSString "selected") . toJSVal) =<< JS.documentQuerySelector ("#self ul li") return SelectedSelf @@ -698,11 +699,11 @@ selectSelf GlobalState {..} _ = do selectCreateInvite :: GlobalState -> Server -> IO () selectCreateInvite GlobalState {..} _ = do modifyMVar_ currentContextVar $ \_ -> do - mapM_ (\body -> js_setAttribute body (toJSString "data-selected") (toJSString "create-invite")) =<< + mapM_ (\body -> js_setAttribute (toJSVal body) (toJSString "data-selected") (toJSString "create-invite")) =<< JS.getElementById "body" - mapM_ (flip js_classList_remove (toJSString "selected")) =<< + mapM_ (flip js_classList_remove (toJSString "selected"). toJSVal) =<< JS.documentQuerySelector "#sidebar ul li.selected" - mapM_ (flip js_classList_add (toJSString "selected")) =<< + mapM_ (flip js_classList_add (toJSString "selected"). toJSVal) =<< JS.documentQuerySelector ("#create_invite_item") return SelectedSelf @@ -773,9 +774,6 @@ foreign import javascript unsafe "$1.scrollHeight" foreign import javascript unsafe "$1.clientHeight" js_get_clientHeight :: JSVal -> IO Int -foreign import javascript unsafe "window" - js_window :: JSVal - foreign import javascript unsafe "window.location.hash" js_get_location_hash :: IO JSString diff --git a/src/WebSocket.hs b/src/WebSocket.hs index a1196ca..0492c81 100644 --- a/src/WebSocket.hs +++ b/src/WebSocket.hs @@ -20,13 +20,14 @@ import Foreign.Ptr import GHC.Wasm.Prim -import JavaScript qualified as JS +import JavaScript +import JavaScript.Val data Connection = Connection { connUnique :: Unique , connAddress :: String - , connJS :: JSVal + , connJS :: WebSocket , connInQueue :: Chan ByteString } @@ -47,32 +48,32 @@ startClient :: Server -> String -> Int -> String -> (Connection -> IO ()) -> IO startClient server addr port path fun = do connUnique <- newUnique let connAddress = "wss://" <> addr <> ":" <> show port <> "/" <> path - connJS <- js_initWebSocket (toJSString connAddress) + connJS <- initWebSocket connAddress connInQueue <- newChan let conn = Connection {..} - JS.addEventListener connJS "open" $ \_ -> do + addEventListener connJS "open" $ \_ -> do fun conn - JS.addEventListener connJS "message" $ \ev -> do - bytes <- js_get_data ev + addEventListener connJS "message" $ \ev -> do + bytes <- js_get_data $ toJSVal 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 "close" $ \_ -> do + addEventListener connJS "close" $ \_ -> do dropPeerAddress server $ CustomPeerAddress conn - JS.addEventListener connJS "error" $ \_ -> do + addEventListener connJS "error" $ \_ -> do dropPeerAddress server $ CustomPeerAddress conn sendMessage :: Connection -> ByteString -> IO () sendMessage Connection {..} bs = do unsafeUseAsCStringLen bs $ \( ptr, len ) -> do - js_send connJS (castPtr ptr) len >>= \case + js_send (toJSVal connJS) (castPtr ptr) len >>= \case 0 -> return () 1 -> error "websocket is not open" @@ -82,9 +83,18 @@ receiveMessage Connection {..} = do closeConnection :: Connection -> IO () closeConnection Connection {..} = do - js_close connJS + js_close (toJSVal connJS) +newtype WebSocket = WebSocket JSVal + deriving (FromJSVal, ToJSVal) + +instance IsEventTarget WebSocket where + toEventTarget = fromJSValUnchecked . toJSVal + +initWebSocket :: String -> IO WebSocket +initWebSocket addr = WebSocket <$> js_initWebSocket (toJSString addr) + foreign import javascript unsafe "const ws = new WebSocket($1); ws.binaryType = 'arraybuffer'; return ws" js_initWebSocket :: JSString -> IO JSVal -- cgit v1.2.3