1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
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
|