Attach service handling using URL parameter

1 files changed, 157 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