-
Notifications
You must be signed in to change notification settings - Fork 14
/
MutableApp.fs
344 lines (275 loc) · 16.1 KB
/
MutableApp.fs
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
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
namespace Aardvark.UI
open System
open System.Threading
open System.Collections.Generic
open System.Collections.Concurrent
open Aardvark.Base
open Aardvark.Base.Geometry
open Aardvark.GPGPU
open Aardvark.Rendering
open Aardvark.SceneGraph
open FSharp.Data.Adaptive
open Aardvark.Application
open Aardvark.Service
open Aardvark.UI.Internal
open Suave
open Suave.Control
open Suave.Filters
open Suave.Operators
open Suave.WebSocket
open Suave.Successful
open Suave.Sockets.Control
open Suave.Sockets
open Suave.State.CookieStateStore
type EmbeddedResources = EmbeddedResources
[<AutoOpen>]
module private Tools =
type WebSocket with
member x.readMessage() =
socket {
let! (t,d,fin) = x.read()
if fin then
return (t,d)
else
let! (_, rest) = x.readMessage()
return (t, Array.append d rest)
}
// https://github.com/aardvark-platform/aardvark.media/issues/19
module ThreadPoolAdjustment =
let mutable shouldAdjust = true
let adjust () =
if shouldAdjust then
let mutable maxThreads,maxIOThreads = 0,0
System.Threading.ThreadPool.GetMaxThreads(&maxThreads,&maxIOThreads)
let mutable minThreads, minIOThreads = 0,0
System.Threading.ThreadPool.GetMinThreads(&minThreads,&minIOThreads)
if minThreads < 12 || minIOThreads < 12 then
Log.warn "[aardvark.media] currently ThreadPool.MinThreads is (%d,%d)" minThreads minIOThreads
let minThreads = max 12 minThreads
let minIOThreads = max 12 minIOThreads
Log.warn "[aardvark.media] unfortunately, currently we need to adjust this to at least (12,12) due to an open issue https://github.com/aardvark-platform/aardvark.media/issues/19"
if not <| System.Threading.ThreadPool.SetMinThreads(minThreads, minIOThreads) then Log.warn "could not set min threads"
if maxThreads < 12 || maxIOThreads < 12 then
Log.warn "[aardvark.media] detected less than 12 threadpool threads: (%d,%d). Be aware that this will result in severe stutters... Consider switching back to the default (65537,1000)." maxThreads maxIOThreads
module MutableApp =
open Aardvark.UI.Internal.Updaters
let private template =
let html =
let ass = typeof<DomNode<_>>.Assembly
use stream = ass.GetManifestResourceStream("Aardvark.UI.template.html")
let reader = new IO.StreamReader(stream)
reader.ReadToEnd()
fun (title: string) -> html |> String.replace "__TITLE__" title
type private EventMessage =
{
sender : string
name : string
args : array<string>
}
let private (|Guid|_|) (str : string) =
match Guid.TryParse str with
| (true, guid) -> Some guid
| _ -> None
type private DummyObject() =
inherit AdaptiveObject()
let toWebPart' (runtime : IRuntime) (useGpuCompression : bool) (app : MutableApp<'model, 'msg>) =
ThreadPoolAdjustment.adjust ()
let sceneStore =
ConcurrentDictionary<string, Scene * Option<SceneMessages<'msg>> * (ClientInfo -> ClientState)>()
let compressor =
if useGpuCompression then new JpegCompressor(runtime) |> Some
else None
let renderer =
{
runtime = runtime
content = fun sceneName ->
match sceneStore.TryGetValue sceneName with
| (true, (scene, _, _)) -> Some scene
| _ -> None
getState = fun clientInfo ->
match sceneStore.TryGetValue clientInfo.sceneName with
| (true, (scene, update, cam)) ->
match update with
| Some sceneMessages ->
let msgs = sceneMessages.preRender clientInfo
if not (Seq.isEmpty msgs) then
app.updateSync clientInfo.session msgs
| None ->
()
Some (cam clientInfo)
| _ ->
None
compressor = compressor
rendered = fun clientInfo ->
match sceneStore.TryGetValue clientInfo.sceneName with
| (true, (scene, update, cam)) ->
match update with
| Some sceneMessages ->
let msgs = sceneMessages.postRender clientInfo
if not (Seq.isEmpty msgs) then
app.updateSync clientInfo.session msgs
| None ->
()
| _ ->
()
fileSystemRoot = None //Some "/"
}
let events (ws : WebSocket) (context: HttpContext) =
match context.request.queryParam "session" with
| Choice1Of2 (Guid sessionId) ->
let request =
{
requestPath = context.request.path
queryParams = context.request.query |> List.choose (function (k, Some v) -> Some (k,v) | _ -> None) |> Map.ofList
}
let updater = app.ui.NewUpdater(request)
let handlers = Dictionary()
let scenes = Dictionary()
let state : UpdateState<'msg> =
{
scenes = ContraDict.ofDictionary scenes
handlers = ContraDict.ofDictionary handlers
references = Dictionary()
activeChannels = Dict()
messages = app.messages
}
let o = DummyObject()
let update = MVar.create true
let subscription = o.AddMarkingCallback(fun () -> MVar.put update true)
let mutable running = true
let mutable oldChannels : Set<string * string> = Set.empty
let send (arr : byte[]) =
let rec res retries =
async {
try
return! ws.send Opcode.Text (ByteSegment(arr)) true
with e ->
Log.warn "[Media] send failed: %s (retries=%d)" e.Message retries
do! Async.Sleep 100
return! res (retries - 1)
}
let res = res 10 |> Async.RunSynchronously
match res with
| Choice1Of2 () ->
()
| Choice2Of2 err ->
failwithf "[WS] error: %A" err
let updateFunction () =
try
while running do
let cont = MVar.take update
if cont then
lock app.lock (fun () ->
o.EvaluateAlways AdaptiveToken.Top (fun t ->
if Config.shouldTimeJsCodeGeneration then
Log.startTimed "[Aardvark.UI] generating code (updater.Update + js post processing)"
let code =
let expr =
lock state (fun () ->
state.references.Clear()
if Config.shouldTimeUIUpdate then Log.startTimed "[Aardvark.UI] updating UI"
let r = updater.Update(t,state, Some (fun n -> JSExpr.AppendChild(JSExpr.Body, n)))
if Config.shouldTimeUIUpdate then Log.stop ()
r
)
for (name, sd) in Dictionary.toSeq scenes do
sceneStore.TryAdd(name, sd) |> ignore
let newReferences = state.references.Values |> Seq.toArray
if Config.showTimeJsAssembly then Log.startTimed "[Aardvark.UI] JS assembler"
let code = expr |> JSExpr.toString
let code = code.Trim [| ' '; '\r'; '\n'; '\t' |]
if Config.showTimeJsAssembly then Log.stop()
if newReferences.Length > 0 then
let args =
newReferences |> Seq.map (fun r ->
sprintf "{ kind: \"%s\", name: \"%s\", url: \"%s\" }" (if r.kind = Script then "script" else "stylesheet") r.name r.url
) |> String.concat "," |> sprintf "[%s]"
let code = String.indent 1 code
sprintf "aardvark.addReferences(%s, function() {\r\n%s\r\n});" args code
else
code
if Config.shouldTimeJsCodeGeneration then
Log.line "[Aardvark.UI] code length: %d" (code.Length); Log.stop()
if code <> "" then
lock app (fun () ->
if Config.shouldPrintDOMUpdates then
let lines = code.Split([| "\r\n" |], System.StringSplitOptions.None)
Log.start "update"
for l in lines do Log.line "%s" l
Log.stop()
match Config.dumpJsCodeFile with
| None -> ()
| Some file ->
try
System.IO.File.AppendAllText(file,code)
with e ->
printfn "%A" e
)
send (Text.Encoding.UTF8.GetBytes("x" + code))
let mutable o = oldChannels
let mutable c = Set.empty
for (KeyValue((id,name), cr)) in state.activeChannels do
match cr.GetMessages(t) with
| [] -> ()
| messages ->
let message = Pickler.json.Pickle { targetId = id; channel = name; data = messages }
send message
c <- Set.add (id, name) c
o <- Set.remove (id, name) o
for (id, name) in o do
let message = Pickler.json.Pickle { targetId = id; channel = name; data = [Pickler.json.PickleToString "commit-suicide"] }
send message
oldChannels <- c
)
)
with e ->
Config.updateThreadFailed e
()
//raise e
let updateThread = Thread(ThreadStart updateFunction)
updateThread.IsBackground <- true
updateThread.Name <- "[media] UpdateThread"
updateThread.Start()
socket {
while running do
let! code, data = ws.readMessage()
match code with
| Opcode.Text ->
try
if data.Length > 0 && data.[0] = uint8 '#' then
let str = System.Text.Encoding.UTF8.GetString(data, 1, data.Length - 1)
match str with
| "ping" ->
do! ws.send Opcode.Pong (ByteSegment([||])) true
| _ ->
Log.warn "bad opcode: %A" str
else
let evt : EventMessage = Pickler.json.UnPickle data
match lock state (fun () -> handlers.TryGetValue((evt.sender, evt.name))) with
| (true, handler) ->
let msgs = handler sessionId evt.sender (Array.toList evt.args)
app.update sessionId msgs
| _ ->
()
with e ->
Log.warn "unpickle faulted: %A" e
| Opcode.Close ->
running <- false
| Opcode.Ping ->
do! ws.send Opcode.Pong (ByteSegment([||])) true
| _ ->
Log.warn "[MutableApp] unknown message: %A" (code,data)
MVar.put update false
updater.Destroy(state, JSExpr.Body) |> ignore
subscription.Dispose()
}
| _ ->
SocketOp.abort(Error.InputDataError(None, "no session id"))
choose [
prefix "/rendering" >=> Aardvark.Service.Server.toWebPart app.lock renderer
Reflection.assemblyWebPart typeof<EmbeddedResources>.Assembly
path "/events" >=> handShake events
path "/" >=> OK (template Config.defaultDocumentTitle)
]
let toWebPart (runtime : IRuntime) (app : MutableApp<'model, 'msg>) =
toWebPart' runtime false app