ilyakooo0/airlock
1
0
Fork 0
mirror of https://github.com/ilyakooo0/airlock.git synced 2024-08-16 14:00:23 +03:00
Code Issues Packages Projects Releases Wiki Activity

Added pokes

Browse Source
This commit is contained in:
iko 2023-06-16 16:11:42 +03:00
parent 4988fc5c0e
commit 5590712d02
Signed by untrusted user: iko
GPG Key ID: 82C257048D1026F2
7 changed files with 389 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
example/elm.json
View File

@ -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": {

184
example/src/Main.elm
View File

@ -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"
}

35
src/Ur/Cmd.elm Normal file
View File

@ -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

9
src/Ur/Cmd/Internal.elm Normal file
View File

@ -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)

23
src/Ur/Da.elm Normal file
View File

@ -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

83
src/Ur/Requests.elm
View File

@ -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

76
src/Ur/Run.elm
View File

@ -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