mirror of
https://github.com/ilyakooo0/airlock.git
synced 2024-08-16 14:00:23 +03:00
Got basic subscriptions working
This commit is contained in:
parent
89f0999d9e
commit
6964397757
GPG Key ID:
82C257048D1026F2
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 "$@"
|
||||
9
elm.json
9
elm.json
@ -10,9 +10,16 @@
|
||||
"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",
|
||||
"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/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/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"
|
||||
},
|
||||
"test-dependencies": {
|
||||
"elm-explorations/test": "2.1.1 <= v < 3.0.0"
|
||||
|
||||
21571
example/elm.js
Normal file
21571
example/elm.js
Normal file
File diff suppressed because it is too large
Load Diff
44
example/elm.json
Normal file
44
example/elm.json
Normal file
@ -0,0 +1,44 @@
|
||||
{
|
||||
"type": "application",
|
||||
"source-directories": [
|
||||
"src",
|
||||
"../src"
|
||||
],
|
||||
"elm-version": "0.19.1",
|
||||
"dependencies": {
|
||||
"direct": {
|
||||
"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/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",
|
||||
"jxxcarlson/hex": "4.0.0",
|
||||
"ktonon/elm-word": "2.1.2",
|
||||
"mdgriffith/elm-ui": "1.1.8",
|
||||
"robinheghan/murmur3": "1.0.0"
|
||||
},
|
||||
"indirect": {
|
||||
"AdrianRibao/elm-derberos-date": "1.2.3",
|
||||
"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/virtual-dom": "1.0.3",
|
||||
"rtfeldman/elm-hex": "1.0.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 });
|
||||
}
|
||||
});
|
||||
|
||||
});
|
||||
80
example/src/Main.elm
Normal file
80
example/src/Main.elm
Normal file
@ -0,0 +1,80 @@
|
||||
port module Main exposing (main)
|
||||
|
||||
import Browser exposing (Document)
|
||||
import Element exposing (..)
|
||||
import Html exposing (Html)
|
||||
import Json.Decode as JD
|
||||
import Ur.Deconstructor as D
|
||||
import Ur
|
||||
import Ur.Run
|
||||
import Ur.Sub
|
||||
|
||||
|
||||
main =
|
||||
Ur.Run.application
|
||||
{ init =
|
||||
\_ _ ->
|
||||
( { error = ""
|
||||
}
|
||||
, Ur.logIn "http://localhost:8080" "lidlut-tabwed-pillex-ridrup"
|
||||
|> Cmd.map (result (Debug.toString >> Error) (always Noop))
|
||||
)
|
||||
, 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)
|
||||
}
|
||||
, onEventSourceMsg = onEventSourceMessage
|
||||
, onUrlChange = \_ -> Noop
|
||||
, onUrlRequest = \_ -> Noop
|
||||
, urbitUrl = \_ -> "http://localhost:8080"
|
||||
}
|
||||
|
||||
|
||||
type alias Model =
|
||||
{ error : String
|
||||
}
|
||||
|
||||
|
||||
type Msg
|
||||
= Noop
|
||||
| Error String
|
||||
|
||||
|
||||
update : Msg -> Model -> ( Model, Cmd msg )
|
||||
update msg model =
|
||||
case msg of
|
||||
Noop ->
|
||||
( model, Cmd.none )
|
||||
|
||||
Error err ->
|
||||
( { model | error = err }, Cmd.none )
|
||||
|
||||
|
||||
view : Model -> Document Msg
|
||||
view model =
|
||||
{ body =
|
||||
[ layout [] (column [ centerX, centerY ] [ el [ alignTop ] (text model.error), text "Hello" ]) ]
|
||||
, 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
|
||||
@ -1,7 +1,8 @@
|
||||
module Urbit exposing
|
||||
module Ur exposing
|
||||
( Noun(..)
|
||||
, cue
|
||||
, jam
|
||||
, logIn
|
||||
, mat
|
||||
, rub
|
||||
)
|
||||
@ -12,9 +13,26 @@ import Bitwise
|
||||
import Bytes exposing (Bytes)
|
||||
import Bytes.Extra as Bytes
|
||||
import Dict exposing (Dict)
|
||||
import Http
|
||||
import List.Extra as List
|
||||
|
||||
|
||||
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
|
||||
@ -1,4 +1,4 @@
|
||||
module Urbit.Constructor exposing
|
||||
module Ur.Constructor exposing
|
||||
( Constructor
|
||||
, cell
|
||||
, cord
|
||||
@ -14,7 +14,7 @@ module Urbit.Constructor exposing
|
||||
import Bitwise
|
||||
import Bytes exposing (Bytes, Endianness(..))
|
||||
import Bytes.Encode as BE
|
||||
import Urbit exposing (..)
|
||||
import Ur exposing (..)
|
||||
|
||||
|
||||
type alias Constructor a =
|
||||
@ -1,4 +1,4 @@
|
||||
module Urbit.Deconstructor exposing
|
||||
module Ur.Deconstructor exposing
|
||||
( Deconstructor
|
||||
, alt
|
||||
, bytes
|
||||
@ -25,7 +25,7 @@ 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
|
||||
@ -220,9 +220,9 @@ 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))
|
||||
|
||||
|
||||
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 (..)
|
||||
|
||||
import BigInt exposing (toHexString)
|
||||
import Bytes exposing (Bytes)
|
||||
import Hex.Convert as Hex
|
||||
import Urbit.Encoding.Atom exposing (toBigInt)
|
||||
import Urbit.Encoding.Phonemic exposing (..)
|
||||
|
||||
|
||||
p : String -> Maybe Bytes
|
||||
p s =
|
||||
case fromPatp s of
|
||||
Ok atom ->
|
||||
let
|
||||
hexString =
|
||||
toBigInt atom |> toHexString
|
||||
|
||||
paddedHexString =
|
||||
if modBy 2 (String.length hexString) == 0 then
|
||||
hexString
|
||||
|
||||
else
|
||||
"0" ++ hexString
|
||||
in
|
||||
Hex.toBytes paddedHexString
|
||||
|
||||
Err _ ->
|
||||
Nothing
|
||||
377
src/Ur/Run.elm
Normal file
377
src/Ur/Run.elm
Normal file
@ -0,0 +1,377 @@
|
||||
module Ur.Run exposing (Model, application)
|
||||
|
||||
import Browser exposing (Document, UrlRequest)
|
||||
import Browser.Navigation as Nav
|
||||
import Dict exposing (Dict)
|
||||
import Html
|
||||
import Http
|
||||
import Json.Decode as JD
|
||||
import Maybe.Extra
|
||||
import Task
|
||||
import Ur exposing (Noun)
|
||||
import Ur.Constructor as C
|
||||
import Ur.Deconstructor as D
|
||||
import Ur.Phonemic
|
||||
import Ur.Sub
|
||||
import Ur.Uw
|
||||
import Url exposing (Url)
|
||||
|
||||
|
||||
type alias SubDict msg =
|
||||
Dict
|
||||
-- (ship, app, 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
|
||||
, messageCounter : Int
|
||||
, flags : Flags
|
||||
, requestsToRetry : List Noun
|
||||
}
|
||||
|
||||
|
||||
type Msg msg
|
||||
= AppMsg msg
|
||||
| EventSourceMsg JD.Value
|
||||
-- | ActivateSubscription ( String, String, List String ) Int
|
||||
| FailedSubscribe Noun
|
||||
| FailedUnsubscribe Noun
|
||||
| Noop
|
||||
| OpenConnection
|
||||
| NeedsActivation
|
||||
|
||||
|
||||
type UrbitAction
|
||||
= Subscribe ( String, String, List String )
|
||||
| Unsubscribe Int
|
||||
| Poke { ship : String, agent : String, mark : String, noun : Noun }
|
||||
|
||||
|
||||
renderUrbitActions : Int -> List ( UrbitAction, a ) -> ( Int, Maybe Noun, List ( Int, a ) )
|
||||
renderUrbitActions idCounter acts =
|
||||
let
|
||||
( newIdCounter, x ) =
|
||||
renderUrbitActions_ idCounter acts
|
||||
in
|
||||
( newIdCounter
|
||||
, if List.isEmpty x then
|
||||
Nothing
|
||||
|
||||
else
|
||||
x |> List.map Tuple.first |> Maybe.Extra.values |> C.listOf identity |> Just
|
||||
, x |> List.map Tuple.second
|
||||
)
|
||||
|
||||
|
||||
renderUrbitActions_ : Int -> List ( UrbitAction, a ) -> ( Int, List ( Maybe Noun, ( Int, a ) ) )
|
||||
renderUrbitActions_ idCounter acts =
|
||||
case acts of
|
||||
[] ->
|
||||
( idCounter, [] )
|
||||
|
||||
( act, a ) :: rest ->
|
||||
renderUrbitActions_ (idCounter + 1) rest
|
||||
|> Tuple.mapSecond
|
||||
(\xs ->
|
||||
( case act of
|
||||
Subscribe ( ship, app, path ) ->
|
||||
Ur.Phonemic.p ship
|
||||
|> Maybe.map
|
||||
(\shipAtom ->
|
||||
C.cell (C.cord "subscribe") <|
|
||||
C.cell (C.int idCounter) <|
|
||||
C.cell (Ur.Atom shipAtom) <|
|
||||
C.cell (C.cord app) (C.listOf C.cord path)
|
||||
)
|
||||
|
||||
Unsubscribe subId ->
|
||||
Just <|
|
||||
C.cell (C.cord "usubscribe") <|
|
||||
C.cell (C.int idCounter) (C.int subId)
|
||||
|
||||
Poke { ship, agent, mark, noun } ->
|
||||
Ur.Phonemic.p ship
|
||||
|> Maybe.map
|
||||
(\shipAtom ->
|
||||
C.cell (C.cord "poke") <|
|
||||
C.cell (C.int idCounter) <|
|
||||
C.cell (Ur.Atom shipAtom) <|
|
||||
C.cell (C.cord agent) <|
|
||||
C.cell (C.cord mark) <|
|
||||
noun
|
||||
)
|
||||
, ( idCounter, a )
|
||||
)
|
||||
:: xs
|
||||
)
|
||||
|
||||
|
||||
application :
|
||||
{ init : Url -> Nav.Key -> ( model, Cmd msg )
|
||||
, view : model -> Document msg
|
||||
, update : msg -> model -> ( model, 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, subscriptions, onUrlRequest, onUrlChange, urbitSubscriptions, createEventSource, onEventSourceMsg, urbitUrl } =
|
||||
inp
|
||||
in
|
||||
Browser.application
|
||||
{ init =
|
||||
\flags u key ->
|
||||
let
|
||||
( app, appCmds ) =
|
||||
init u key
|
||||
|
||||
-- urbitSubs_ =
|
||||
-- urbitSubscriptions app |> (\(Ur.Sub.Sub x) -> x)
|
||||
-- urbitSubs =
|
||||
-- urbitSubs_
|
||||
-- |> Dict.map (\_ deconstructor -> { active = Nothing, deconstructor = deconstructor })
|
||||
-- ( messageCounter, actions ) =
|
||||
-- subscriptionActions Dict.empty urbitSubs |> renderUrbitActions 0
|
||||
in
|
||||
( { subscriptions = Dict.empty
|
||||
, subscriptionIntMapping = Dict.empty
|
||||
, app = app
|
||||
, connected = False
|
||||
, messageCounter = 0
|
||||
, flags = flags
|
||||
, requestsToRetry = []
|
||||
}
|
||||
, [ Cmd.map AppMsg appCmds, pureCmd NeedsActivation ] |> 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
|
||||
[ subscriptions model.app |> Sub.map AppMsg
|
||||
, onEventSourceMsg EventSourceMsg
|
||||
]
|
||||
, onUrlRequest = \req -> onUrlRequest req |> AppMsg
|
||||
, onUrlChange = \url -> onUrlChange url |> AppMsg
|
||||
}
|
||||
|
||||
|
||||
result : (a -> c) -> (b -> c) -> Result a b -> c
|
||||
result f g res =
|
||||
case res of
|
||||
Ok b ->
|
||||
g b
|
||||
|
||||
Err a ->
|
||||
f a
|
||||
|
||||
|
||||
update :
|
||||
{ r
|
||||
| update : msg -> app -> ( app, 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
|
||||
|
||||
urbitSubs_ =
|
||||
inp.urbitSubscriptions model.app |> (\(Ur.Sub.Sub x) -> x)
|
||||
|
||||
urbitSubs =
|
||||
urbitSubs_
|
||||
|> Dict.map (\_ deconstructor -> { deconstructor = deconstructor })
|
||||
|
||||
( messageCounter, newSubscriptionActions, intMapping ) =
|
||||
Dict.diff urbitSubs model.subscriptions
|
||||
|> Dict.toList
|
||||
|> List.map (\( address, _ ) -> ( Subscribe address, address ))
|
||||
|> renderUrbitActions model.messageCounter
|
||||
|
||||
removedSubscriptions =
|
||||
Dict.diff model.subscriptions urbitSubs
|
||||
|
||||
( messageCounter_, removedSubscriptionActions, _ ) =
|
||||
removedSubscriptions
|
||||
|> Dict.toList
|
||||
|> List.map (\( _, { number } ) -> ( Unsubscribe number, () ))
|
||||
|> renderUrbitActions messageCounter
|
||||
|
||||
foo =
|
||||
intMapping |> 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)
|
||||
foo
|
||||
urbitSubs
|
||||
Dict.empty
|
||||
in
|
||||
( { model
|
||||
| app = appModel
|
||||
, messageCounter = messageCounter_
|
||||
, subscriptions =
|
||||
Dict.diff model.subscriptions removedSubscriptions
|
||||
|> Dict.union newSubscriptions
|
||||
, subscriptionIntMapping =
|
||||
model.subscriptionIntMapping
|
||||
|> Dict.union
|
||||
(newSubscriptions
|
||||
|> Dict.toList
|
||||
|> List.map (\( key, { number } ) -> ( number, key ))
|
||||
|> Dict.fromList
|
||||
)
|
||||
}
|
||||
, Cmd.batch
|
||||
[ appCmds |> Cmd.map AppMsg
|
||||
, removedSubscriptionActions
|
||||
|> Maybe.map
|
||||
(\noun ->
|
||||
sendUr
|
||||
{ noun = noun
|
||||
, url = url
|
||||
, success = Noop
|
||||
, error = FailedUnsubscribe noun
|
||||
}
|
||||
)
|
||||
|> Maybe.withDefault Cmd.none
|
||||
, newSubscriptionActions
|
||||
|> Maybe.map
|
||||
(\noun ->
|
||||
sendUr
|
||||
{ noun = noun
|
||||
, url = url
|
||||
, success = Noop
|
||||
, error = FailedSubscribe noun
|
||||
}
|
||||
)
|
||||
|> Maybe.withDefault Cmd.none
|
||||
]
|
||||
)
|
||||
|
||||
EventSourceMsg value ->
|
||||
let
|
||||
model_ =
|
||||
model
|
||||
in
|
||||
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 ) |> Debug.log "event")) (Ur.Uw.decode string) of
|
||||
Just ( _, "watch-ack", _ ) ->
|
||||
-- Not sure what to do. Assume things are fine.
|
||||
( model_, Cmd.none )
|
||||
|
||||
Just ( _, "poke-ack", _ ) ->
|
||||
-- Not sure what to do.
|
||||
( model_, Cmd.none )
|
||||
|
||||
Just ( subscriptionNumber, "fact", rest ) ->
|
||||
case
|
||||
Dict.get subscriptionNumber 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
|
||||
Just subMsg ->
|
||||
( model_, pureCmd (AppMsg subMsg) )
|
||||
|
||||
-- Got gargbage
|
||||
Nothing ->
|
||||
( model_, Cmd.none )
|
||||
|
||||
-- Got a fact for a subscription we do not hold
|
||||
Nothing ->
|
||||
( model_, Cmd.none )
|
||||
|
||||
-- got something we don't expect
|
||||
_ ->
|
||||
( 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
|
||||
( newMessageCounter, nouns, _ ) =
|
||||
[ ( Poke { ship = "~zod", agent = "hood", mark = "helm-hi", noun = C.cord "Opening airlock!" }, () ) ]
|
||||
|> renderUrbitActions model.messageCounter
|
||||
in
|
||||
( { model | messageCounter = newMessageCounter }
|
||||
, nouns
|
||||
|> Maybe.map (\noun -> sendUr { url = url, noun = noun, success = OpenConnection, error = NeedsActivation })
|
||||
|> Maybe.withDefault Cmd.none
|
||||
)
|
||||
|
||||
Noop ->
|
||||
( model, Cmd.none )
|
||||
|
||||
FailedSubscribe noun ->
|
||||
( { model | requestsToRetry = noun :: model.requestsToRetry }, Cmd.none )
|
||||
|
||||
FailedUnsubscribe noun ->
|
||||
( { model | requestsToRetry = noun :: model.requestsToRetry }, Cmd.none )
|
||||
|
||||
OpenConnection ->
|
||||
( { model | connected = True }, inp.createEventSource url )
|
||||
|
||||
|
||||
pureCmd : msg -> Cmd msg
|
||||
pureCmd msg =
|
||||
Task.succeed msg |> Task.perform identity
|
||||
|
||||
|
||||
sendUr : { url : String, error : c, success : c, noun : Noun } -> Cmd c
|
||||
sendUr { url, error, success, noun } =
|
||||
Http.riskyRequest
|
||||
{ method = "PUT"
|
||||
, headers = []
|
||||
, url = url
|
||||
, body = Ur.jam noun |> Ur.Uw.encode |> Http.stringBody "application/x-urb-jam"
|
||||
, expect = Http.expectWhatever (result (\_ -> error) (always success))
|
||||
, timeout = Nothing
|
||||
, tracker = Nothing
|
||||
}
|
||||
28
src/Ur/Sub.elm
Normal file
28
src/Ur/Sub.elm
Normal file
@ -0,0 +1,28 @@
|
||||
module Ur.Sub exposing (Sub(..), batch, none, subscribe)
|
||||
|
||||
import Dict exposing (Dict)
|
||||
import Ur.Deconstructor as D
|
||||
|
||||
|
||||
type Sub msg
|
||||
= Sub
|
||||
(Dict
|
||||
-- key is (ship, app, path)
|
||||
( String, String, List String )
|
||||
(D.Deconstructor (msg -> msg) 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 |> Sub
|
||||
|
||||
|
||||
none : Sub msg
|
||||
none =
|
||||
Sub Dict.empty
|
||||
|
||||
|
||||
batch : List (Sub msg) -> Sub msg
|
||||
batch subs =
|
||||
subs |> List.map (\(Sub dict) -> dict) |> List.foldl Dict.union Dict.empty |> Sub
|
||||
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, '~' )
|
||||
]
|
||||
@ -9,9 +9,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
|
||||
@ -204,6 +205,11 @@ tests =
|
||||
)
|
||||
)
|
||||
]
|
||||
, Test.describe "Ur.Uw"
|
||||
[ Test.fuzz atom
|
||||
"encode <-> decode"
|
||||
(\bs -> bytesEq bs (bs |> Ur.Uw.encode |> Ur.Uw.decode |> stripTrailingZeros))
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
@ -234,7 +240,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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user