mirror of
https://github.com/ilyakooo0/airlock.git
synced 2024-10-05 14:27:58 +03:00
Noun channels (#4)
* Got basic subscriptions working * Refactored urbit requests * Added elm.json back in * Added int64 * Switched to bigint * Added pokes * Retry critical failed requests * Cleaned up * Expose proper modules * Refactored subscriptions * Minor refactors
This commit is contained in:
GitHub
parent
89f0999d9e
commit
f224d6c636
1
.gitignore
vendored
1
.gitignore
vendored
@ -1 +1,2 @@
|
||||
elm-stuff
|
||||
elm.js
|
||||
|
||||
7
dev/elm-live.sh
Executable file
7
dev/elm-live.sh
Executable file
@ -0,0 +1,7 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -e
|
||||
|
||||
cd "$(dirname "$0")/../example"
|
||||
|
||||
nix run nixpkgs#elmPackages.elm-live -- src/Main.elm --start-page=index.html -- --output=elm.js --debug "$@"
|
||||
18
elm.json
18
elm.json
@ -5,14 +5,26 @@
|
||||
"license": "MIT",
|
||||
"version": "1.0.0",
|
||||
"exposed-modules": [
|
||||
"Urbit"
|
||||
"Ur", "Ur.Cmd", "Ur.Sub", "Ur.Constructor", "Ur.Deconstructor", "Ur.Phonemic", "Ur.Da", "Ur.Uw", "Ur.Run"
|
||||
],
|
||||
"elm-version": "0.19.0 <= v < 0.20.0",
|
||||
"dependencies": {
|
||||
"TSFoster/elm-bytes-extra": "1.3.0 <= v < 1.4.0",
|
||||
"chelovek0v/bbase64": "1.0.1 <= v < 2.0.0",
|
||||
"cmditch/elm-bigint": "2.0.1 <= v < 3.0.0",
|
||||
"elm/browser": "1.0.2 <= v < 2.0.0",
|
||||
"elm/bytes": "1.0.8 <= v < 2.0.0",
|
||||
"elm/core": "1.0.0 <= v < 1.0.5",
|
||||
"elm-community/list-extra": "8.7.0 <= v < 9.0.0"
|
||||
"elm/core": "1.0.0 <= v < 2.0.0",
|
||||
"elm/html": "1.0.0 <= v < 2.0.0",
|
||||
"elm/http": "2.0.0 <= v < 3.0.0",
|
||||
"elm/json": "1.1.3 <= v < 2.0.0",
|
||||
"elm/time": "1.0.0 <= v < 2.0.0",
|
||||
"elm/url": "1.0.0 <= v < 2.0.0",
|
||||
"elm-community/list-extra": "8.7.0 <= v < 9.0.0",
|
||||
"elm-community/maybe-extra": "5.3.0 <= v < 6.0.0",
|
||||
"figbus/elm-urbit-api": "4.0.1 <= v < 5.0.0",
|
||||
"jxxcarlson/hex": "4.0.0 <= v < 5.0.0",
|
||||
"toastal/either": "3.6.3 <= v < 4.0.0"
|
||||
},
|
||||
"test-dependencies": {
|
||||
"elm-explorations/test": "2.1.1 <= v < 3.0.0"
|
||||
|
||||
53
example/elm.json
Normal file
53
example/elm.json
Normal file
@ -0,0 +1,53 @@
|
||||
{
|
||||
"type": "application",
|
||||
"source-directories": [
|
||||
"src",
|
||||
"../src"
|
||||
],
|
||||
"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",
|
||||
"elm/browser": "1.0.2",
|
||||
"elm/bytes": "1.0.8",
|
||||
"elm/core": "1.0.5",
|
||||
"elm/html": "1.0.0",
|
||||
"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",
|
||||
"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/svg": "1.0.1",
|
||||
"elm/virtual-dom": "1.0.3",
|
||||
"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": {
|
||||
"direct": {},
|
||||
"indirect": {}
|
||||
}
|
||||
}
|
||||
2
example/fetch-event-source.js
Normal file
2
example/fetch-event-source.js
Normal file
@ -0,0 +1,2 @@
|
||||
var m=class extends Error{};async function A(r,e,t){let n=r.getReader(),o={done:!1,value:new Uint8Array};for(;o&&!o.done;)o=await Promise.race([n.read(),new Promise((g,i)=>{setTimeout(()=>i(new Error("getBytes timed out")),t)})]),e(o.value)}function R(r){let e,t,n,o=!1;return function(i){e===void 0?(e=i,t=0,n=-1):e=L(e,i);let s=e.length,a=0;for(;t<s;){o&&(e[t]===10&&(a=++t),o=!1);let c=-1;for(;t<s&&c===-1;++t)switch(e[t]){case 58:n===-1&&(n=t-a);break;case 13:o=!0;case 10:c=t;break}if(c===-1)break;r(e.subarray(a,c),n),a=t,n=-1}a===s?e=void 0:a!==0&&(e=e.subarray(a),t-=a)}}function P(r,e,t){let n=k(),o=new TextDecoder;return function(i,s){if(i.length===0)r?.(n),n=k();else if(s>0){let a=o.decode(i.subarray(0,s)),c=s+(i[s+1]===32?2:1),p=o.decode(i.subarray(c));switch(a){case"data":n.data=n.data?n.data+`
|
||||
`+p:p;break;case"event":n.event=p;break;case"id":e?.(n.id=p);break;case"retry":let l=parseInt(p,10);isNaN(l)||t?.(n.retry=l);break}}}}function L(r,e){let t=new Uint8Array(r.length+e.length);return t.set(r),t.set(e,r.length),t}function k(){return{data:"",event:"",id:"",retry:void 0}}var b="text/event-stream",N=1e3,T="last-event-id";function q(r,{signal:e,headers:t,onopen:n,onmessage:o,onclose:g,onerror:i,openWhenHidden:s,fetch:a,responseTimeout:c,...p}){return new Promise((l,M)=>{let y={...t};y.accept||(y.accept=b);let f;function w(){f.abort(),document.hidden||E()}typeof document<"u"&&!s&&document.addEventListener("visibilitychange",w);let S=N,h;function x(){typeof document<"u"&&!s&&document.removeEventListener("visibilitychange",w),clearTimeout(h),f.abort()}e?.addEventListener("abort",()=>{x(),l()});let I=a??fetch,U=n??O,v=!1;async function E(){f=new AbortController;try{let u=await Promise.race([I(r,{...p,headers:y,signal:f.signal}),new Promise((d,C)=>{setTimeout(()=>C(new Error("fetch timed out")),c)})]);if(u.status===404)throw new m("Channel reaped");if(u.status<200||u.status>=300)throw new Error(`Invalid server response: ${u.status}`);await U(u,v),v&&(v=!1),await A(u.body,R(P(o,d=>{d?y[T]=d:delete y[T]},d=>{S=d})),c),g?.(),x(),l()}catch(u){if(!f.signal.aborted)try{v=!0;let d=i?.(u)??S;clearTimeout(h),f.abort(),h=setTimeout(E,d)}catch(d){x(),M(d)}}}E()})}function O(r){let e=r.headers.get("content-type");if(!e?.startsWith(b))throw new Error(`Expected content-type to be ${b}, Actual: ${e}`)}export{b as EventStreamContentType,q as fetchEventSource};
|
||||
13
example/index.html
Normal file
13
example/index.html
Normal file
@ -0,0 +1,13 @@
|
||||
<!DOCTYPE html>
|
||||
<html lang="en">
|
||||
<head>
|
||||
<meta charset="UTF-8" />
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1.0" />
|
||||
</head>
|
||||
<body>
|
||||
<div id="elm"></div>
|
||||
<script src="/elm.js"></script>
|
||||
<script type="module" src="/script.js"></script>
|
||||
</body>
|
||||
</html>
|
||||
|
||||
27
example/script.js
Normal file
27
example/script.js
Normal file
@ -0,0 +1,27 @@
|
||||
import { fetchEventSource } from "/fetch-event-source.js"
|
||||
|
||||
const uid = `${Math.floor(Date.now() / 1000)}-${Math.random()}`;
|
||||
|
||||
let app = Elm.Main.init({ node: document.getElementById("elm"), flags: { uid } });
|
||||
|
||||
app.ports.createEventSource.subscribe((url) => {
|
||||
fetchEventSource(url, {
|
||||
headers: {
|
||||
Accept: 'application/x-urb-jam',
|
||||
"x-channel-format": 'application/x-urb-jam',
|
||||
"content-type": 'application/x-urb-jam'
|
||||
},
|
||||
credentials: 'include',
|
||||
responseTimeout: 25000,
|
||||
openWhenHidden: true,
|
||||
onmessage(ev) {
|
||||
console.log(ev)
|
||||
app.ports.onEventSourceMessage.send({ message: ev.data });
|
||||
},
|
||||
onerror(err) {
|
||||
console.log(err)
|
||||
app.ports.onEventSourceMessage.send({ error: err });
|
||||
}
|
||||
});
|
||||
|
||||
});
|
||||
239
example/src/Main.elm
Normal file
239
example/src/Main.elm
Normal file
@ -0,0 +1,239 @@
|
||||
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 =
|
||||
Ur.Run.application
|
||||
{ init =
|
||||
\_ _ ->
|
||||
( { error = ""
|
||||
, entries = Nothing
|
||||
, newEntry = ""
|
||||
}
|
||||
, 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 =
|
||||
\{ 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
|
||||
, urbitUrl = \_ -> "http://localhost:8080"
|
||||
}
|
||||
|
||||
|
||||
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, Ur.Cmd.Cmd Msg )
|
||||
update msg model =
|
||||
case msg of
|
||||
Noop ->
|
||||
( model, Ur.Cmd.none )
|
||||
|
||||
Error err ->
|
||||
( { 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 []
|
||||
([ 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"
|
||||
}
|
||||
|
||||
|
||||
result : (a -> c) -> (b -> c) -> Result a b -> c
|
||||
result f g res =
|
||||
case res of
|
||||
Ok b ->
|
||||
g b
|
||||
|
||||
Err a ->
|
||||
f a
|
||||
|
||||
|
||||
port createEventSource : String -> Cmd msg
|
||||
|
||||
|
||||
port onEventSourceMessage : (JD.Value -> msg) -> Sub msg
|
||||
35
src/BigInt/Bytes.elm
Normal file
35
src/BigInt/Bytes.elm
Normal file
@ -0,0 +1,35 @@
|
||||
module BigInt.Bytes exposing (decode, encode)
|
||||
|
||||
import BigInt exposing (BigInt, toHexString)
|
||||
import Bytes exposing (Bytes)
|
||||
import Bytes.Extra
|
||||
import Hex.Convert as Hex
|
||||
|
||||
|
||||
encode : BigInt -> Bytes
|
||||
encode x =
|
||||
let
|
||||
hexString =
|
||||
toHexString x
|
||||
|
||||
paddedHexString =
|
||||
if modBy 2 (String.length hexString) == 0 then
|
||||
hexString
|
||||
|
||||
else
|
||||
"0" ++ hexString
|
||||
in
|
||||
Hex.toBytes paddedHexString
|
||||
|> Maybe.map (Bytes.Extra.toByteValues >> List.reverse >> Bytes.Extra.fromByteValues)
|
||||
|> Maybe.withDefault Bytes.Extra.empty
|
||||
|
||||
|
||||
decode : Bytes -> BigInt
|
||||
decode bs =
|
||||
bs
|
||||
|> Bytes.Extra.toByteValues
|
||||
|> List.reverse
|
||||
|> Bytes.Extra.fromByteValues
|
||||
|> Hex.toString
|
||||
|> BigInt.fromHexString
|
||||
|> Maybe.withDefault (BigInt.fromInt 0)
|
||||
@ -1,7 +1,12 @@
|
||||
module Urbit exposing
|
||||
( Noun(..)
|
||||
module Ur exposing
|
||||
( Agent
|
||||
, Atom
|
||||
, Mark
|
||||
, Noun(..)
|
||||
, Path
|
||||
, cue
|
||||
, jam
|
||||
, logIn
|
||||
, mat
|
||||
, rub
|
||||
)
|
||||
@ -12,12 +17,45 @@ import Bitwise
|
||||
import Bytes exposing (Bytes)
|
||||
import Bytes.Extra as Bytes
|
||||
import Dict exposing (Dict)
|
||||
import Http
|
||||
import List.Extra as List
|
||||
|
||||
|
||||
{-| An Urbit agent (app) name like `journal` or 'groups'.
|
||||
-}
|
||||
type alias Agent =
|
||||
String
|
||||
|
||||
|
||||
{-| An Urbit subscription path.
|
||||
-}
|
||||
type alias Path =
|
||||
List String
|
||||
|
||||
|
||||
type alias Mark =
|
||||
String
|
||||
|
||||
|
||||
logIn : String -> String -> Cmd (Result Http.Error ())
|
||||
logIn root password =
|
||||
Http.riskyRequest
|
||||
{ url = root ++ "/~/login"
|
||||
, method = "POST"
|
||||
, headers = []
|
||||
, timeout = Nothing
|
||||
, tracker = Nothing
|
||||
, body =
|
||||
Http.stringBody
|
||||
"application/x-www-form-urlencoded; charset=utf-8"
|
||||
("password=" ++ password)
|
||||
, expect = Http.expectWhatever identity
|
||||
}
|
||||
|
||||
|
||||
type Noun
|
||||
= Cell ( Noun, Noun )
|
||||
| Atom Bytes
|
||||
| Atom Atom
|
||||
|
||||
|
||||
type alias Atom =
|
||||
35
src/Ur/Cmd.elm
Normal file
35
src/Ur/Cmd.elm
Normal 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
9
src/Ur/Cmd/Internal.elm
Normal 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)
|
||||
@ -1,5 +1,7 @@
|
||||
module Urbit.Constructor exposing
|
||||
module Ur.Constructor exposing
|
||||
( Constructor
|
||||
, bigint
|
||||
, bytes
|
||||
, cell
|
||||
, cord
|
||||
, float32
|
||||
@ -11,10 +13,12 @@ module Urbit.Constructor exposing
|
||||
, tape
|
||||
)
|
||||
|
||||
import BigInt exposing (BigInt)
|
||||
import BigInt.Bytes
|
||||
import Bitwise
|
||||
import Bytes exposing (Bytes, Endianness(..))
|
||||
import Bytes.Encode as BE
|
||||
import Urbit exposing (..)
|
||||
import Ur exposing (..)
|
||||
|
||||
|
||||
type alias Constructor a =
|
||||
@ -42,6 +46,11 @@ int i =
|
||||
)
|
||||
|
||||
|
||||
bigint : BigInt -> Noun
|
||||
bigint x =
|
||||
Atom (BigInt.Bytes.encode x)
|
||||
|
||||
|
||||
signedInt : Int -> Noun
|
||||
signedInt i =
|
||||
int
|
||||
23
src/Ur/Da.elm
Normal file
23
src/Ur/Da.elm
Normal 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
|
||||
@ -1,12 +1,14 @@
|
||||
module Urbit.Deconstructor exposing
|
||||
module Ur.Deconstructor exposing
|
||||
( Deconstructor
|
||||
, alt
|
||||
, bigint
|
||||
, bytes
|
||||
, cell
|
||||
, const
|
||||
, cord
|
||||
, float32
|
||||
, float64
|
||||
, ignore
|
||||
, int
|
||||
, list
|
||||
, llec
|
||||
@ -20,12 +22,14 @@ module Urbit.Deconstructor exposing
|
||||
, tar
|
||||
)
|
||||
|
||||
import BigInt exposing (BigInt)
|
||||
import BigInt.Bytes
|
||||
import Bitwise
|
||||
import Bytes exposing (Bytes, Endianness(..))
|
||||
import Bytes.Decode as BD
|
||||
import Bytes.Encode as BE
|
||||
import Bytes.Extra
|
||||
import Urbit exposing (..)
|
||||
import Ur exposing (..)
|
||||
|
||||
|
||||
type Deconstructor a b
|
||||
@ -109,6 +113,19 @@ int =
|
||||
)
|
||||
|
||||
|
||||
bigint : Deconstructor (BigInt -> a) a
|
||||
bigint =
|
||||
Deconstructor
|
||||
(\x f ->
|
||||
case x of
|
||||
Atom bs ->
|
||||
BigInt.Bytes.decode bs |> f |> Just
|
||||
|
||||
Cell _ ->
|
||||
Nothing
|
||||
)
|
||||
|
||||
|
||||
signedInt : Deconstructor (Int -> a) a
|
||||
signedInt =
|
||||
int
|
||||
@ -220,9 +237,14 @@ oneOf l =
|
||||
alt x (oneOf xs)
|
||||
|
||||
|
||||
tar : Deconstructor a a
|
||||
tar : Deconstructor (Noun -> a) a
|
||||
tar =
|
||||
Deconstructor (\_ a -> Just a)
|
||||
Deconstructor (\noun f -> Just (f noun))
|
||||
|
||||
|
||||
ignore : Deconstructor a a
|
||||
ignore =
|
||||
Deconstructor (\_ f -> Just f)
|
||||
|
||||
|
||||
llec : Deconstructor a b -> Deconstructor b c -> Deconstructor a c
|
||||
28
src/Ur/Phonemic.elm
Normal file
28
src/Ur/Phonemic.elm
Normal file
@ -0,0 +1,28 @@
|
||||
module Ur.Phonemic exposing (Ship, fromString)
|
||||
|
||||
import BigInt.Bytes
|
||||
import Bytes.Extra
|
||||
import Ur exposing (Atom, Noun(..))
|
||||
import Urbit.Encoding.Atom exposing (toBigInt)
|
||||
import Urbit.Encoding.Phonemic exposing (..)
|
||||
|
||||
|
||||
{-| A ship name like `~zod` or `~racfer-hattes`.
|
||||
|
||||
Also know as `@p`.
|
||||
|
||||
-}
|
||||
type alias Ship =
|
||||
String
|
||||
|
||||
|
||||
{-| Converts a string like '~zod' into an Atom.
|
||||
-}
|
||||
fromString : Ship -> Atom
|
||||
fromString s =
|
||||
case fromPatp s of
|
||||
Ok atom ->
|
||||
toBigInt atom |> BigInt.Bytes.encode
|
||||
|
||||
Err _ ->
|
||||
Bytes.Extra.empty
|
||||
164
src/Ur/Requests.elm
Normal file
164
src/Ur/Requests.elm
Normal file
@ -0,0 +1,164 @@
|
||||
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
|
||||
|
||||
|
||||
type UrbitRequest
|
||||
= Subscribe ( Ship, Agent, Path )
|
||||
| Unsubscribe EventId
|
||||
| Poke { ship : Ship, agent : Agent, mark : Mark, noun : Noun }
|
||||
| Ack Int
|
||||
|
||||
|
||||
tag : EventId -> List x -> ( EventId, List ( EventId, x ) )
|
||||
tag eventId reqs =
|
||||
case reqs of
|
||||
[] ->
|
||||
( eventId, [] )
|
||||
|
||||
req :: rest ->
|
||||
tag (eventId + 1) rest |> Tuple.mapSecond (\xs -> ( eventId, req ) :: xs)
|
||||
|
||||
|
||||
send :
|
||||
{ url : String
|
||||
, error : msg
|
||||
, success : msg
|
||||
, requests : List ( EventId, UrbitRequest )
|
||||
}
|
||||
-> Cmd msg
|
||||
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
|
||||
Task.succeed success
|
||||
|
||||
else
|
||||
Http.riskyTask
|
||||
{ method = "PUT"
|
||||
, headers = []
|
||||
, url = url
|
||||
, body =
|
||||
requests
|
||||
|> List.map (uncurry toNoun)
|
||||
|> C.listOf identity
|
||||
|> Ur.jam
|
||||
|> Ur.Uw.encode
|
||||
|> Http.stringBody "application/x-urb-jam"
|
||||
, resolver =
|
||||
Http.bytesResolver
|
||||
(\resp ->
|
||||
case resp of
|
||||
Http.GoodStatus_ _ _ ->
|
||||
Ok success
|
||||
|
||||
_ ->
|
||||
Ok error
|
||||
)
|
||||
, timeout = Nothing
|
||||
}
|
||||
|
||||
|
||||
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
|
||||
Subscribe ( ship, app, path ) ->
|
||||
C.cell (C.cord "subscribe") <|
|
||||
C.cell (C.int eventId) <|
|
||||
C.cell (Ur.Atom (Ur.Phonemic.fromString ship)) <|
|
||||
C.cell (C.cord app) (C.listOf C.cord path)
|
||||
|
||||
Unsubscribe subId ->
|
||||
C.cell (C.cord "usubscribe") <|
|
||||
C.cell (C.int eventId) (C.int subId)
|
||||
|
||||
Poke { ship, agent, mark, noun } ->
|
||||
C.cell (C.cord "poke") <|
|
||||
C.cell (C.int eventId) <|
|
||||
C.cell (Ur.Atom (Ur.Phonemic.fromString ship)) <|
|
||||
C.cell (C.cord agent) <|
|
||||
C.cell (C.cord mark) <|
|
||||
noun
|
||||
|
||||
Ack number ->
|
||||
C.cell (C.cord "ack") (C.int number)
|
||||
|
||||
|
||||
uncurry : (a -> b -> c) -> (( a, b ) -> c)
|
||||
uncurry f ( a, b ) =
|
||||
f a b
|
||||
375
src/Ur/Run.elm
Normal file
375
src/Ur/Run.elm
Normal file
@ -0,0 +1,375 @@
|
||||
module Ur.Run exposing (Model, Msg, 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 Time
|
||||
import Ur exposing (Agent, Path)
|
||||
import Ur.Cmd
|
||||
import Ur.Cmd.Internal
|
||||
import Ur.Constructor as C
|
||||
import Ur.Deconstructor as D
|
||||
import Ur.Phonemic exposing (Ship)
|
||||
import Ur.Requests exposing (..)
|
||||
import Ur.Sub
|
||||
import Ur.Sub.Internal
|
||||
import Ur.Uw
|
||||
import Url exposing (Url)
|
||||
|
||||
|
||||
type alias SubDict msg =
|
||||
Dict
|
||||
-- (ship, agent, path)
|
||||
( String, String, List String )
|
||||
{ deconstructor : D.Deconstructor (msg -> msg) msg
|
||||
, number : Int
|
||||
}
|
||||
|
||||
|
||||
type alias Flags =
|
||||
{ uid : String }
|
||||
|
||||
|
||||
type alias Model app msg =
|
||||
{ subscriptions : SubDict msg
|
||||
, subscriptionIntMapping : Dict Int ( String, String, List String )
|
||||
, app : app
|
||||
, connected : Bool
|
||||
, eventId : Int
|
||||
, flags : Flags
|
||||
, requestsToRetry : List UrbitRequest
|
||||
}
|
||||
|
||||
|
||||
type Msg msg
|
||||
= AppMsg msg
|
||||
| EventSourceMsg JD.Value
|
||||
| FailedRequest (List UrbitRequest)
|
||||
| Noop
|
||||
| OpenConnection
|
||||
| NeedsActivation
|
||||
| RetryRequests
|
||||
|
||||
|
||||
application :
|
||||
{ init : Url -> Nav.Key -> ( model, Ur.Cmd.Cmd msg )
|
||||
, view : model -> Document msg
|
||||
, update : msg -> model -> ( model, Ur.Cmd.Cmd msg )
|
||||
, subscriptions : model -> Sub msg
|
||||
, urbitSubscriptions : model -> Ur.Sub.Sub msg
|
||||
, onUrlRequest : UrlRequest -> msg
|
||||
, onUrlChange : Url -> msg
|
||||
, createEventSource : String -> Cmd (Msg msg)
|
||||
, onEventSourceMsg : (JD.Value -> Msg msg) -> Sub (Msg msg)
|
||||
, urbitUrl : model -> String
|
||||
}
|
||||
-> Program Flags (Model model msg) (Msg msg)
|
||||
application inp =
|
||||
let
|
||||
{ init, view, onUrlRequest, onUrlChange, onEventSourceMsg } =
|
||||
inp
|
||||
in
|
||||
Browser.application
|
||||
{ init =
|
||||
\flags u key ->
|
||||
let
|
||||
( app, appCmds ) =
|
||||
init u key
|
||||
|
||||
{ subscriptions, eventId, subscriptionRequests, subscriptionIntMapping } =
|
||||
processUrSubs
|
||||
0
|
||||
Dict.empty
|
||||
(inp.urbitSubscriptions app |> (\(Ur.Sub.Internal.Sub x) -> x))
|
||||
|
||||
( eventId_, cmds, urReqs ) =
|
||||
processCmd eventId appCmds
|
||||
|
||||
url =
|
||||
inp.urbitUrl app ++ "/~/channel/" ++ flags.uid
|
||||
in
|
||||
( { subscriptions = subscriptions
|
||||
, subscriptionIntMapping = subscriptionIntMapping
|
||||
, app = app
|
||||
, connected = False
|
||||
, eventId = eventId_
|
||||
, flags = flags
|
||||
, requestsToRetry = []
|
||||
}
|
||||
, [ cmds
|
||||
, pureCmd NeedsActivation
|
||||
, send
|
||||
{ requests = urReqs ++ subscriptionRequests
|
||||
, url = url
|
||||
, error = Noop
|
||||
, success = Noop
|
||||
}
|
||||
]
|
||||
|> Cmd.batch
|
||||
)
|
||||
, view =
|
||||
\model ->
|
||||
view model.app
|
||||
|> (\{ body, title } -> { title = title, body = body |> List.map (Html.map AppMsg) })
|
||||
, update = update inp
|
||||
, subscriptions =
|
||||
\model ->
|
||||
Sub.batch
|
||||
[ inp.subscriptions model.app |> Sub.map AppMsg
|
||||
, onEventSourceMsg EventSourceMsg
|
||||
, if List.isEmpty model.requestsToRetry then
|
||||
Sub.none
|
||||
|
||||
else
|
||||
Time.every 1000 (always RetryRequests)
|
||||
]
|
||||
, onUrlRequest = \req -> onUrlRequest req |> AppMsg
|
||||
, onUrlChange = \url -> onUrlChange url |> AppMsg
|
||||
}
|
||||
|
||||
|
||||
update :
|
||||
{ r
|
||||
| update : msg -> app -> ( app, Ur.Cmd.Cmd msg )
|
||||
, createEventSource : String -> Cmd (Msg msg)
|
||||
, urbitUrl : app -> String
|
||||
, urbitSubscriptions : app -> Ur.Sub.Sub msg
|
||||
}
|
||||
-> Msg msg
|
||||
-> Model app msg
|
||||
-> ( Model app msg, Cmd (Msg msg) )
|
||||
update inp msg model =
|
||||
let
|
||||
url =
|
||||
inp.urbitUrl model.app ++ "/~/channel/" ++ model.flags.uid
|
||||
in
|
||||
case msg of
|
||||
AppMsg msg_ ->
|
||||
let
|
||||
( appModel, appCmds ) =
|
||||
inp.update msg_ model.app
|
||||
|
||||
{ subscriptions, eventId, subscriptionRequests, subscriptionIntMapping } =
|
||||
processUrSubs
|
||||
model.eventId
|
||||
model.subscriptions
|
||||
(inp.urbitSubscriptions model.app |> (\(Ur.Sub.Internal.Sub x) -> x))
|
||||
|
||||
( eventId_, cmds, urReqs ) =
|
||||
processCmd eventId appCmds
|
||||
in
|
||||
( { model
|
||||
| app = appModel
|
||||
, eventId = eventId_
|
||||
, subscriptions = subscriptions
|
||||
, subscriptionIntMapping = model.subscriptionIntMapping |> Dict.union subscriptionIntMapping
|
||||
}
|
||||
, Cmd.batch
|
||||
[ cmds
|
||||
, Ur.Requests.send
|
||||
{ url = url
|
||||
, error = Noop
|
||||
, success = Noop
|
||||
, requests = urReqs
|
||||
}
|
||||
, send
|
||||
{ requests = subscriptionRequests
|
||||
, url = url
|
||||
, error = subscriptionRequests |> List.map (\( _, x ) -> x) |> FailedRequest
|
||||
, success = Noop
|
||||
}
|
||||
]
|
||||
)
|
||||
|
||||
EventSourceMsg value ->
|
||||
case JD.decodeValue (JD.field "message" JD.string) value of
|
||||
Ok string ->
|
||||
case
|
||||
D.runBytes
|
||||
(D.cell D.int (D.cell D.cord D.tar)
|
||||
|> D.map (\a b c -> ( a, b, c ))
|
||||
)
|
||||
(Ur.Uw.decode string)
|
||||
of
|
||||
Just ( messageId, messageType, rest ) ->
|
||||
let
|
||||
( eventId, ackReqs ) =
|
||||
tag model.eventId [ Ack messageId ]
|
||||
|
||||
ackCmd =
|
||||
send
|
||||
{ requests = ackReqs
|
||||
, url = url
|
||||
, success = Noop
|
||||
, error = ackReqs |> List.map (\( _, x ) -> x) |> FailedRequest
|
||||
}
|
||||
|
||||
model_ =
|
||||
{ model | eventId = eventId }
|
||||
in
|
||||
case messageType of
|
||||
"watch-ack" ->
|
||||
-- Not sure what to do. Assume things are fine.
|
||||
( model_, ackCmd )
|
||||
|
||||
"poke-ack" ->
|
||||
-- Not sure what to do.
|
||||
( model_, ackCmd )
|
||||
|
||||
"fact" ->
|
||||
case
|
||||
Dict.get messageId model.subscriptionIntMapping
|
||||
|> Maybe.andThen (\key -> Dict.get key model.subscriptions)
|
||||
of
|
||||
Just { deconstructor } ->
|
||||
case D.run (D.cell D.ignore (D.cell D.ignore deconstructor)) rest of
|
||||
Just subMsg ->
|
||||
( model_, pureCmd (AppMsg subMsg) )
|
||||
|
||||
-- Got gargbage
|
||||
Nothing ->
|
||||
( model_, ackCmd )
|
||||
|
||||
-- Got a fact for a subscription we do not hold
|
||||
Nothing ->
|
||||
( model_, ackCmd )
|
||||
|
||||
_ ->
|
||||
( model_, ackCmd )
|
||||
|
||||
-- got something we don't expect
|
||||
Nothing ->
|
||||
( model, Cmd.none )
|
||||
|
||||
Err _ ->
|
||||
case JD.decodeValue (JD.field "error" JD.value) value of
|
||||
Ok _ ->
|
||||
( { model | connected = False }, Cmd.none )
|
||||
|
||||
Err _ ->
|
||||
-- we got garbage
|
||||
( model, Cmd.none )
|
||||
|
||||
NeedsActivation ->
|
||||
let
|
||||
( eventId, reqs ) =
|
||||
[ Poke { ship = "~zod", agent = "hood", mark = "helm-hi", noun = C.cord "Opening airlock!" } ]
|
||||
|> tag model.eventId
|
||||
in
|
||||
( { model | eventId = eventId }
|
||||
, send { url = url, requests = reqs, success = OpenConnection, error = NeedsActivation }
|
||||
)
|
||||
|
||||
Noop ->
|
||||
( model, Cmd.none )
|
||||
|
||||
FailedRequest reqs ->
|
||||
( { model | requestsToRetry = reqs ++ model.requestsToRetry }, Cmd.none )
|
||||
|
||||
OpenConnection ->
|
||||
( { model | connected = True }, inp.createEventSource url )
|
||||
|
||||
RetryRequests ->
|
||||
let
|
||||
( eventId, reqs ) =
|
||||
model.requestsToRetry |> tag model.eventId
|
||||
in
|
||||
( { model | eventId = eventId, requestsToRetry = [] }
|
||||
, send
|
||||
{ url = url
|
||||
, error = FailedRequest model.requestsToRetry
|
||||
, success = Noop
|
||||
, requests = reqs
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
processUrSubs :
|
||||
EventId
|
||||
-> Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId }
|
||||
-> Dict ( Ship, Agent, Path ) d
|
||||
->
|
||||
{ subscriptions : Dict ( Ship, Agent, Path ) { deconstructor : d, number : EventId }
|
||||
, eventId : EventId
|
||||
, subscriptionRequests : List ( EventId, UrbitRequest )
|
||||
, subscriptionIntMapping : Dict EventId ( Ship, Agent, Path )
|
||||
}
|
||||
processUrSubs eventId existingSubscriptions urbitSubs_ =
|
||||
let
|
||||
urbitSubs =
|
||||
urbitSubs_
|
||||
|> Dict.map (\_ deconstructor -> { deconstructor = deconstructor })
|
||||
|
||||
( eventId_, newSubscriptionActions ) =
|
||||
Dict.diff urbitSubs existingSubscriptions
|
||||
|> Dict.toList
|
||||
|> List.map (\( address, _ ) -> ( Subscribe address, address ))
|
||||
|> tag eventId
|
||||
|
||||
removedSubscriptions =
|
||||
Dict.diff existingSubscriptions urbitSubs
|
||||
|
||||
( eventId__, removedSubscriptionActions ) =
|
||||
removedSubscriptions
|
||||
|> Dict.toList
|
||||
|> List.map (\( _, { number } ) -> Unsubscribe number)
|
||||
|> tag eventId_
|
||||
|
||||
keyToNumber =
|
||||
newSubscriptionActions |> List.map (\( a, ( _, b ) ) -> ( b, a )) |> Dict.fromList
|
||||
|
||||
newSubscriptions =
|
||||
Dict.merge
|
||||
(\_ _ x -> x)
|
||||
(\key number { deconstructor } ->
|
||||
Dict.insert key
|
||||
{ deconstructor = deconstructor
|
||||
, number = number
|
||||
}
|
||||
)
|
||||
(\_ _ x -> x)
|
||||
keyToNumber
|
||||
urbitSubs
|
||||
Dict.empty
|
||||
in
|
||||
{ subscriptions = Dict.diff existingSubscriptions removedSubscriptions |> Dict.union newSubscriptions
|
||||
, subscriptionIntMapping =
|
||||
newSubscriptions
|
||||
|> Dict.toList
|
||||
|> List.map (\( key, { number } ) -> ( number, key ))
|
||||
|> Dict.fromList
|
||||
, eventId = eventId__
|
||||
, subscriptionRequests =
|
||||
removedSubscriptionActions ++ (newSubscriptionActions |> List.map (\( id, ( req, _ ) ) -> ( id, req )))
|
||||
}
|
||||
24
src/Ur/Sub.elm
Normal file
24
src/Ur/Sub.elm
Normal file
@ -0,0 +1,24 @@
|
||||
module Ur.Sub exposing (Sub, batch, none, subscribe)
|
||||
|
||||
import Dict
|
||||
import Ur.Deconstructor as D
|
||||
import Ur.Sub.Internal
|
||||
|
||||
|
||||
type alias Sub msg =
|
||||
Ur.Sub.Internal.Sub msg
|
||||
|
||||
|
||||
subscribe : { ship : String, app : String, path : List String, deconstructor : D.Deconstructor (msg -> msg) msg } -> Sub msg
|
||||
subscribe { ship, app, path, deconstructor } =
|
||||
Dict.singleton ( ship, app, path ) deconstructor |> Ur.Sub.Internal.Sub
|
||||
|
||||
|
||||
none : Sub msg
|
||||
none =
|
||||
Ur.Sub.Internal.Sub Dict.empty
|
||||
|
||||
|
||||
batch : List (Sub msg) -> Sub msg
|
||||
batch subs =
|
||||
subs |> List.map (\(Ur.Sub.Internal.Sub dict) -> dict) |> List.foldl Dict.union Dict.empty |> Ur.Sub.Internal.Sub
|
||||
15
src/Ur/Sub/Internal.elm
Normal file
15
src/Ur/Sub/Internal.elm
Normal file
@ -0,0 +1,15 @@
|
||||
module Ur.Sub.Internal exposing (Sub(..))
|
||||
|
||||
import Dict exposing (Dict)
|
||||
import Ur exposing (Agent, Path)
|
||||
import Ur.Deconstructor as D
|
||||
import Ur.Phonemic exposing (Ship)
|
||||
|
||||
|
||||
type Sub msg
|
||||
= Sub
|
||||
(Dict
|
||||
-- key is (ship, app, path)
|
||||
( Ship, Agent, Path )
|
||||
(D.Deconstructor (msg -> msg) msg)
|
||||
)
|
||||
196
src/Ur/Uw.elm
Normal file
196
src/Ur/Uw.elm
Normal file
@ -0,0 +1,196 @@
|
||||
module Ur.Uw exposing (decode, encode)
|
||||
|
||||
import BitParser as BP
|
||||
import BitWriter as BW
|
||||
import Bitwise
|
||||
import Bytes exposing (Bytes)
|
||||
import Bytes.Extra
|
||||
import Dict
|
||||
import List.Extra
|
||||
|
||||
|
||||
decode : String -> Bytes
|
||||
decode string =
|
||||
if string == "0w0" then
|
||||
Bytes.Extra.empty
|
||||
|
||||
else
|
||||
let
|
||||
chars =
|
||||
string
|
||||
|> String.toList
|
||||
-- 0w
|
||||
|> List.drop 2
|
||||
|
||||
go : List Char -> BW.BitWriter -> BW.BitWriter
|
||||
go cs writer =
|
||||
case cs of
|
||||
[] ->
|
||||
writer
|
||||
|
||||
'.' :: rest ->
|
||||
go rest writer
|
||||
|
||||
c :: rest ->
|
||||
case Dict.get c charToBits of
|
||||
Just bits ->
|
||||
go rest writer |> BW.bits bits
|
||||
|
||||
Nothing ->
|
||||
go rest writer
|
||||
in
|
||||
BW.run (go chars BW.empty)
|
||||
|
||||
|
||||
encode : Bytes -> String
|
||||
encode bytes =
|
||||
let
|
||||
w =
|
||||
Bytes.width bytes * 8
|
||||
|
||||
go () =
|
||||
take w 6
|
||||
|> BP.andThen
|
||||
(\bits ->
|
||||
if List.isEmpty bits then
|
||||
BP.succeed []
|
||||
|
||||
else
|
||||
case Dict.get (BP.bitsToInt bits) intToChar of
|
||||
Nothing ->
|
||||
BP.fail
|
||||
|
||||
Just char ->
|
||||
go () |> BP.map (\chars -> char :: chars)
|
||||
)
|
||||
|
||||
encoded =
|
||||
BP.run (go ()) bytes
|
||||
|> Maybe.withDefault []
|
||||
|> List.Extra.dropWhileRight (\x -> x == '0')
|
||||
|> dot
|
||||
|> List.reverse
|
||||
in
|
||||
if List.isEmpty encoded then
|
||||
"0w0"
|
||||
|
||||
else
|
||||
String.fromList ('0' :: 'w' :: encoded)
|
||||
|
||||
|
||||
dot : List Char -> List Char
|
||||
dot chars =
|
||||
if List.isEmpty chars then
|
||||
[]
|
||||
|
||||
else if List.length chars <= 5 then
|
||||
chars
|
||||
|
||||
else
|
||||
List.take 5 chars ++ ('.' :: dot (List.drop 5 chars))
|
||||
|
||||
|
||||
take : Int -> Int -> BP.BitParser (List Int)
|
||||
take width n =
|
||||
if n <= 0 then
|
||||
BP.succeed []
|
||||
|
||||
else
|
||||
BP.getOffset
|
||||
|> BP.andThen
|
||||
(\offset ->
|
||||
if offset >= width then
|
||||
BP.succeed []
|
||||
|
||||
else
|
||||
BP.bit
|
||||
|> BP.andThen
|
||||
(\bit -> take width (n - 1) |> BP.map (\bits -> bit :: bits))
|
||||
)
|
||||
|
||||
|
||||
intToChar : Dict.Dict Int Char
|
||||
intToChar =
|
||||
Dict.fromList mapping
|
||||
|
||||
|
||||
charToBits : Dict.Dict Char (List Int)
|
||||
charToBits =
|
||||
let
|
||||
intToBits bitsLeft n =
|
||||
if bitsLeft > 0 then
|
||||
Bitwise.and 1 n :: intToBits (bitsLeft - 1) (Bitwise.shiftRightBy 1 n)
|
||||
|
||||
else
|
||||
[]
|
||||
in
|
||||
mapping |> List.map (\( x, y ) -> ( y, intToBits 6 x )) |> Dict.fromList
|
||||
|
||||
|
||||
mapping : List ( number, Char )
|
||||
mapping =
|
||||
[ ( 0, '0' )
|
||||
, ( 1, '1' )
|
||||
, ( 2, '2' )
|
||||
, ( 3, '3' )
|
||||
, ( 4, '4' )
|
||||
, ( 5, '5' )
|
||||
, ( 6, '6' )
|
||||
, ( 7, '7' )
|
||||
, ( 8, '8' )
|
||||
, ( 9, '9' )
|
||||
, ( 10, 'a' )
|
||||
, ( 11, 'b' )
|
||||
, ( 12, 'c' )
|
||||
, ( 13, 'd' )
|
||||
, ( 14, 'e' )
|
||||
, ( 15, 'f' )
|
||||
, ( 16, 'g' )
|
||||
, ( 17, 'h' )
|
||||
, ( 18, 'i' )
|
||||
, ( 19, 'j' )
|
||||
, ( 20, 'k' )
|
||||
, ( 21, 'l' )
|
||||
, ( 22, 'm' )
|
||||
, ( 23, 'n' )
|
||||
, ( 24, 'o' )
|
||||
, ( 25, 'p' )
|
||||
, ( 26, 'q' )
|
||||
, ( 27, 'r' )
|
||||
, ( 28, 's' )
|
||||
, ( 29, 't' )
|
||||
, ( 30, 'u' )
|
||||
, ( 31, 'v' )
|
||||
, ( 32, 'w' )
|
||||
, ( 33, 'x' )
|
||||
, ( 34, 'y' )
|
||||
, ( 35, 'z' )
|
||||
, ( 36, 'A' )
|
||||
, ( 37, 'B' )
|
||||
, ( 38, 'C' )
|
||||
, ( 39, 'D' )
|
||||
, ( 40, 'E' )
|
||||
, ( 41, 'F' )
|
||||
, ( 42, 'G' )
|
||||
, ( 43, 'H' )
|
||||
, ( 44, 'I' )
|
||||
, ( 45, 'J' )
|
||||
, ( 46, 'K' )
|
||||
, ( 47, 'L' )
|
||||
, ( 48, 'M' )
|
||||
, ( 49, 'N' )
|
||||
, ( 50, 'O' )
|
||||
, ( 51, 'P' )
|
||||
, ( 52, 'Q' )
|
||||
, ( 53, 'R' )
|
||||
, ( 54, 'S' )
|
||||
, ( 55, 'T' )
|
||||
, ( 56, 'U' )
|
||||
, ( 57, 'V' )
|
||||
, ( 58, 'W' )
|
||||
, ( 59, 'X' )
|
||||
, ( 60, 'Y' )
|
||||
, ( 61, 'Z' )
|
||||
, ( 62, '-' )
|
||||
, ( 63, '~' )
|
||||
]
|
||||
@ -1,5 +1,7 @@
|
||||
module Test.Urbit exposing (tests)
|
||||
|
||||
import BigInt exposing (BigInt)
|
||||
import BigInt.Bytes
|
||||
import BitParser
|
||||
import BitWriter
|
||||
import Bytes exposing (Bytes)
|
||||
@ -9,9 +11,10 @@ import Fuzz exposing (Fuzzer)
|
||||
import List.Extra as List
|
||||
import Test exposing (..)
|
||||
import Test.Utils exposing (..)
|
||||
import Urbit exposing (..)
|
||||
import Urbit.Constructor as C
|
||||
import Urbit.Deconstructor as D
|
||||
import Ur exposing (..)
|
||||
import Ur.Constructor as C
|
||||
import Ur.Deconstructor as D
|
||||
import Ur.Uw
|
||||
|
||||
|
||||
tests : Test
|
||||
@ -76,6 +79,16 @@ tests =
|
||||
(Bytes.fromByteValues [ 0x31, 0x12 ])
|
||||
)
|
||||
)
|
||||
, test "1.686.761.906.334"
|
||||
(\() ->
|
||||
Expect.equal
|
||||
(Just "1686761906334")
|
||||
(D.runBytes
|
||||
D.bigint
|
||||
(Bytes.fromByteValues [ 0x80, 0xC9, 0x13, 0x04, 0x5B, 0x17, 0x31 ])
|
||||
|> Maybe.map BigInt.toString
|
||||
)
|
||||
)
|
||||
, test "[4 ~[1 2 3]]"
|
||||
(\() ->
|
||||
Expect.equal
|
||||
@ -149,7 +162,7 @@ tests =
|
||||
(Bytes.fromByteValues [ 0xC1, 0x20, 0xE4, 0x01 ])
|
||||
)
|
||||
)
|
||||
, test "65.600"
|
||||
, test "Int 65.600"
|
||||
(\() ->
|
||||
Expect.equal
|
||||
(Just 65600)
|
||||
@ -158,6 +171,15 @@ tests =
|
||||
(Bytes.fromByteValues [ 0xC0, 0x00, 0x02, 0x08 ])
|
||||
)
|
||||
)
|
||||
, test "BigInt 65.600"
|
||||
(\() ->
|
||||
Expect.equal
|
||||
(Just (BigInt.fromInt 65600))
|
||||
(D.runBytes
|
||||
D.bigint
|
||||
(Bytes.fromByteValues [ 0xC0, 0x00, 0x02, 0x08 ])
|
||||
)
|
||||
)
|
||||
]
|
||||
, describe "Constructor <-> Deconstructor"
|
||||
[ Test.fuzz
|
||||
@ -203,6 +225,12 @@ tests =
|
||||
(C.tape x)
|
||||
)
|
||||
)
|
||||
, Test.fuzz bigint "bigint" (\x -> Expect.equal (Just x) (D.run D.bigint (C.bigint x)))
|
||||
]
|
||||
, Test.describe "Ur.Uw"
|
||||
[ Test.fuzz atom
|
||||
"encode <-> decode"
|
||||
(\bs -> bytesEq bs (bs |> Ur.Uw.encode |> Ur.Uw.decode |> stripTrailingZeros))
|
||||
]
|
||||
]
|
||||
|
||||
@ -234,7 +262,12 @@ atom : Fuzzer Bytes
|
||||
atom =
|
||||
bytes
|
||||
|> Fuzz.map
|
||||
(\a -> a |> Bytes.toByteValues |> List.dropWhileRight (\x -> x == 0) |> Bytes.fromByteValues)
|
||||
stripTrailingZeros
|
||||
|
||||
|
||||
stripTrailingZeros : Bytes -> Bytes
|
||||
stripTrailingZeros =
|
||||
Bytes.toByteValues >> List.dropWhileRight (\x -> x == 0) >> Bytes.fromByteValues
|
||||
|
||||
|
||||
noun : () -> Fuzzer Noun
|
||||
@ -243,3 +276,8 @@ noun () =
|
||||
[ ( 0.6, atom |> Fuzz.map Atom )
|
||||
, ( 0.4, Fuzz.map2 (\a b -> Cell ( a, b )) (Fuzz.lazy noun) (Fuzz.lazy noun) )
|
||||
]
|
||||
|
||||
|
||||
bigint : Fuzzer BigInt
|
||||
bigint =
|
||||
bytes |> Fuzz.map BigInt.Bytes.decode
|
||||
|
||||
Loading…
Reference in New Issue
Block a user