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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
module Main (main, setup) where
import Control.Concurrent
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.Foldable
import Data.Proxy
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time.LocalTime
import GHC.Wasm.Prim
import Erebos.Chatroom
import Erebos.DirectMessage
import Erebos.Discovery
import Erebos.Identity
import Erebos.Network
import Erebos.PubKey
import Erebos.Service
import Erebos.State
import Erebos.Storable
import Erebos.Storage
import Erebos.Sync
import System.IO.Unsafe
import Text.Blaze.Html5 ((!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A
import Text.Blaze.Html.Renderer.String
import JavaScript qualified as JS
import WebSocket
main :: IO ()
main = error "unused"
{-# NOINLINE globalStorage #-}
globalStorage :: Storage
globalStorage = unsafePerformIO $ memoryStorage
{-# NOINLINE globalHead #-}
globalHead :: Head LocalState
globalHead = unsafePerformIO $ do
identity <- createIdentity globalStorage Nothing Nothing
storeHead globalStorage $ LocalState { lsPrev = Nothing, lsIdentity = idExtData identity, lsShared = [], lsOther = [] }
foreign export javascript setup :: IO ()
setup :: IO ()
setup = do
body <- js_document_getElementById (toJSString "body")
js_set_innerHTML body $ toJSString $ renderHtml $ do
H.div $ do
"Name: "
H.span ! A.id "name_text" $ return ()
H.div $ do
H.input ! A.id "name_set_input" ! A.type_ "text"
H.button ! A.id "name_set_button" $ "set name"
H.hr
H.div $ do
H.ul ! A.id "msg_list" $ return ()
H.div $ do
H.input ! A.id "msg_text" ! A.type_ "text"
H.button ! A.id "msg_send" $ "send"
nameElem <- js_document_getElementById (toJSString "name_text")
_ <- watchHead globalHead $ \ls -> do
js_set_textContent nameElem $ toJSString $ maybe "(Anonymous)" T.unpack $ idName $ finalOwner $ headLocalIdentity ls
let devName = T.pack "WebApp"
let st = globalStorage
owner <- createIdentity st Nothing Nothing
identity <- createIdentity st (Just devName) (Just owner)
shared <- wrappedStore st $ SharedState
{ ssPrev = []
, ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
, ssValue = [ storedRef $ idExtData owner ]
}
flip runReaderT globalHead $ do
updateLocalState_ $ \_ -> do
mstore $ LocalState
{ lsPrev = Nothing
, lsIdentity = idExtData identity
, lsShared = [ shared ]
, lsOther = []
}
setNameInput <- JS.getElementById "name_set_input"
setNameButton <- JS.getElementById "name_set_button"
JS.addEventListener setNameButton "click" $ \_ -> do
name <- T.pack . fromJSString <$> js_get_value setNameInput
js_set_value setNameInput $ toJSString ""
Just h <- reloadHead globalHead
res <- runExceptT $ flip runReaderT h $ updateSharedIdentity name
case res of
Right _ -> return ()
Left err -> JS.consoleLog $ "Failed to set name: " <> showErebosError err
messagesList <- JS.getElementById "msg_list"
tzone <- getCurrentTimeZone
void $ watchReceivedMessages globalHead $ \msg -> do
li <- js_document_createElement (toJSString "li")
content <- js_document_createTextNode $ toJSString $ formatDirectMessage tzone $ fromStored msg
js_appendChild li content
js_appendChild messagesList li
sendText <- JS.getElementById "msg_text"
sendButton <- JS.getElementById "msg_send"
server <- startServer defaultServerOptions globalHead JS.consoleLog
[ someService @ChatroomService Proxy
, someService @DiscoveryService Proxy
, someService @DirectMessage Proxy
, someService @SyncService Proxy
]
startClient "localhost" 9160 "" $ \conn -> do
void $ forkIO $ forever $ do
msg <- receiveMessage conn
receivedFromCustomAddress server conn msg
peer <- serverPeerCustom server conn
JS.addEventListener sendButton "click" $ \_ -> do
peerIdentity peer >>= \case
PeerIdentityUnknown {} -> JS.consoleLog "unknown peer identity"
PeerIdentityRef {} -> JS.consoleLog "unresolved peer identity"
PeerIdentityFull pid -> do
msg <- T.pack . fromJSString <$> js_get_value sendText
js_set_value sendText $ toJSString ""
res <- runExceptT $ flip runReaderT globalHead $ sendDirectMessage pid msg
case res of
Right _ -> return ()
Left err -> JS.consoleLog $ "Failed to send message: " <> err
updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Text -> m ()
updateSharedIdentity name = updateLocalState_ $ updateSharedState_ $ \case
Just identity -> do
Just . toComposedIdentity <$> interactiveIdentityUpdate name identity
Nothing -> throwOtherError "no existing shared identity"
interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => Text -> Identity f -> m UnifiedIdentity
interactiveIdentityUpdate name fidentity = do
identity <- mergeIdentity fidentity
if | T.null name -> return identity
| otherwise -> do
secret <- loadKey $ idKeyIdentity identity
maybe (throwOtherError "created invalid identity") return . validateExtendedIdentity =<<
mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData identity)
{ idePrev = toList $ idExtDataF identity
, ideName = Just name
}
foreign import javascript unsafe "document.getElementById($1)"
js_document_getElementById :: JSString -> IO JSVal
foreign import javascript unsafe "$1.innerHTML = $2"
js_set_innerHTML :: JSVal -> JSString -> IO ()
foreign import javascript unsafe "$1.textContent = $2"
js_set_textContent :: JSVal -> JSString -> IO ()
foreign import javascript unsafe "$1.appendChild($2)"
js_appendChild :: JSVal -> JSVal -> IO ()
foreign import javascript unsafe "document.createElement($1)"
js_document_createElement :: JSString -> IO JSVal
foreign import javascript unsafe "document.createTextNode($1)"
js_document_createTextNode :: JSString -> IO JSVal
foreign import javascript unsafe "$1.value"
js_get_value :: JSVal -> IO JSString
foreign import javascript unsafe "$1.value = $2"
js_set_value :: JSVal -> JSString -> IO ()
|