summaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs104
1 files changed, 51 insertions, 53 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-07-14 23:45:05 +0000