Attach service handling using URL parameter

1 files changed, 22 insertions, 0 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 8a33793..c8a2e82 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -40,6 +40,7 @@ import Text.Blaze.Html5 qualified as H
 import Text.Blaze.Html5.Attributes qualified as A
 import Text.Blaze.Html.Renderer.String
 
+import Attach
 import JavaScript as JS
 import Storage.Cache
 import Storage.IndexedDB
@@ -55,6 +56,7 @@ data GlobalState = GlobalState
     , peerListVar :: MVar [ ( Peer, String, Element ) ]
     , currentContextVar :: MVar SelectedContext
     , conversationsVar :: MVar [ ( Int, Conversation ) ]
+    , attachState :: MVar (Maybe AttachState)
     }
 
 data SelectedContext
@@ -63,6 +65,7 @@ data SelectedContext
     | WaitingForPeerConversation RefDigest InviteToken
     | SelectedPeer (Either RefDigest Peer)
     | SelectedSelf
+    | AttachingToPeer RefDigest
 
 initGlobalState :: IO GlobalState
 initGlobalState = do
@@ -92,6 +95,7 @@ initGlobalState = do
         peerListVar <- liftIO $ newMVar []
         currentContextVar <- liftIO $ newMVar NoContext
         conversationsVar <- liftIO $ newMVar []
+        attachState <- liftIO $ newMVar Nothing
         return GlobalState {..}
 
 foreign export javascript setup :: IO ()
@@ -207,6 +211,9 @@ setup = do
                     H.input ! A.id "name_set_input" ! A.type_ "text"
                     H.button ! A.type_ "submit" $ "set name"
 
+        H.div ! A.id "attach_content" ! A.class_ "selected-content" $ do
+            attachTemplate
+
         H.div ! A.id "version" $ do
             H.toHtml versionLine
 
@@ -417,6 +424,11 @@ processUrlParams gs@GlobalState {..} server = do
               -> do
                 selectCreateInvite gs server
 
+              | Just peer <- readRefDigest =<< id =<< lookup "attach" params
+              -> do
+                void $ swapMVar currentContextVar $ AttachingToPeer peer
+                selectAttach gs server peer
+
               | otherwise -> do
                 JS.consoleLog $ "Unrecognized URL parameters: " <> show params
 
@@ -712,6 +724,16 @@ selectCreateInvite GlobalState {..} _ = do
         return SelectedSelf
 
 
+selectAttach :: GlobalState -> Server -> RefDigest -> IO ()
+selectAttach GlobalState {..} _ dgst = do
+    modifyMVar_ currentContextVar $ \_ -> do
+        mapM_ (setAttribute "data-selected" "attach") =<< JS.getElementById "body"
+        return $ AttachingToPeer dgst
+    modifyMVar_ attachState $ \case
+        Just x -> return $ Just x
+        Nothing -> Just <$> initiateAttachConnection globalHead dgst
+
+
 foreign import javascript unsafe "document.getElementById($1)"
     js_document_getElementById :: JSString -> IO JSVal