summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs157
-rw-r--r--src/JavaScript.hs18
-rw-r--r--src/Main.hs22
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-08-04 23:15:05 +0000