From 5590712d02e6a351649c4b00b1fcc0555422be16 Mon Sep 17 00:00:00 2001 From: iko Date: Fri, 16 Jun 2023 16:11:42 +0300 Subject: [PATCH] Added pokes --- example/elm.json | 15 +++- example/src/Main.elm | 184 +++++++++++++++++++++++++++++++++++++--- src/Ur/Cmd.elm | 35 ++++++++ src/Ur/Cmd/Internal.elm | 9 ++ src/Ur/Da.elm | 23 +++++ src/Ur/Requests.elm | 83 ++++++++++++++++-- src/Ur/Run.elm | 76 ++++++++++++++--- 7 files changed, 389 insertions(+), 36 deletions(-) create mode 100644 src/Ur/Cmd.elm create mode 100644 src/Ur/Cmd/Internal.elm create mode 100644 src/Ur/Da.elm diff --git a/example/elm.json b/example/elm.json index e08c5e4..3909e4f 100644 --- a/example/elm.json +++ b/example/elm.json @@ -7,6 +7,7 @@ "elm-version": "0.19.1", "dependencies": { "direct": { + "Orasund/elm-ui-widgets": "3.4.0", "TSFoster/elm-bytes-extra": "1.3.0", "chelovek0v/bbase64": "1.0.1", "cmditch/elm-bigint": "2.0.1", @@ -17,24 +18,32 @@ "elm/http": "2.0.0", "elm/json": "1.1.3", "elm/parser": "1.1.0", + "elm/time": "1.0.0", "elm/url": "1.0.0", "elm-community/list-extra": "8.7.0", "elm-community/maybe-extra": "5.3.0", "figbus/elm-urbit-api": "4.0.1", + "jasonliang-dev/elm-heroicons": "2.0.0", "jxxcarlson/hex": "4.0.0", "ktonon/elm-word": "2.1.2", "mdgriffith/elm-ui": "1.1.8", - "robinheghan/murmur3": "1.0.0" + "robinheghan/murmur3": "1.0.0", + "toastal/either": "3.6.3" }, "indirect": { "AdrianRibao/elm-derberos-date": "1.2.3", + "avh4/elm-color": "1.0.0", "bitsoflogic/elm-radixint": "2.0.0", "elm/file": "1.0.5", "elm/random": "1.0.0", "elm/regex": "1.0.0", - "elm/time": "1.0.0", + "elm/svg": "1.0.1", "elm/virtual-dom": "1.0.3", - "rtfeldman/elm-hex": "1.0.0" + "elm-community/intdict": "3.0.0", + "fredcy/elm-parseint": "2.0.1", + "noahzgordon/elm-color-extra": "1.0.2", + "rtfeldman/elm-hex": "1.0.0", + "turboMaCk/queue": "1.1.0" } }, "test-dependencies": { diff --git a/example/src/Main.elm b/example/src/Main.elm index ae37e38..1c4fa35 100644 --- a/example/src/Main.elm +++ b/example/src/Main.elm @@ -1,12 +1,24 @@ port module Main exposing (main) +import BigInt exposing (BigInt) import Browser exposing (Document) import Element exposing (..) +import Element.Border as Border +import Heroicons.Outline import Json.Decode as JD +import Task +import Time import Ur +import Ur.Cmd +import Ur.Constructor as C +import Ur.Da import Ur.Deconstructor as D +import Ur.Requests import Ur.Run import Ur.Sub +import Widget +import Widget.Icon as Icon +import Widget.Material as Material main = @@ -14,22 +26,44 @@ main = { init = \_ _ -> ( { error = "" + , entries = Nothing + , newEntry = "" } - , Ur.logIn "http://localhost:8080" "lidlut-tabwed-pillex-ridrup" - |> Cmd.map (result (Debug.toString >> Error) (always Noop)) + , Cmd.batch + [ Ur.logIn "http://localhost:8080" "lidlut-tabwed-pillex-ridrup" + |> Cmd.map (result (Debug.toString >> Error) (always Noop)) + , Ur.Requests.scry + { url = "http://localhost:8080" + , agent = "journal" + , path = [ "entries", "all" ] + , error = Noop + , success = + D.cell D.ignore + (D.cell (D.const D.cord "jrnl") + (D.list (D.cell D.bigint D.cord |> D.map (\a b -> ( a, b )))) + |> D.map GotListings + ) + } + ] + |> Ur.Cmd.cmd ) , update = update , view = view , subscriptions = always Sub.none , createEventSource = createEventSource , urbitSubscriptions = - \_ -> - Ur.Sub.subscribe - { ship = "~zod" - , app = "journal" - , path = [ "updates" ] - , deconstructor = D.tar |> D.map (always Noop) - } + \{ entries } -> + case entries of + Nothing -> + Ur.Sub.none + + Just _ -> + Ur.Sub.subscribe + { ship = "~zod" + , app = "journal" + , path = [ "updates" ] + , deconstructor = decodeJournalUpdate |> D.map GotUpdate + } , onEventSourceMsg = onEventSourceMessage , onUrlChange = \_ -> Noop , onUrlRequest = \_ -> Noop @@ -39,28 +73,152 @@ main = type alias Model = { error : String + , entries : Maybe (List ( BigInt, String )) + , newEntry : String } type Msg = Noop | Error String + | GotListings (List ( BigInt, String )) + | GotUpdate JournalUpdate + | UpdateNewEntry String + | DeleteEntry BigInt + | AddEntry String + | RunCmd (Ur.Cmd.Cmd Msg) -update : Msg -> Model -> ( Model, Cmd msg ) +update : Msg -> Model -> ( Model, Ur.Cmd.Cmd Msg ) update msg model = case msg of Noop -> - ( model, Cmd.none ) + ( model, Ur.Cmd.none ) Error err -> - ( { model | error = err }, Cmd.none ) + ( { model | error = err }, Ur.Cmd.none ) + + GotListings entries -> + ( { model | entries = Just entries }, Ur.Cmd.none ) + + GotUpdate action -> + let + applyAction oldEntries = + case action of + Add id txt -> + ( id, txt ) :: oldEntries + + Edit id txt -> + oldEntries + |> List.map + (\(( key, _ ) as value) -> + if key == id then + ( key, txt ) + + else + value + ) + + Delete id -> + oldEntries |> List.filter (\( key, _ ) -> key /= id) + + newEntries = + model.entries |> Maybe.map applyAction + in + ( { model | entries = newEntries }, Ur.Cmd.none ) + + UpdateNewEntry txt -> + ( { model | newEntry = txt }, Ur.Cmd.none ) + + DeleteEntry id -> + ( model + , Ur.Cmd.poke + { ship = "~zod" + , agent = "journal" + , mark = "journal-action" + , noun = C.cell (C.cord "del") (C.bigint id) + } + ) + + AddEntry txt -> + ( { model | newEntry = "" } + , Time.now + |> Task.perform + (\time -> + Ur.Cmd.poke + { ship = "~zod" + , agent = "journal" + , mark = "journal-action" + , noun = C.cell (C.cord "add") (C.cell (Ur.Da.posixToDa time |> C.bigint) (C.cord txt)) + } + |> RunCmd + ) + |> Ur.Cmd.cmd + ) + + RunCmd cmd -> + ( model, cmd ) + + +type JournalUpdate + = Add BigInt String + | Edit BigInt String + | Delete BigInt + + +decodeJournalUpdate : D.Deconstructor (JournalUpdate -> a) a +decodeJournalUpdate = + D.cell D.ignore <| + D.oneOf + [ (D.cell (D.const D.cord "add") <| D.cell D.bigint D.cord) |> D.map Add + , (D.cell (D.const D.cord "edit") <| D.cell D.bigint D.cord) |> D.map Edit + , D.cell (D.const D.cord "del") D.bigint |> D.map Delete + ] view : Model -> Document Msg view model = { body = - [ layout [] (column [ centerX, centerY ] [ el [ alignTop ] (text model.error), text "Hello" ]) ] + [ layout [] + ([ el [ alignTop ] (text model.error) + , row [ spacing 8 ] + [ Widget.textInput (Material.textInput Material.defaultPalette) + { chips = [] + , text = model.newEntry + , placeholder = Nothing + , label = "New entry" + , onChange = UpdateNewEntry + } + , Widget.iconButton (Material.containedButton Material.defaultPalette) + { text = "submit" + , icon = Icon.elmHeroicons Heroicons.Outline.check + , onPress = AddEntry model.newEntry |> Just + } + ] + , model.entries + |> Maybe.withDefault [] + |> List.map + (\( id, txt ) -> + row + [ Border.rounded 10 + , Border.shadow { offset = ( 0, 5 ), size = 1, blur = 10, color = rgba 0 0 0 0.3 } + , centerX + , padding 10 + , spacing 12 + ] + [ paragraph [] [ text txt ] + , Widget.iconButton (Material.containedButton Material.defaultPalette) + { text = "delete" + , icon = Icon.elmHeroicons Heroicons.Outline.trash + , onPress = DeleteEntry id |> Just + } + ] + ) + |> column [ spacing 10, centerX ] + ] + |> column [ spacing 18, centerX ] + ) + ] , title = "Airlock" } diff --git a/src/Ur/Cmd.elm b/src/Ur/Cmd.elm new file mode 100644 index 0000000..8018ea3 --- /dev/null +++ b/src/Ur/Cmd.elm @@ -0,0 +1,35 @@ +module Ur.Cmd exposing + ( Cmd + , batch + , cmd + , none + , poke + ) + +import Ur exposing (Agent, Mark, Noun) +import Ur.Cmd.Internal +import Ur.Phonemic exposing (Ship) + + +type alias Cmd msg = + List (Ur.Cmd.Internal.Cmd msg) + + +none : Cmd msg +none = + [] + + +poke : { ship : Ship, agent : Agent, mark : Mark, noun : Noun } -> Cmd msg +poke p = + [ Ur.Cmd.Internal.Poke p ] + + +cmd : Cmd.Cmd msg -> Cmd msg +cmd c = + [ Ur.Cmd.Internal.Cmd c ] + + +batch : List (Cmd msg) -> Cmd msg +batch = + List.concat diff --git a/src/Ur/Cmd/Internal.elm b/src/Ur/Cmd/Internal.elm new file mode 100644 index 0000000..44530a1 --- /dev/null +++ b/src/Ur/Cmd/Internal.elm @@ -0,0 +1,9 @@ +module Ur.Cmd.Internal exposing (Cmd(..)) + +import Ur exposing (Agent, Mark, Noun) +import Ur.Phonemic exposing (Ship) + + +type Cmd msg + = Poke { ship : Ship, agent : Agent, mark : Mark, noun : Noun } + | Cmd (Cmd.Cmd msg) diff --git a/src/Ur/Da.elm b/src/Ur/Da.elm new file mode 100644 index 0000000..b269694 --- /dev/null +++ b/src/Ur/Da.elm @@ -0,0 +1,23 @@ +module Ur.Da exposing (Da, posixToDa) + +import BigInt exposing (BigInt) +import Time exposing (Posix) + + +type alias Da = + BigInt + + +unixEpochStart : BigInt +unixEpochStart = + BigInt.fromIntString "170141184475152167957503069145530368000" |> Maybe.withDefault (BigInt.fromInt 0) + + +second : BigInt +second = + BigInt.fromIntString "18446744073709551616" |> Maybe.withDefault (BigInt.fromInt 0) + + +posixToDa : Posix -> Da +posixToDa p = + BigInt.add (BigInt.div (BigInt.mul (BigInt.fromInt (Time.posixToMillis p)) second) (BigInt.fromInt 1000)) unixEpochStart diff --git a/src/Ur/Requests.elm b/src/Ur/Requests.elm index 65e7815..75742ae 100644 --- a/src/Ur/Requests.elm +++ b/src/Ur/Requests.elm @@ -1,14 +1,19 @@ module Ur.Requests exposing ( EventId , UrbitRequest(..) + , scry + , scryTask , send + , sendTask , tag , toNoun ) import Http +import Task exposing (Task) import Ur exposing (..) import Ur.Constructor as C +import Ur.Deconstructor as D import Ur.Phonemic exposing (Ship) import Ur.Uw @@ -30,8 +35,6 @@ tag eventId reqs = tag (eventId + 1) rest |> Tuple.mapSecond (\xs -> ( eventId, req ) :: xs) -{-| `requests` should the result of calling `tag` --} send : { url : String , error : msg @@ -39,12 +42,25 @@ send : , requests : List ( EventId, UrbitRequest ) } -> Cmd msg -send { url, error, success, requests } = +send inp = + sendTask inp |> Task.perform identity + + +{-| `requests` should the result of calling `tag` +-} +sendTask : + { url : String + , error : msg + , success : msg + , requests : List ( EventId, UrbitRequest ) + } + -> Task a msg +sendTask { url, error, success, requests } = if List.isEmpty requests then - Cmd.none + Task.succeed success else - Http.riskyRequest + Http.riskyTask { method = "PUT" , headers = [] , url = url @@ -55,9 +71,17 @@ send { url, error, success, requests } = |> Ur.jam |> Ur.Uw.encode |> Http.stringBody "application/x-urb-jam" - , expect = Http.expectWhatever (result (\_ -> error) (always success)) + , resolver = + Http.bytesResolver + (\resp -> + case resp of + Http.GoodStatus_ _ _ -> + Ok success + + _ -> + Ok error + ) , timeout = Nothing - , tracker = Nothing } @@ -65,6 +89,51 @@ type alias EventId = Int +scry : + { url : String + , agent : Agent + , path : Path + , error : msg + , success : D.Deconstructor (msg -> msg) msg + } + -> Cmd msg +scry args = + scryTask args |> Task.perform identity + + +scryTask : + { url : String + , agent : Agent + , path : Path + , error : msg + , success : D.Deconstructor (msg -> msg) msg + } + -> Task a msg +scryTask { url, agent, path, error, success } = + Http.riskyTask + { method = "GET" + , headers = [] + , url = url ++ "/~/scry/" ++ agent ++ "/" ++ String.join "/" path ++ ".jam" + , body = Http.emptyBody + , resolver = + Http.bytesResolver + (\resp -> + case resp of + Http.GoodStatus_ _ bytes -> + case D.runBytes success bytes of + Just msg -> + Ok msg + + Nothing -> + Ok error + + _ -> + Ok error + ) + , timeout = Nothing + } + + toNoun : EventId -> UrbitRequest -> Noun toNoun eventId req = case req of diff --git a/src/Ur/Run.elm b/src/Ur/Run.elm index a8778cb..5fbd3e5 100644 --- a/src/Ur/Run.elm +++ b/src/Ur/Run.elm @@ -3,9 +3,12 @@ module Ur.Run exposing (Model, application) import Browser exposing (Document, UrlRequest) import Browser.Navigation as Nav import Dict exposing (Dict) +import Either exposing (Either(..)) import Html import Json.Decode as JD import Task +import Ur.Cmd +import Ur.Cmd.Internal import Ur.Constructor as C import Ur.Deconstructor as D import Ur.Requests exposing (..) @@ -16,7 +19,7 @@ import Url exposing (Url) type alias SubDict msg = Dict - -- (ship, app, path) + -- (ship, agent, path) ( String, String, List String ) { deconstructor : D.Deconstructor (msg -> msg) msg , number : Int @@ -48,9 +51,9 @@ type Msg msg application : - { init : Url -> Nav.Key -> ( model, Cmd msg ) + { init : Url -> Nav.Key -> ( model, Ur.Cmd.Cmd msg ) , view : model -> Document msg - , update : msg -> model -> ( model, Cmd msg ) + , update : msg -> model -> ( model, Ur.Cmd.Cmd msg ) , subscriptions : model -> Sub msg , urbitSubscriptions : model -> Ur.Sub.Sub msg , onUrlRequest : UrlRequest -> msg @@ -71,16 +74,31 @@ application inp = let ( app, appCmds ) = init u key + + ( eventId, cmds, urReqs ) = + processCmd 0 appCmds + + url = + inp.urbitUrl app ++ "/~/channel/" ++ flags.uid in ( { subscriptions = Dict.empty , subscriptionIntMapping = Dict.empty , app = app , connected = False - , eventId = 0 + , eventId = eventId , flags = flags , requestsToRetry = [] } - , [ Cmd.map AppMsg appCmds, pureCmd NeedsActivation ] |> Cmd.batch + , [ cmds + , pureCmd NeedsActivation + , send + { requests = urReqs + , url = url + , error = Noop + , success = Noop + } + ] + |> Cmd.batch ) , view = \model -> @@ -100,7 +118,7 @@ application inp = update : { r - | update : msg -> app -> ( app, Cmd msg ) + | update : msg -> app -> ( app, Ur.Cmd.Cmd msg ) , createEventSource : String -> Cmd (Msg msg) , urbitUrl : app -> String , urbitSubscriptions : app -> Ur.Sub.Sub msg @@ -119,6 +137,9 @@ update inp msg model = ( appModel, appCmds ) = inp.update msg_ model.app + ( eventId, cmds, urReqs ) = + processCmd model.eventId appCmds + urbitSubs_ = inp.urbitSubscriptions model.app |> (\(Ur.Sub.Sub x) -> x) @@ -126,7 +147,7 @@ update inp msg model = urbitSubs_ |> Dict.map (\_ deconstructor -> { deconstructor = deconstructor }) - ( eventId, newSubscriptionActions ) = + ( eventId_, newSubscriptionActions ) = Dict.diff urbitSubs model.subscriptions |> Dict.toList |> List.map (\( address, _ ) -> ( Subscribe address, address )) @@ -135,11 +156,11 @@ update inp msg model = removedSubscriptions = Dict.diff model.subscriptions urbitSubs - ( eventId_, removedSubscriptionActions ) = + ( eventId__, removedSubscriptionActions ) = removedSubscriptions |> Dict.toList |> List.map (\( _, { number } ) -> Unsubscribe number) - |> tag eventId + |> tag eventId_ keyToNumber = newSubscriptionActions |> List.map (\( a, ( _, b ) ) -> ( b, a )) |> Dict.fromList @@ -160,7 +181,7 @@ update inp msg model = in ( { model | app = appModel - , eventId = eventId_ + , eventId = eventId__ , subscriptions = Dict.diff model.subscriptions removedSubscriptions |> Dict.union newSubscriptions @@ -174,7 +195,13 @@ update inp msg model = ) } , Cmd.batch - [ appCmds |> Cmd.map AppMsg + [ cmds + , Ur.Requests.send + { url = url + , error = Noop + , success = Noop + , requests = urReqs + } , let requests = removedSubscriptionActions @@ -226,10 +253,11 @@ update inp msg model = "fact" -> case - Dict.get messageId model.subscriptionIntMapping |> Maybe.andThen (\key -> Dict.get key model.subscriptions) + Dict.get messageId model.subscriptionIntMapping + |> Maybe.andThen (\key -> Dict.get key model.subscriptions) of Just { deconstructor } -> - case D.run (D.cell D.tar deconstructor |> D.map (\_ subMsg -> subMsg)) rest of + case D.run (D.cell D.ignore (D.cell D.ignore deconstructor)) rest of Just subMsg -> ( model_, pureCmd (AppMsg subMsg) ) @@ -277,6 +305,28 @@ update inp msg model = ( { model | connected = True }, inp.createEventSource url ) +processCmd : EventId -> Ur.Cmd.Cmd msg -> ( EventId, Cmd (Msg msg), List ( EventId, UrbitRequest ) ) +processCmd eventId urCmds = + let + ( cmds, reqs ) = + urCmds + |> List.map + (\x -> + case x of + Ur.Cmd.Internal.Cmd cmd -> + cmd |> Cmd.map AppMsg |> Left + + Ur.Cmd.Internal.Poke p -> + Ur.Requests.Poke p |> Right + ) + |> Either.partition + + ( newEventId, urReqs ) = + reqs |> tag eventId + in + ( newEventId, Cmd.batch cmds, urReqs ) + + pureCmd : msg -> Cmd msg pureCmd msg = Task.succeed msg |> Task.perform identity