diff options
| -rw-r--r-- | erebos-webapp.cabal | 1 | ||||
| -rw-r--r-- | src/JavaScript.hs | 12 | ||||
| -rw-r--r-- | src/Main.hs | 54 | ||||
| -rw-r--r-- | src/WebSocket.hs | 6 |
4 files changed, 47 insertions, 26 deletions
diff --git a/erebos-webapp.cabal b/erebos-webapp.cabal index 47c7b58..23e00d6 100644 --- a/erebos-webapp.cabal +++ b/erebos-webapp.cabal @@ -60,6 +60,7 @@ executable erebos-webapp ghc-experimental ^>= { 9.1201 }, mtl ^>= { 2.3 }, text ^>= { 2.1 }, + time ^>= { 1.14 }, hs-source-dirs: src default-language: GHC2021 diff --git a/src/JavaScript.hs b/src/JavaScript.hs index 7f1c0f9..21571ea 100644 --- a/src/JavaScript.hs +++ b/src/JavaScript.hs @@ -1,4 +1,6 @@ module JavaScript ( + getElementById, + asEventListener, addEventListener, @@ -8,11 +10,19 @@ module JavaScript ( import GHC.Wasm.Prim +getElementById :: String -> IO JSVal +getElementById = js_document_getElementById . toJSString +foreign import javascript unsafe "document.getElementById($1)" + js_document_getElementById :: JSString -> IO JSVal + 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)" - addEventListener :: JSVal -> JSString -> JSVal -> IO () + js_addEventListener :: JSVal -> JSString -> JSVal -> IO () consoleLog :: String -> IO () consoleLog = js_consoleLog . toJSString diff --git a/src/Main.hs b/src/Main.hs index 2a08285..2b0a02f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,11 +2,13 @@ module Main (main, setup) where import Control.Concurrent import Control.Monad +import Control.Monad.Except import Control.Monad.Reader import Data.Maybe import Data.Proxy import Data.Text qualified as T +import Data.Time.LocalTime import GHC.Wasm.Prim @@ -52,21 +54,17 @@ setup = do H.div $ do "Name: " H.span ! A.id "name_text" $ return () - H.hr - H.input ! A.id "some_input" ! A.type_ "text" ! A.value "xyz" - H.button ! A.id "some_button" $ "add" + H.hr H.div $ do - H.ul ! A.id "some_list" $ return () + H.ul ! A.id "msg_list" $ return () + H.div $ do + H.input ! A.id "msg_text" ! A.type_ "text" + H.button ! A.id "msg_send" $ "send" nameElem <- js_document_getElementById (toJSString "name_text") _ <- watchHead globalHead $ \ls -> do js_set_textContent nameElem $ toJSString $ T.unpack $ displayIdentity $ headLocalIdentity ls - buttonElem <- js_document_getElementById (toJSString "some_button") - buttonCallback <- JS.asEventListener onButtonClick - - JS.addEventListener buttonElem (toJSString "click") buttonCallback - let name = T.pack "My Name" devName = T.pack "WebApp" @@ -91,6 +89,18 @@ setup = do , lsOther = [] } + messagesList <- JS.getElementById "msg_list" + tzone <- getCurrentTimeZone + void $ watchReceivedMessages globalHead $ \msg -> do + JS.consoleLog $ formatDirectMessage tzone $ fromStored msg + li <- js_document_createElement (toJSString "li") + content <- js_document_createTextNode $ toJSString $ formatDirectMessage tzone $ fromStored msg + js_appendChild li content + js_appendChild messagesList li + + sendText <- JS.getElementById "msg_text" + sendButton <- JS.getElementById "msg_send" + server <- startServer defaultServerOptions globalHead JS.consoleLog [ someService @ChatroomService Proxy , someService @DiscoveryService Proxy @@ -99,23 +109,23 @@ setup = do ] startClient "localhost" 9160 "" $ \conn -> do - void $ serverPeerCustom server conn void $ forkIO $ forever $ do msg <- receiveMessage conn receivedFromCustomAddress server conn msg - return () - - -onButtonClick :: JSVal -> IO () -onButtonClick _event = do - inputElem <- js_document_getElementById (toJSString "some_input") - listElem <- js_document_getElementById (toJSString "some_list") + peer <- serverPeerCustom server conn + JS.addEventListener sendButton "click" $ \_ -> do + peerIdentity peer >>= \case + PeerIdentityUnknown {} -> JS.consoleLog "unknown peer identity" + PeerIdentityRef {} -> JS.consoleLog "unresolved peer identity" + PeerIdentityFull pid -> do + msg <- T.pack . fromJSString <$> js_get_value sendText + js_set_value sendText $ toJSString "" + res <- runExceptT $ flip runReaderT globalHead $ sendDirectMessage pid msg + case res of + Right sent -> JS.consoleLog . ("sent message: " <>) $ formatDirectMessage tzone $ fromStored sent + Left err -> JS.consoleLog $ "Failed to send message: " <> err - li <- js_document_createElement (toJSString "li") - content <- js_document_createTextNode =<< js_get_value inputElem - js_appendChild li content - js_appendChild listElem li foreign import javascript unsafe "document.getElementById($1)" js_document_getElementById :: JSString -> IO JSVal @@ -138,3 +148,5 @@ foreign import javascript unsafe "document.createTextNode($1)" foreign import javascript unsafe "$1.value" js_get_value :: JSVal -> IO JSString +foreign import javascript unsafe "$1.value = $2" + js_set_value :: JSVal -> JSString -> IO () diff --git a/src/WebSocket.hs b/src/WebSocket.hs index 19d30c4..68feae8 100644 --- a/src/WebSocket.hs +++ b/src/WebSocket.hs @@ -50,10 +50,10 @@ startClient addr port path fun = do connInQueue <- newChan let conn = Connection {..} - onOpen <- JS.asEventListener $ \_ -> do + JS.addEventListener connJS "open" $ \_ -> do fun conn - onMessage <- JS.asEventListener $ \ev -> do + JS.addEventListener connJS "message" $ \ev -> do bytes <- js_get_data ev len <- js_get_byteLength bytes ptr <- mallocBytes len @@ -61,8 +61,6 @@ startClient addr port path fun = do 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 |