@@ -1,510 +0,0 @@
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− ]