@@ -0,0 +1,510 @@
1+module Ur.Run exposing (element, document, application, Program, Model, Msg)
3+{-| This module contains functions to run your application with Urbit integration.
5+@docs element, document, application, Program, Model, Msg
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
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 (..)
24+import Ur.Sub.Internal
25+import Ur.Types exposing (..)
27+import Url exposing (Url)
30+type alias SubDict msg =
32+ -- (ship, agent, path)
33+ ( String, String, List String )
34+ { deconstructor : D.Deconstructor msg
44+{-| An Urbit wrapper around your application model.
46+type alias Model app msg =
47+ { subscriptions : SubDict msg
48+ , subscriptionIntMapping : Dict Int ( String, String, List String )
53+ , requestsToRetry : List UrbitRequest
54+ , sinks : Dict Int Noun
58+{-| An Urbit wrapper around your application messages.
62+ | EventSourceMsg JD.Value
63+ | FailedRequest (List UrbitRequest)
70+{-| A wrapper around your application `Program`.
72+type alias Program model msg =
73+ Platform.Program Flags (Model model msg) (Msg msg)
76+{-| The same as `Browser.element` but with urbit stuff added around it.
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
91+ { init = init inp inp.init
92+ , view = \model -> inp.view model.app |> Html.map AppMsg
93+ , update = update inp
94+ , subscriptions = subscriptions inp
98+{-| The same as `Browser.element` but with urbit stuff added around it.
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
110+ -> Program model msg
113+ { init = init inp inp.init
117+ |> (\{ body, title } -> { title = title, body = body |> List.map (Html.map AppMsg) })
118+ , update = update inp
119+ , subscriptions = subscriptions inp
123+{-| The same as `Browser.element` but with urbit stuff added around it.
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
137+ -> Program model msg
140+ { view, onUrlRequest, onUrlChange } =
144+ { init = \flags url key -> init inp (inp.init url key) flags
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
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
165+ -> ( Model app msg, Cmd (Msg msg) )
166+update inp msg model =
169+ inp.urbitUrl model.app ++ "/~/channel/" ++ model.flags.uid
174+ ( appModel, appCmds ) =
175+ inp.update msg_ model.app
181+ (inp.urbitSubscriptions appModel |> (\(Ur.Sub.Internal.Sub x) -> x))
183+ ( eventId_, cmds, urReqs ) =
184+ processCmd subsResult.eventId appCmds
188+ , eventId = eventId_
189+ , subscriptions = subsResult.subscriptions
190+ , subscriptionIntMapping = model.subscriptionIntMapping |> Dict.union subsResult.subscriptionIntMapping
201+ { requests = subsResult.subscriptionRequests
203+ , error = subsResult.subscriptionRequests |> List.map (\( _, x ) -> x) |> FailedRequest
209+ EventSourceMsg value ->
210+ case JD.decodeValue (JD.field "message" JD.string) value of
214+ (D.cell D.int (D.cell D.cord D.tar))
215+ (Ur.Uw.decode string)
217+ Just ( messageId, ( messageType, rest ) ) ->
219+ ( eventId, ackReqs ) =
220+ tag model.eventId [ Ack messageId ]
224+ { requests = ackReqs
227+ , error = ackReqs |> List.map (\( _, x ) -> x) |> FailedRequest
231+ { model | eventId = eventId }
235+ -- Not sure what to do. Assume things are fine.
239+ -- Not sure what to do.
244+ Dict.get messageId model.subscriptionIntMapping
245+ |> Maybe.andThen (\key -> Dict.get key model.subscriptions)
247+ Just { deconstructor, sink } ->
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
254+ pureCmd (AppMsg subMsg)
261+ Just (Drain patch) ->
262+ case Dict.get messageId model.sinks of
266+ Ur.NounDiff.apply patch oldNoun
268+ ( { model | sinks = Dict.insert messageId newNoun model.sinks }
269+ , case D.run deconstructor newNoun of
271+ pureCmd (AppMsg subMsg)
285+ case D.run (D.cell D.ignore (D.cell D.ignore deconstructor) |> D.map (\( (), ( (), m ) ) -> m)) rest of
287+ ( model_, pureCmd (AppMsg subMsg) )
293+ -- Got a fact for a subscription we do not hold
300+ -- got something we don't expect
305+ case JD.decodeValue (JD.field "error" JD.value) value of
307+ ( { model | connected = False }, Cmd.none )
316+ [ Poke { ship = "", agent = "hood", mark = "helm-hi", noun = C.cord "Opening airlock!" } ]
317+ |> tag model.eventId
319+ ( { model | eventId = eventId }
320+ , send { url = url, requests = reqs, success = OpenConnection, error = Noop }
326+ FailedRequest reqs ->
327+ ( { model | requestsToRetry = reqs ++ model.requestsToRetry }, Cmd.none )
330+ ( { model | connected = True }, inp.createEventSource url )
335+ model.requestsToRetry |> tag model.eventId
337+ ( { model | eventId = eventId, requestsToRetry = [] }
340+ , error = FailedRequest model.requestsToRetry
352+deconstructSink : D.Deconstructor Sink
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)
360+processCmd : EventId -> Ur.Cmd.Cmd msg -> ( EventId, Cmd (Msg msg), List ( EventId, UrbitRequest ) )
361+processCmd eventId urCmds =
368+ Ur.Cmd.Internal.Cmd cmd ->
369+ cmd |> Cmd.map AppMsg |> Left
371+ Ur.Cmd.Internal.Poke p ->
372+ Ur.Requests.Poke p |> Right
376+ ( newEventId, urReqs ) =
379+ ( newEventId, Cmd.batch cmds, urReqs )
382+pureCmd : msg -> Cmd msg
384+ Task.succeed msg |> Task.perform identity
389+ -> Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId, sink : Bool }
390+ -> Dict ( Ship, Agent, Path ) { deconstructor : d, sink : Bool }
392+ { subscriptions : Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId, sink : Bool }
394+ , subscriptionRequests : List ( EventId, UrbitRequest )
395+ , subscriptionIntMapping : Dict EventId ( Ship, Agent, Path )
397+processUrSubs eventId existingSubscriptions urbitSubs_ =
401+ |> Dict.map (\_ { deconstructor, sink } -> { deconstructor = deconstructor, sink = sink })
403+ ( eventId_, newSubscriptionActions ) =
404+ Dict.diff urbitSubs existingSubscriptions
406+ |> List.map (\( address, _ ) -> ( Subscribe address, address ))
409+ removedSubscriptions =
410+ Dict.diff existingSubscriptions urbitSubs
412+ ( eventId__, removedSubscriptionActions ) =
413+ removedSubscriptions
415+ |> List.map (\( _, { number } ) -> Unsubscribe number)
419+ newSubscriptionActions |> List.map (\( a, ( _, b ) ) -> ( b, a )) |> Dict.fromList
424+ (\key number { deconstructor, sink } ->
426+ { deconstructor = deconstructor
436+ { subscriptions = Dict.diff existingSubscriptions removedSubscriptions |> Dict.union newSubscriptions
437+ , subscriptionIntMapping =
440+ |> List.map (\( key, { number } ) -> ( number, key ))
442+ , eventId = eventId__
443+ , subscriptionRequests =
444+ removedSubscriptionActions ++ (newSubscriptionActions |> List.map (\( id, ( req, _ ) ) -> ( id, req )))
449+ { a | urbitSubscriptions : model -> Ur.Sub.Sub msg, urbitUrl : model -> String }
450+ -> ( model, Ur.Cmd.Cmd msg )
456+init inp ( app, appCmds ) flags =
462+ (inp.urbitSubscriptions app |> (\(Ur.Sub.Internal.Sub x) -> x))
464+ ( eventId_, cmds, urReqs ) =
465+ processCmd subsResult.eventId appCmds
468+ inp.urbitUrl app ++ "/~/channel/" ++ flags.uid
470+ ( { subscriptions = subsResult.subscriptions
471+ , sinks = Dict.empty
472+ , subscriptionIntMapping = subsResult.subscriptionIntMapping
475+ , eventId = eventId_
477+ , requestsToRetry = []
480+ , pureCmd NeedsActivation
482+ { requests = urReqs ++ subsResult.subscriptionRequests
493+ { a | subscriptions : b -> Sub msg, onEventSourceMsg : (JD.Value -> Msg c) -> Sub (Msg msg) }
494+ -> { d | app : b, requestsToRetry : List e, connected : Bool }
496+subscriptions inp model =
498+ [ inp.subscriptions model.app |> Sub.map AppMsg
499+ , inp.onEventSourceMsg EventSourceMsg
500+ , if List.isEmpty model.requestsToRetry then
504+ Time.every 1000 (always RetryRequests)
505+ , if not model.connected then
506+ Time.every 10000 (always NeedsActivation)