Attach service handling using URL parameter

3 files changed, 197 insertions, 0 deletions

diff --git a/src/Attach.hs b/src/Attach.hs
new file mode 100644
index 0000000..c15b0a5
--- /dev/null
+++ b/src/Attach.hs
@@ -0,0 +1,157 @@
+module Attach (
+    AttachState(..),
+    attachTemplate,
+    initiateAttachConnection,
+) where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+
+import Data.Proxy
+import Data.Text qualified as T
+
+import Erebos.Attach
+import Erebos.Discovery
+import Erebos.Error
+import Erebos.Identity
+import Erebos.Network
+import Erebos.Object
+import Erebos.Pairing
+import Erebos.Service
+import Erebos.State
+import Erebos.Storable
+import Erebos.Storage
+import Erebos.Storage.Key
+
+import Text.Blaze.Html5 ((!))
+import Text.Blaze.Html5 qualified as H
+import Text.Blaze.Html5.Attributes qualified as A
+
+import JavaScript
+import WebSocket (startClient, receiveMessage)
+
+
+data AttachState = AttachState
+    { asStorage :: Storage
+    , asHead :: Head LocalState
+    , asServer :: Server
+    }
+
+
+attachTemplate :: H.Html
+attachTemplate = do
+    H.h2 $ "Attach to other device"
+
+    H.div ! A.class_ "content" $ do
+        H.div ! A.class_ "warning" $ do
+            "Deletes all local data, including conversations and contacts,\
+            \ and synchronizes with the remote device."
+
+        H.div ! A.id "attach_details" $ do
+            H.div ! A.class_ "attach_details_item" $ do
+                "Name: "
+                H.span ! A.id "attach_details_name" $ return ()
+            H.div ! A.class_ "attach_details_item" $ do
+                "Confirmation code: "
+                H.span ! A.id "attach_details_code" $ return ()
+
+        H.button ! A.id "attach_confirm" ! A.disabled "" $ do
+            "Confirm and proceed (deleting data)"
+
+        H.button ! A.id "attach_cancel" $ do
+            "Cancel"
+
+initiateAttachConnection :: Head LocalState -> RefDigest -> IO AttachState
+initiateAttachConnection baseHead dgst = do
+    let baseStorage = headStorage baseHead
+    Just nameElem <- getElementById "attach_details_name"
+    Just codeElem <- getElementById "attach_details_code"
+    Just confirmButton <- getElementById "attach_confirm"
+    Just cancelButton <- getElementById "attach_cancel"
+
+    asStorage <- deriveEphemeralStorage baseStorage
+    asHead <- (either (fail . showErebosError) return =<<) $ runExceptT $ flip runReaderT asStorage $ do
+        let devName = T.pack "WebApp"
+        identity <- createIdentity (Just devName) Nothing
+        storeHead asStorage $ LocalState
+            { lsPrev = Nothing
+            , lsIdentity = idExtData identity
+            , lsShared = []
+            , lsOther = []
+            }
+
+    asServer <- startServer defaultServerOptions asHead consoleLog
+        [ someServiceAttr (defaultPairingAttributes (Proxy @AttachService))
+            { pairingHookResponse = \confirm ->
+                afterCommit $ do
+                    setTextContent confirm codeElem
+                    removeAttribute "disabled" confirmButton
+            , pairingHookAcceptedResponse = do
+                afterCommit $ do
+                    Just chead <- reloadHead asHead
+                    moveKeys asStorage baseStorage
+                    void $ updateHead_ baseHead $ \_ -> return (headStoredObject chead)
+                    locationAssign "./"
+            }
+        , someService @DiscoveryService Proxy
+        ]
+
+    attachRequested <- newMVar Nothing
+    addEventListener confirmButton "click" $ \_ -> do
+        readMVar attachRequested >>= \case
+            Just peer -> do
+                runExceptT (attachAccept peer) >>= \case
+                    Right _ -> do
+                        consoleLog "Attach accepted"
+                    Left err -> do
+                        consoleLog $ "Failed to accept attach: " <> showErebosError err
+            Nothing -> do
+                consoleLog $ "Attach not requested yet"
+    addEventListener cancelButton "click" $ \_ -> do
+        readMVar attachRequested >>= \case
+            Just peer -> do
+                runExceptT (attachReject peer) >>= \case
+                    Right _ -> do
+                        consoleLog "Attach rejected"
+                    Left err -> do
+                        consoleLog $ "Failed to reject attach: " <> showErebosError err
+            Nothing -> return ()
+        locationAssign "./"
+
+    startClient asServer "a.discovery.erebosprotocol.net" 443 "" $ \conn -> do
+        void $ forkIO $ forever $ do
+            msg <- receiveMessage conn
+            receivedFromCustomAddress asServer conn msg
+        void $ serverPeerCustom asServer conn
+
+    runExceptT (discoverySearch asServer dgst) >>= \case
+        Right _ -> return ()
+        Left err -> consoleLog $ "Failed to search for " <> show dgst <> ": " <> showErebosError err
+
+    void $ forkIO $ do
+        let loop = do
+                peer <- getNextPeerChange asServer
+                getPeerIdentity peer >>= \case
+                    PeerIdentityFull pid
+                        | dgst `elem` identityDigests pid -> do
+                            modifyMVar_ attachRequested $ \case
+                                Nothing -> do
+                                    runExceptT (attachToOwner peer) >>= \case
+                                        Right _ -> do
+                                            consoleLog "Attach request sent"
+                                            return $ Just peer
+                                        Left err -> do
+                                            consoleLog $ "Failed send attach request to " <> show dgst <> ": " <> showErebosError err
+                                            return $ Nothing
+                                cur -> return cur
+                            setTextContent (T.unpack $ displayIdentity pid) nameElem
+                    _ -> loop
+        loop
+
+    return AttachState {..}
+
+
+identityDigests :: Foldable f => Identity f -> [ RefDigest ]
+identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid
diff --git a/src/JavaScript.hs b/src/JavaScript.hs
index aaf3747..3039b3f 100644
--- a/src/JavaScript.hs
+++ b/src/JavaScript.hs
@@ -8,6 +8,9 @@ module JavaScript (
     consoleLogVal,
 
     historyPushState,
+    locationAssign,
+    locationGetHash,
+    locationSetHash,
 ) where
 
 import JavaScript.Element
@@ -29,3 +32,18 @@ historyPushState :: String -> IO ()
 historyPushState = js_history_pushState . toJSString
 foreign import javascript unsafe "history.pushState(null, '', $1)"
     js_history_pushState :: JSString -> IO ()
+
+locationAssign :: String -> IO ()
+locationAssign = js_location_assign . toJSString
+foreign import javascript unsafe "window.location.assign($1)"
+    js_location_assign :: JSString -> IO ()
+
+locationGetHash :: IO String
+locationGetHash = fromJSString <$> js_location_hash_get
+foreign import javascript unsafe "window.location.hash"
+    js_location_hash_get :: IO JSString
+
+locationSetHash :: String -> IO ()
+locationSetHash = js_location_hash_set . toJSString
+foreign import javascript unsafe "window.location.hash = $1"
+    js_location_hash_set :: JSString -> IO ()
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