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
|
module Main (main, setup) where
import Control.Concurrent
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.Maybe
import Data.Proxy
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.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 (Just $ T.pack "<init>") 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.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 $ T.unpack $ displayIdentity $ headLocalIdentity ls
let name = T.pack "My Name"
devName = T.pack "WebApp"
let st = globalStorage
owner <- if
| T.null name -> return Nothing
| otherwise -> Just <$> createIdentity st (Just name) Nothing
identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner
shared <- wrappedStore st $ SharedState
{ ssPrev = []
, ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
, ssValue = [ storedRef $ idExtData $ fromMaybe identity owner ]
}
flip runReaderT globalHead $ do
updateLocalState_ $ \_ -> do
mstore $ LocalState
{ lsPrev = Nothing
, lsIdentity = idExtData identity
, lsShared = [ shared ]
, lsOther = []
}
messagesList <- JS.getElementById "msg_list"
tzone <- getCurrentTimeZone
void $ watchReceivedMessages globalHead $ \msg -> do
JS.consoleLog $ formatDirectMessage tzone $ fromStored msg
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 sent -> JS.consoleLog . ("sent message: " <>) $ formatDirectMessage tzone $ fromStored sent
Left err -> JS.consoleLog $ "Failed to send message: " <> err
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 ()
|