@@ -0,0 +1,510 @@
1+module Ur.Run exposing (element, document, application, Program, Model, Msg)
2+
3+{-| This module contains functions to run your application with Urbit integration.
4+
5+@docs element, document, application, Program, Model, Msg
6+
7+-}
8+
9+import Browser exposing (Document, UrlRequest)
10+import Browser.Navigation as Nav
11+import Dict exposing (Dict)
12+import Either exposing (Either(..))
13+import Html exposing (Html)
14+import Json.Decode as JD
15+import Task
16+import Time
17+import Ur.Cmd
18+import Ur.Cmd.Internal
19+import Ur.Constructor as C
20+import Ur.Deconstructor as D
21+import Ur.NounDiff exposing (Patch, deconstructPatch)
22+import Ur.Requests exposing (..)
23+import Ur.Sub
24+import Ur.Sub.Internal
25+import Ur.Types exposing (..)
26+import Ur.Uw
27+import Url exposing (Url)
28+
29+
30+type alias SubDict msg =
31+ Dict
32+ -- (ship, agent, path)
33+ ( String, String, List String )
34+ { deconstructor : D.Deconstructor msg
35+ , number : Int
36+ , sink : Bool
37+ }
38+
39+
40+type alias Flags =
41+ { uid : String }
42+
43+
44+{-| An Urbit wrapper around your application model.
45+-}
46+type alias Model app msg =
47+ { subscriptions : SubDict msg
48+ , subscriptionIntMapping : Dict Int ( String, String, List String )
49+ , app : app
50+ , connected : Bool
51+ , eventId : Int
52+ , flags : Flags
53+ , requestsToRetry : List UrbitRequest
54+ , sinks : Dict Int Noun
55+ }
56+
57+
58+{-| An Urbit wrapper around your application messages.
59+-}
60+type Msg msg
61+ = AppMsg msg
62+ | EventSourceMsg JD.Value
63+ | FailedRequest (List UrbitRequest)
64+ | Noop
65+ | OpenConnection
66+ | NeedsActivation
67+ | RetryRequests
68+
69+
70+{-| A wrapper around your application `Program`.
71+-}
72+type alias Program model msg =
73+ Platform.Program Flags (Model model msg) (Msg msg)
74+
75+
76+{-| The same as `Browser.element` but with urbit stuff added around it.
77+-}
78+element :
79+ { init : ( model, Ur.Cmd.Cmd msg )
80+ , view : model -> Html msg
81+ , update : msg -> model -> ( model, Ur.Cmd.Cmd msg )
82+ , subscriptions : model -> Sub msg
83+ , urbitSubscriptions : model -> Ur.Sub.Sub msg
84+ , createEventSource : String -> Cmd (Msg msg)
85+ , onEventSourceMsg : (JD.Value -> Msg msg) -> Sub (Msg msg)
86+ , urbitUrl : model -> String
87+ }
88+ -> Program model msg
89+element inp =
90+ Browser.element
91+ { init = init inp inp.init
92+ , view = \model -> inp.view model.app |> Html.map AppMsg
93+ , update = update inp
94+ , subscriptions = subscriptions inp
95+ }
96+
97+
98+{-| The same as `Browser.element` but with urbit stuff added around it.
99+-}
100+document :
101+ { init : ( model, Ur.Cmd.Cmd msg )
102+ , view : model -> Document msg
103+ , update : msg -> model -> ( model, Ur.Cmd.Cmd msg )
104+ , subscriptions : model -> Sub msg
105+ , urbitSubscriptions : model -> Ur.Sub.Sub msg
106+ , createEventSource : String -> Cmd (Msg msg)
107+ , onEventSourceMsg : (JD.Value -> Msg msg) -> Sub (Msg msg)
108+ , urbitUrl : model -> String
109+ }
110+ -> Program model msg
111+document inp =
112+ Browser.document
113+ { init = init inp inp.init
114+ , view =
115+ \model ->
116+ inp.view model.app
117+ |> (\{ body, title } -> { title = title, body = body |> List.map (Html.map AppMsg) })
118+ , update = update inp
119+ , subscriptions = subscriptions inp
120+ }
121+
122+
123+{-| The same as `Browser.element` but with urbit stuff added around it.
124+-}
125+application :
126+ { init : Url -> Nav.Key -> ( model, Ur.Cmd.Cmd msg )
127+ , view : model -> Document msg
128+ , update : msg -> model -> ( model, Ur.Cmd.Cmd msg )
129+ , subscriptions : model -> Sub msg
130+ , urbitSubscriptions : model -> Ur.Sub.Sub msg
131+ , onUrlRequest : UrlRequest -> msg
132+ , onUrlChange : Url -> msg
133+ , createEventSource : String -> Cmd (Msg msg)
134+ , onEventSourceMsg : (JD.Value -> Msg msg) -> Sub (Msg msg)
135+ , urbitUrl : model -> String
136+ }
137+ -> Program model msg
138+application inp =
139+ let
140+ { view, onUrlRequest, onUrlChange } =
141+ inp
142+ in
143+ Browser.application
144+ { init = \flags url key -> init inp (inp.init url key) flags
145+ , view =
146+ \model ->
147+ view model.app
148+ |> (\{ body, title } -> { title = title, body = body |> List.map (Html.map AppMsg) })
149+ , update = update inp
150+ , subscriptions = subscriptions inp
151+ , onUrlRequest = \req -> onUrlRequest req |> AppMsg
152+ , onUrlChange = \url -> onUrlChange url |> AppMsg
153+ }
154+
155+
156+update :
157+ { r
158+ | update : msg -> app -> ( app, Ur.Cmd.Cmd msg )
159+ , createEventSource : String -> Cmd (Msg msg)
160+ , urbitUrl : app -> String
161+ , urbitSubscriptions : app -> Ur.Sub.Sub msg
162+ }
163+ -> Msg msg
164+ -> Model app msg
165+ -> ( Model app msg, Cmd (Msg msg) )
166+update inp msg model =
167+ let
168+ url =
169+ inp.urbitUrl model.app ++ "/~/channel/" ++ model.flags.uid
170+ in
171+ case msg of
172+ AppMsg msg_ ->
173+ let
174+ ( appModel, appCmds ) =
175+ inp.update msg_ model.app
176+
177+ subsResult =
178+ processUrSubs
179+ model.eventId
180+ model.subscriptions
181+ (inp.urbitSubscriptions appModel |> (\(Ur.Sub.Internal.Sub x) -> x))
182+
183+ ( eventId_, cmds, urReqs ) =
184+ processCmd subsResult.eventId appCmds
185+ in
186+ ( { model
187+ | app = appModel
188+ , eventId = eventId_
189+ , subscriptions = subsResult.subscriptions
190+ , subscriptionIntMapping = model.subscriptionIntMapping |> Dict.union subsResult.subscriptionIntMapping
191+ }
192+ , Cmd.batch
193+ [ cmds
194+ , Ur.Requests.send
195+ { url = url
196+ , error = Noop
197+ , success = Noop
198+ , requests = urReqs
199+ }
200+ , send
201+ { requests = subsResult.subscriptionRequests
202+ , url = url
203+ , error = subsResult.subscriptionRequests |> List.map (\( _, x ) -> x) |> FailedRequest
204+ , success = Noop
205+ }
206+ ]
207+ )
208+
209+ EventSourceMsg value ->
210+ case JD.decodeValue (JD.field "message" JD.string) value of
211+ Ok string ->
212+ case
213+ D.runBytes
214+ (D.cell D.int (D.cell D.cord D.tar))
215+ (Ur.Uw.decode string)
216+ of
217+ Just ( messageId, ( messageType, rest ) ) ->
218+ let
219+ ( eventId, ackReqs ) =
220+ tag model.eventId [ Ack messageId ]
221+
222+ ackCmd =
223+ send
224+ { requests = ackReqs
225+ , url = url
226+ , success = Noop
227+ , error = ackReqs |> List.map (\( _, x ) -> x) |> FailedRequest
228+ }
229+
230+ model_ =
231+ { model | eventId = eventId }
232+ in
233+ case messageType of
234+ "watch-ack" ->
235+ -- Not sure what to do. Assume things are fine.
236+ ( model_, ackCmd )
237+
238+ "poke-ack" ->
239+ -- Not sure what to do.
240+ ( model_, ackCmd )
241+
242+ "fact" ->
243+ case
244+ Dict.get messageId model.subscriptionIntMapping
245+ |> Maybe.andThen (\key -> Dict.get key model.subscriptions)
246+ of
247+ Just { deconstructor, sink } ->
248+ if sink then
249+ case D.run (D.cell D.ignore (D.cell D.ignore deconstructSink) |> D.map (\( (), ( (), s ) ) -> s)) rest of
250+ Just (Flush noun) ->
251+ ( { model | sinks = Dict.insert messageId noun model.sinks }
252+ , case D.run deconstructor noun of
253+ Just subMsg ->
254+ pureCmd (AppMsg subMsg)
255+
256+ -- Got garbage
257+ Nothing ->
258+ Cmd.none
259+ )
260+
261+ Just (Drain patch) ->
262+ case Dict.get messageId model.sinks of
263+ Just oldNoun ->
264+ let
265+ newNoun =
266+ Ur.NounDiff.apply patch oldNoun
267+ in
268+ ( { model | sinks = Dict.insert messageId newNoun model.sinks }
269+ , case D.run deconstructor newNoun of
270+ Just subMsg ->
271+ pureCmd (AppMsg subMsg)
272+
273+ Nothing ->
274+ Cmd.none
275+ )
276+
277+ Nothing ->
278+ ( model, Cmd.none )
279+
280+ -- Got garbage
281+ Nothing ->
282+ ( model, Cmd.none )
283+
284+ else
285+ case D.run (D.cell D.ignore (D.cell D.ignore deconstructor) |> D.map (\( (), ( (), m ) ) -> m)) rest of
286+ Just subMsg ->
287+ ( model_, pureCmd (AppMsg subMsg) )
288+
289+ -- Got gargbage
290+ Nothing ->
291+ ( model_, ackCmd )
292+
293+ -- Got a fact for a subscription we do not hold
294+ Nothing ->
295+ ( model_, ackCmd )
296+
297+ _ ->
298+ ( model_, ackCmd )
299+
300+ -- got something we don't expect
301+ Nothing ->
302+ ( model, Cmd.none )
303+
304+ Err _ ->
305+ case JD.decodeValue (JD.field "error" JD.value) value of
306+ Ok _ ->
307+ ( { model | connected = False }, Cmd.none )
308+
309+ Err _ ->
310+ -- we got garbage
311+ ( model, Cmd.none )
312+
313+ NeedsActivation ->
314+ let
315+ ( eventId, reqs ) =
316+ [ Poke { ship = "", agent = "hood", mark = "helm-hi", noun = C.cord "Opening airlock!" } ]
317+ |> tag model.eventId
318+ in
319+ ( { model | eventId = eventId }
320+ , send { url = url, requests = reqs, success = OpenConnection, error = Noop }
321+ )
322+
323+ Noop ->
324+ ( model, Cmd.none )
325+
326+ FailedRequest reqs ->
327+ ( { model | requestsToRetry = reqs ++ model.requestsToRetry }, Cmd.none )
328+
329+ OpenConnection ->
330+ ( { model | connected = True }, inp.createEventSource url )
331+
332+ RetryRequests ->
333+ let
334+ ( eventId, reqs ) =
335+ model.requestsToRetry |> tag model.eventId
336+ in
337+ ( { model | eventId = eventId, requestsToRetry = [] }
338+ , send
339+ { url = url
340+ , error = FailedRequest model.requestsToRetry
341+ , success = Noop
342+ , requests = reqs
343+ }
344+ )
345+
346+
347+type Sink
348+ = Flush Noun
349+ | Drain Patch
350+
351+
352+deconstructSink : D.Deconstructor Sink
353+deconstructSink =
354+ D.oneOf
355+ [ D.cell (D.const D.cord "flush") D.tar |> D.map (\( (), n ) -> Flush n)
356+ , D.cell (D.const D.cord "drain") (D.lazy deconstructPatch) |> D.map (\( (), patch ) -> Drain patch)
357+ ]
358+
359+
360+processCmd : EventId -> Ur.Cmd.Cmd msg -> ( EventId, Cmd (Msg msg), List ( EventId, UrbitRequest ) )
361+processCmd eventId urCmds =
362+ let
363+ ( cmds, reqs ) =
364+ urCmds
365+ |> List.map
366+ (\x ->
367+ case x of
368+ Ur.Cmd.Internal.Cmd cmd ->
369+ cmd |> Cmd.map AppMsg |> Left
370+
371+ Ur.Cmd.Internal.Poke p ->
372+ Ur.Requests.Poke p |> Right
373+ )
374+ |> Either.partition
375+
376+ ( newEventId, urReqs ) =
377+ reqs |> tag eventId
378+ in
379+ ( newEventId, Cmd.batch cmds, urReqs )
380+
381+
382+pureCmd : msg -> Cmd msg
383+pureCmd msg =
384+ Task.succeed msg |> Task.perform identity
385+
386+
387+processUrSubs :
388+ EventId
389+ -> Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId, sink : Bool }
390+ -> Dict ( Ship, Agent, Path ) { deconstructor : d, sink : Bool }
391+ ->
392+ { subscriptions : Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId, sink : Bool }
393+ , eventId : EventId
394+ , subscriptionRequests : List ( EventId, UrbitRequest )
395+ , subscriptionIntMapping : Dict EventId ( Ship, Agent, Path )
396+ }
397+processUrSubs eventId existingSubscriptions urbitSubs_ =
398+ let
399+ urbitSubs =
400+ urbitSubs_
401+ |> Dict.map (\_ { deconstructor, sink } -> { deconstructor = deconstructor, sink = sink })
402+
403+ ( eventId_, newSubscriptionActions ) =
404+ Dict.diff urbitSubs existingSubscriptions
405+ |> Dict.toList
406+ |> List.map (\( address, _ ) -> ( Subscribe address, address ))
407+ |> tag eventId
408+
409+ removedSubscriptions =
410+ Dict.diff existingSubscriptions urbitSubs
411+
412+ ( eventId__, removedSubscriptionActions ) =
413+ removedSubscriptions
414+ |> Dict.toList
415+ |> List.map (\( _, { number } ) -> Unsubscribe number)
416+ |> tag eventId_
417+
418+ keyToNumber =
419+ newSubscriptionActions |> List.map (\( a, ( _, b ) ) -> ( b, a )) |> Dict.fromList
420+
421+ newSubscriptions =
422+ Dict.merge
423+ (\_ _ x -> x)
424+ (\key number { deconstructor, sink } ->
425+ Dict.insert key
426+ { deconstructor = deconstructor
427+ , number = number
428+ , sink = sink
429+ }
430+ )
431+ (\_ _ x -> x)
432+ keyToNumber
433+ urbitSubs
434+ Dict.empty
435+ in
436+ { subscriptions = Dict.diff existingSubscriptions removedSubscriptions |> Dict.union newSubscriptions
437+ , subscriptionIntMapping =
438+ newSubscriptions
439+ |> Dict.toList
440+ |> List.map (\( key, { number } ) -> ( number, key ))
441+ |> Dict.fromList
442+ , eventId = eventId__
443+ , subscriptionRequests =
444+ removedSubscriptionActions ++ (newSubscriptionActions |> List.map (\( id, ( req, _ ) ) -> ( id, req )))
445+ }
446+
447+
448+init :
449+ { a | urbitSubscriptions : model -> Ur.Sub.Sub msg, urbitUrl : model -> String }
450+ -> ( model, Ur.Cmd.Cmd msg )
451+ -> Flags
452+ ->
453+ ( Model model msg
454+ , Cmd (Msg msg)
455+ )
456+init inp ( app, appCmds ) flags =
457+ let
458+ subsResult =
459+ processUrSubs
460+ 0
461+ Dict.empty
462+ (inp.urbitSubscriptions app |> (\(Ur.Sub.Internal.Sub x) -> x))
463+
464+ ( eventId_, cmds, urReqs ) =
465+ processCmd subsResult.eventId appCmds
466+
467+ url =
468+ inp.urbitUrl app ++ "/~/channel/" ++ flags.uid
469+ in
470+ ( { subscriptions = subsResult.subscriptions
471+ , sinks = Dict.empty
472+ , subscriptionIntMapping = subsResult.subscriptionIntMapping
473+ , app = app
474+ , connected = False
475+ , eventId = eventId_
476+ , flags = flags
477+ , requestsToRetry = []
478+ }
479+ , [ cmds
480+ , pureCmd NeedsActivation
481+ , send
482+ { requests = urReqs ++ subsResult.subscriptionRequests
483+ , url = url
484+ , error = Noop
485+ , success = Noop
486+ }
487+ ]
488+ |> Cmd.batch
489+ )
490+
491+
492+subscriptions :
493+ { a | subscriptions : b -> Sub msg, onEventSourceMsg : (JD.Value -> Msg c) -> Sub (Msg msg) }
494+ -> { d | app : b, requestsToRetry : List e, connected : Bool }
495+ -> Sub (Msg msg)
496+subscriptions inp model =
497+ Sub.batch
498+ [ inp.subscriptions model.app |> Sub.map AppMsg
499+ , inp.onEventSourceMsg EventSourceMsg
500+ , if List.isEmpty model.requestsToRetry then
501+ Sub.none
502+
503+ else
504+ Time.every 1000 (always RetryRequests)
505+ , if not model.connected then
506+ Time.every 10000 (always NeedsActivation)
507+
508+ else
509+ Sub.none
510+ ]