objective categorical abstract machine language personal data server
Set up React for frontend
+812
-204
+1
-1
dune
+1
-1
dune
···
6
6
%{workspace_root}/tools/tailwindcss/tailwindcss
7
7
(:input %{workspace_root}/public/main.css)
8
8
(source_tree %{workspace_root}/public)
9
-
(source_tree %{workspace_root}/pegasus/lib/templates))
9
+
(source_tree %{workspace_root}/frontend))
10
10
(action
11
11
(chdir
12
12
%{workspace_root}
+26
-3
dune-project
+26
-3
dune-project
···
1
1
(lang dune 3.20)
2
+
(using melange 0.1)
2
3
3
4
(name pegasus)
4
5
···
30
31
(url "git+https://github.com/roddyyaga/ppx_rapper.git")
31
32
(package (name ppx_rapper_lwt)))
32
33
34
+
(pin ; version on opam is outdated
35
+
(url "git+https://github.com/melange-community/melange-fetch.git")
36
+
(package (name melange-fetch)))
37
+
(pin ; version on opam is outdated
38
+
(url "git+https://github.com/melange-community/melange-webapi.git")
39
+
(package (name melange-webapi)))
40
+
(pin ; version on opam is outdated
41
+
(url "git+https://github.com/ml-in-barcelona/server-reason-react.git")
42
+
(package (name server-reason-react)))
33
43
34
44
(package
35
45
(name pegasus)
···
47
57
(cohttp-lwt-unix (>= 6.1.1))
48
58
(dns-client (>= 10.2.0))
49
59
dream
50
-
html_of_jsx
51
-
mlx
52
60
(re (>= 1.13.2))
53
61
(safepass (>= 3.1))
62
+
server-reason-react
54
63
(timedesc (>= 3.1.0))
55
64
(uri (>= 4.4.0))
56
65
(uuidm (>= 0.9.10))
···
64
73
(ocamlmerlin-mlx :with-dev-setup)))
65
74
66
75
(package
76
+
(name frontend)
77
+
(allow_empty)
78
+
(depends
79
+
(ocaml (= 5.2.1))
80
+
dune
81
+
lwt
82
+
melange
83
+
mlx
84
+
(reason-react (>= 0.16.0))
85
+
(reason-react-ppx (>= 0.16.0))
86
+
server-reason-react))
87
+
88
+
(package
67
89
(name mist)
68
90
(synopsis "Atproto repo functionality")
69
91
(allow_empty)
···
105
127
(multibase (>= 0.1.0))))
106
128
107
129
(package
108
-
(name tailwindcss) (allow_empty))
130
+
(name tailwindcss)
131
+
(allow_empty))
109
132
110
133
(dialect
111
134
(name mlx)
+34
frontend.opam
+34
frontend.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
maintainer: ["futurGH"]
4
+
authors: ["futurGH"]
5
+
license: "MPL-2.0"
6
+
homepage: "https://github.com/futurGH/pegasus"
7
+
bug-reports: "https://github.com/futurGH/pegasus/issues"
8
+
depends: [
9
+
"ocaml" {= "5.2.1"}
10
+
"dune" {>= "3.20"}
11
+
"lwt"
12
+
"melange"
13
+
"mlx"
14
+
"reason-react" {>= "0.16.0"}
15
+
"reason-react-ppx" {>= "0.16.0"}
16
+
"server-reason-react"
17
+
"odoc" {with-doc}
18
+
]
19
+
build: [
20
+
["dune" "subst"] {dev}
21
+
[
22
+
"dune"
23
+
"build"
24
+
"-p"
25
+
name
26
+
"-j"
27
+
jobs
28
+
"@install"
29
+
"@runtest" {with-test}
30
+
"@doc" {with-doc}
31
+
]
32
+
]
33
+
dev-repo: "git+https://github.com/futurGH/pegasus.git"
34
+
x-maintenance-intent: ["(latest)"]
+80
frontend/lib/client.ml
+80
frontend/lib/client.ml
···
1
+
module DOM = Webapi.Dom
2
+
module Location = DOM.Location
3
+
module History = DOM.History
4
+
module ReadableStream = Webapi.ReadableStream
5
+
6
+
external setNavigate : DOM.Window.t -> (string -> unit) -> unit = "__navigate"
7
+
[@@mel.scope "window"] [@@mel.set]
8
+
9
+
external readable_stream : ReadableStream.t
10
+
= "window.srr_stream.readable_stream"
11
+
12
+
let fetchApp url =
13
+
let obj = [%mel.obj {accept= "application/react.component"}] in
14
+
let headers = Fetch.HeadersInit.make obj in
15
+
Fetch.fetchWithInit url
16
+
(Fetch.RequestInit.make ~method_:Fetch.Get ~headers ())
17
+
18
+
let navigate ~setLayout search =
19
+
let location = DOM.Window.location DOM.window in
20
+
let origin = Location.origin location in
21
+
let pathname = Location.pathname location in
22
+
let currentSearch = Location.search location in
23
+
let currentParams = URL.SearchParams.makeExn currentSearch in
24
+
let newSearchParams = Js.Dict.empty () in
25
+
URL.SearchParams.forEach currentParams (fun value key ->
26
+
Js.Dict.set newSearchParams key value ) ;
27
+
let newParams = URL.SearchParams.makeExn search in
28
+
URL.SearchParams.forEach newParams (fun value key ->
29
+
Js.Dict.set newSearchParams key value ) ;
30
+
let finalSearch =
31
+
newSearchParams |> Js.Dict.entries |> URL.SearchParams.makeWithArray
32
+
|> URL.SearchParams.toString
33
+
in
34
+
if currentSearch = "?" ^ finalSearch then ()
35
+
else
36
+
let domain = URL.makeExn (origin ^ pathname) in
37
+
let finalURL =
38
+
URL.setSearch domain (URL.SearchParams.makeExn finalSearch)
39
+
in
40
+
let response = fetchApp (URL.toString finalURL) in
41
+
ReactServerDOMEsbuild.createFromFetch response
42
+
|> Js.Promise.then_ (fun element ->
43
+
History.pushState
44
+
(History.state DOM.history)
45
+
"" (URL.toString finalURL) DOM.history ;
46
+
setLayout (fun _ -> element) ;
47
+
Js.Promise.resolve () )
48
+
|> ignore
49
+
50
+
module App_from_readable_stream = struct
51
+
let initial = ReactServerDOMEsbuild.createFromReadableStream readable_stream
52
+
53
+
let[@react.component] make () =
54
+
let initialElement = React.Experimental.usePromise initial in
55
+
let layout, setLayout = React.useState (fun () -> initialElement) in
56
+
setNavigate DOM.window (navigate ~setLayout) ;
57
+
let fallback error =
58
+
Js.log error ;
59
+
React.createElement
60
+
(ReactDOM.stringToComponent "h1")
61
+
(ReactDOM.domProps ~children:(React.string "Something went wrong!") ())
62
+
in
63
+
React.createElement ReasonReactErrorBoundary.make
64
+
(ReasonReactErrorBoundary.makeProps ~fallback ~children:layout ())
65
+
end
66
+
67
+
let () =
68
+
let document = DOM.Document.asHtmlDocument DOM.document in
69
+
let body = Option.bind document DOM.HtmlDocument.body in
70
+
match body with
71
+
| Some element ->
72
+
let transition () =
73
+
ReactDOM.Client.hydrateRoot element
74
+
(React.createElement App_from_readable_stream.make
75
+
(App_from_readable_stream.makeProps ()) )
76
+
|> ignore
77
+
in
78
+
React.startTransition transition
79
+
| None ->
80
+
Js.log "Root element not found"
+55
frontend/lib/components/Input.mlx
+55
frontend/lib/components/Input.mlx
···
1
+
open React
2
+
3
+
(* putting this inline messes with ocamlformat-mlx *)
4
+
let req_marker = " *"
5
+
6
+
let[@react.component] make ?id ~name ?(className = "") ?(type_ = "text") ?label
7
+
?(sr_only = false) ?value ?placeholder ?(required = false)
8
+
?(disabled = false) ?trailing () =
9
+
let id = Option.value id ~default:name in
10
+
let placeholder = if label <> None && sr_only then label else placeholder in
11
+
let input =
12
+
<input
13
+
id
14
+
type_
15
+
name
16
+
?placeholder
17
+
required
18
+
disabled
19
+
?value
20
+
className="block min-w-0 grow text-mist-100 placeholder:text-mist-80 \
21
+
placeholder:font-medium focus-visible:outline-none"
22
+
/>
23
+
in
24
+
<div>
25
+
( match label with
26
+
| Some label ->
27
+
<div
28
+
className=( "flex justify-between text-sm"
29
+
^ if sr_only then " sr-only" else "" )>
30
+
<label htmlFor=id className="text-mist-100">
31
+
(string label)
32
+
( if required then
33
+
<span className="text-phoenix-100">(string req_marker)</span>
34
+
else null )
35
+
</label>
36
+
( if required then null
37
+
else <span className="text-mist-80">(string "optional")</span> )
38
+
</div>
39
+
| None ->
40
+
null )
41
+
( if type_ = "hidden" then input
42
+
else
43
+
<div
44
+
className=( "flex items-center rounded-lg py-1.5 px-3 outline-1 \
45
+
outline-mana-40 disabled:outline-mana-40/20 \
46
+
disabled:bg-mana-40/20 focus-within:outline-2 \
47
+
focus-within:outline-mana-100" ^ className )>
48
+
input
49
+
( match trailing with
50
+
| Some trailing ->
51
+
<div className="shrink-0 text-mist-100 select-none">trailing</div>
52
+
| None ->
53
+
null )
54
+
</div> )
55
+
</div>
+21
frontend/lib/dune
+21
frontend/lib/dune
···
1
+
(library
2
+
(name frontend)
3
+
(modules :standard \ client)
4
+
(libraries server-reason-react.react)
5
+
(preprocess
6
+
(pps server-reason-react.melange_ppx server-reason-react.ppx)))
7
+
8
+
(melange.emit
9
+
(target app)
10
+
(modules client)
11
+
(module_systems es6)
12
+
(libraries
13
+
melange.js
14
+
reason-react
15
+
react_server_dom_esbuild
16
+
server-reason-react.url_js
17
+
melange-webapi)
18
+
(preprocess
19
+
(pps melange.ppx reason-react-ppx)))
20
+
21
+
(include_subdirs qualified)
+66
frontend/lib/templates/Authorize.mlx
+66
frontend/lib/templates/Authorize.mlx
···
1
+
open Components
2
+
open React
3
+
4
+
let cimd_suffix_len = String.length "/oauth-client-metadata.json"
5
+
6
+
let[@react.component] make ~client_url ?client_name ~handle ~scopes ~code
7
+
~request_uri ~csrf_token () =
8
+
let host, path = client_url in
9
+
let rendered_name =
10
+
match client_name with
11
+
| Some client_name ->
12
+
<span className="text-mana-100 font-serif">
13
+
(string client_name)
14
+
<span className="font-sans">(string (" (" ^ host ^ ")"))</span>
15
+
</span>
16
+
| None when String.length path = 0 ->
17
+
<span className="text-mana-100 font-serif">(string host)</span>
18
+
| None ->
19
+
<span className="text-mana-100 font-serif">
20
+
(string host) <span className="text-mana-40">(string path)</span>
21
+
</span>
22
+
in
23
+
let rendered_handle =
24
+
<span className="text-mana-100 font-serif">(string @@ "@" ^ handle)</span>
25
+
in
26
+
<Layout title=("Authorize " ^ host)>
27
+
<main className="w-full h-auto max-w-lg px-4 sm:px-0">
28
+
<h1 className="text-2xl font-serif text-mana-200 mb-2">
29
+
(string ("authorizing " ^ host))
30
+
</h1>
31
+
<p className="w-full text-mist-100">
32
+
(string "You’re signing into ")
33
+
rendered_name
34
+
(string " as ")
35
+
rendered_handle
36
+
(string " and granting it the following permissions:")
37
+
</p>
38
+
<ul className="w-full text-mist-100 list-disc ml-8 mt-2 space-y-1">
39
+
( List.map (fun scope -> <li>(string scope)</li>) scopes
40
+
|> Array.of_list |> array )
41
+
</ul>
42
+
<form
43
+
method_="post"
44
+
className="w-full flex flex-row items-center justify-between mt-6">
45
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
46
+
<input type_="hidden" name="code" value=code />
47
+
<input type_="hidden" name="request_uri" value=request_uri />
48
+
<Button
49
+
kind=`Secondary
50
+
type_="submit"
51
+
name="action"
52
+
value="deny"
53
+
className="grow basis-1/3 min-w-0">
54
+
(string "cancel")
55
+
</Button>
56
+
<Button
57
+
kind=`Primary
58
+
type_="submit"
59
+
name="action"
60
+
value="allow"
61
+
className="grow basis-2/3 min-w-0 max-w-2xs">
62
+
(string "authorize")
63
+
</Button>
64
+
</form>
65
+
</main>
66
+
</Layout>
+16
frontend/lib/templates/Layout.mlx
+16
frontend/lib/templates/Layout.mlx
···
1
+
open React
2
+
3
+
let[@react.component] make ?(title = "Pegasus") ~children () =
4
+
<html lang="en">
5
+
<head>
6
+
<meta charSet="utf-8" />
7
+
<meta name="viewport" content="width=device-width, initial-scale=1" />
8
+
<link rel="stylesheet" href="/public/index.css" />
9
+
<title>(string title)</title>
10
+
</head>
11
+
<body
12
+
className="bg-feather-100 font-sans font-normal text-base \
13
+
tracking-normal flex items-center justify-center min-h-screen">
14
+
children
15
+
</body>
16
+
</html>
+37
frontend/lib/templates/Login.mlx
+37
frontend/lib/templates/Login.mlx
···
1
+
open Components
2
+
open React
3
+
4
+
let[@react.component] make ~redirect_url ?error ~csrf_token () =
5
+
<Layout title="Sign In">
6
+
<main className="w-full h-auto max-w-xs px-4 sm:px-0">
7
+
<h1 className="text-2xl font-serif text-mana-200 mb-2">
8
+
(string "sign in")
9
+
</h1>
10
+
<span className="w-full text-balance text-mist-100">
11
+
(string "Enter your handle, email address, or DID, and your password.")
12
+
</span>
13
+
<form method_="post" className="w-full flex flex-col mt-4 mb-2 gap-y-2">
14
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
15
+
<Input sr_only=true name="identifier" type_="text" label="identifier" />
16
+
<Input sr_only=true name="password" type_="password" label="password" />
17
+
<input type_="hidden" name="redirect_url" value=redirect_url />
18
+
( match error with
19
+
| Some error ->
20
+
<span className="inline-flex items-center text-phoenix-100 text-sm">
21
+
<Icons.CircleAlert className="w-4 h-4 mr-2" /> (string error)
22
+
</span>
23
+
| None ->
24
+
null )
25
+
<Button type_="submit" className="mt-2">(string "sign in")</Button>
26
+
</form>
27
+
<span className="text-sm text-mist-100">
28
+
(string "Or ")
29
+
<a
30
+
href="/account/signup"
31
+
className="text-mana-100 underline hover:text-mana-200">
32
+
(string "create an account")
33
+
</a>
34
+
(string ".")
35
+
</span>
36
+
</main>
37
+
</Layout>
+350
frontend/lib/vendor/react-server-dom-esbuild/ReactServerDOMEsbuild.ml
+350
frontend/lib/vendor/react-server-dom-esbuild/ReactServerDOMEsbuild.ml
···
1
+
[%%mel.raw
2
+
{|
3
+
/*
4
+
* This file is a bundler integration between react (react-client/flight), esbuild and server-reason-react.
5
+
*
6
+
* Similar resources:
7
+
* - **react-server-dom-webpack**: https://github.com/facebook/react/blob/5c56b873efb300b4d1afc4ba6f16acf17e4e5800/packages/react-server-dom-webpack/src/ReactFlightWebpackPlugin.js#L156-L194
8
+
* - **react-server-dom-parcel**: https://github.com/facebook/react/pull/31725
9
+
*/
10
+
11
+
const ReactClientFlight = require("@pedrobslisboa/react-client/flight");
12
+
13
+
const isDebug = false;
14
+
15
+
const debug = (...args) => {
16
+
if (isDebug && process.env.NODE_ENV === "development") {
17
+
console.log(...args);
18
+
}
19
+
};
20
+
21
+
const ReactFlightClientStreamConfigWeb = {
22
+
createStringDecoder() {
23
+
return new TextDecoder();
24
+
},
25
+
26
+
readPartialStringChunk(decoder, buffer) {
27
+
return decoder.decode(buffer, { stream: true });
28
+
},
29
+
30
+
readFinalStringChunk(decoder, buffer) {
31
+
return decoder.decode(buffer);
32
+
},
33
+
};
34
+
35
+
const badgeFormat = "%c%s%c ";
36
+
37
+
// Same badge styling as DevTools.
38
+
const badgeStyle =
39
+
// We use a fixed background if light-dark is not supported, otherwise
40
+
// we use a transparent background.
41
+
"background: #e6e6e6;" +
42
+
"background: light-dark(rgba(0,0,0,0.1), rgba(255,255,255,0.25));" +
43
+
"color: #000000;" +
44
+
"color: light-dark(#000000, #ffffff);" +
45
+
"border-radius: 2px";
46
+
47
+
const resetStyle = "";
48
+
const pad = " ";
49
+
50
+
const bind = Function.prototype.bind;
51
+
52
+
const ReactClientConsoleConfigBrowser = {
53
+
bindToConsole(methodName, args, badgeName) {
54
+
let offset = 0;
55
+
switch (methodName) {
56
+
case "dir":
57
+
case "dirxml":
58
+
case "groupEnd":
59
+
case "table": {
60
+
// These methods cannot be colorized because they don't take a formatting string.
61
+
return bind.apply(console[methodName], [console].concat(args));
62
+
}
63
+
case "assert": {
64
+
// assert takes formatting options as the second argument.
65
+
offset = 1;
66
+
}
67
+
}
68
+
69
+
const newArgs = args.slice(0);
70
+
if (typeof newArgs[offset] === "string") {
71
+
newArgs.splice(
72
+
offset,
73
+
1,
74
+
badgeFormat + newArgs[offset],
75
+
badgeStyle,
76
+
pad + badgeName + pad,
77
+
resetStyle
78
+
);
79
+
} else {
80
+
newArgs.splice(
81
+
offset,
82
+
0,
83
+
badgeFormat,
84
+
badgeStyle,
85
+
pad + badgeName + pad,
86
+
resetStyle
87
+
);
88
+
}
89
+
90
+
// The "this" binding in the "bind";
91
+
newArgs.unshift(console);
92
+
93
+
return bind.apply(console[methodName], newArgs);
94
+
},
95
+
};
96
+
97
+
const ID = 0;
98
+
const NAME = 1;
99
+
const BUNDLES = 2;
100
+
101
+
const ReactFlightClientConfigBundlerEsbuild = {
102
+
prepareDestinationForModule(moduleLoading, nonce, metadata) {
103
+
debug("prepareDestinationForModule", moduleLoading, nonce, metadata);
104
+
return;
105
+
},
106
+
107
+
resolveClientReference(bundlerConfig, metadata) {
108
+
debug("resolveClientReference", bundlerConfig, metadata);
109
+
// Reference is already resolved during the build
110
+
return {
111
+
type: "ClientComponent",
112
+
id: metadata[ID],
113
+
name: metadata[NAME],
114
+
bundles: metadata[BUNDLES],
115
+
};
116
+
},
117
+
118
+
resolveServerReference(bundlerConfig, ref) {
119
+
debug("resolveServerReference", bundlerConfig, ref);
120
+
121
+
return {
122
+
type: "ServerFunction",
123
+
id: ref,
124
+
};
125
+
},
126
+
127
+
preloadModule(metadata) {
128
+
debug("preloadModule", metadata);
129
+
/* TODO: Does it make sense to preload a module in esbuild? */
130
+
return undefined;
131
+
},
132
+
133
+
requireModule(metadata) {
134
+
const getModule = (type, id) => {
135
+
switch (type) {
136
+
case "ServerFunction":
137
+
const fn = window.__server_functions_manifest_map[id];
138
+
139
+
return fn;
140
+
case "ClientComponent":
141
+
const component = window.__client_manifest_map[id];
142
+
143
+
return component
144
+
}
145
+
}
146
+
147
+
const module = getModule(metadata.type, metadata.id);
148
+
if (!module) {
149
+
throw new Error(`Could not find module of type ${metadata.type} with id: ${metadata.id}`);
150
+
}
151
+
152
+
return module
153
+
},
154
+
};
155
+
156
+
/* TODO: Can we use the real thing, instead of mocks/vendored code here? */
157
+
const ReactServerDOMEsbuildConfig = {
158
+
...ReactFlightClientStreamConfigWeb,
159
+
...ReactClientConsoleConfigBrowser,
160
+
...ReactFlightClientConfigBundlerEsbuild,
161
+
rendererVersion: "19.0.0",
162
+
rendererPackageName: "react-server-dom-esbuild",
163
+
usedWithSSR: true,
164
+
};
165
+
166
+
const {
167
+
createResponse,
168
+
createServerReference: createServerReferenceImpl,
169
+
processReply,
170
+
getRoot,
171
+
reportGlobalError,
172
+
processBinaryChunk,
173
+
createStreamState,
174
+
close,
175
+
} = ReactClientFlight(ReactServerDOMEsbuildConfig);
176
+
177
+
function startReadingFromStream(response, stream) {
178
+
const streamState = createStreamState();
179
+
const reader = stream.getReader();
180
+
function progress({
181
+
done,
182
+
value,
183
+
}) {
184
+
if (done) {
185
+
close(response);
186
+
return;
187
+
}
188
+
const buffer = value;
189
+
processBinaryChunk(response, streamState, buffer);
190
+
return reader.read().then(progress).catch(error);
191
+
}
192
+
function error(e) {
193
+
reportGlobalError(response, e);
194
+
}
195
+
reader.read().then(progress).catch(error);
196
+
}
197
+
198
+
function callCurrentServerCallback(callServer) {
199
+
return function (id, args) {
200
+
if (!callServer) {
201
+
throw new Error(
202
+
"No server callback has been registered. Call setServerCallback to register one."
203
+
);
204
+
}
205
+
return callServer(id, args);
206
+
};
207
+
}
208
+
209
+
function createFromReadableStream(stream, options) {
210
+
const response = createResponseFromOptions(options);
211
+
startReadingFromStream(response, stream);
212
+
return getRoot(response);
213
+
}
214
+
215
+
function createResponseFromOptions(options) {
216
+
let response = createResponse(
217
+
null, // bundlerConfig
218
+
{}, // serverFunctionsConfig, this is the manifest that can contain configs related to server functions. It requires it to not be null, to run resolveServerReference
219
+
null, // moduleLoading
220
+
callCurrentServerCallback(options ? options.callServer : undefined),
221
+
undefined, // encodeFormAction
222
+
undefined, // nonce
223
+
options && options.temporaryReferences
224
+
? options.temporaryReferences
225
+
: undefined,
226
+
undefined, // TODO: findSourceMapUrl
227
+
false /* __DEV__ ? (options ? options.replayConsoleLogs !== false : true) */,
228
+
undefined /* __DEV__ && options && options.environmentName
229
+
? options.environmentName
230
+
: undefined */
231
+
);
232
+
233
+
return response;
234
+
}
235
+
236
+
function createFromFetch(promise, options) {
237
+
const response = createResponseFromOptions(options);
238
+
promise.then(
239
+
function (r) {
240
+
startReadingFromStream(response, r.body);
241
+
},
242
+
function (e) {
243
+
reportGlobalError(response, e);
244
+
}
245
+
);
246
+
return getRoot(response);
247
+
}
248
+
249
+
const createServerReference = createServerReferenceImpl;
250
+
251
+
const encodeReply = (
252
+
value,
253
+
options = { temporaryReferences: undefined, signal: undefined }
254
+
) => {
255
+
return new Promise((resolve, reject) => {
256
+
const abort = processReply(
257
+
value,
258
+
"",
259
+
options && options.temporaryReferences
260
+
? options.temporaryReferences
261
+
: undefined,
262
+
resolve,
263
+
reject
264
+
);
265
+
if (options && options.signal) {
266
+
const signal = options.signal;
267
+
if (signal.aborted) {
268
+
abort(signal.reason);
269
+
} else {
270
+
const listener = () => {
271
+
abort(signal.reason);
272
+
signal.removeEventListener("abort", listener);
273
+
};
274
+
signal.addEventListener("abort", listener);
275
+
}
276
+
}
277
+
});
278
+
};
279
+
280
+
module.exports = {
281
+
createFromReadableStream,
282
+
createFromFetch,
283
+
createServerReference,
284
+
encodeReply,
285
+
}
286
+
|}]
287
+
288
+
type arg
289
+
290
+
type callServer = string -> arg list -> React.element Js.Promise.t
291
+
292
+
type options = {callServer: callServer}
293
+
294
+
external createFromReadableStreamImpl :
295
+
Webapi.ReadableStream.t
296
+
-> ?options:options
297
+
-> unit
298
+
-> React.element Js.Promise.t = "createFromReadableStream"
299
+
300
+
external createFromFetchImpl :
301
+
Fetch.response Js.Promise.t
302
+
-> ?options:options
303
+
-> unit
304
+
-> React.element Js.Promise.t = "createFromFetch"
305
+
306
+
external createServerReferenceImpl :
307
+
string
308
+
-> callServer
309
+
-> 'encodeFormActionCallback option
310
+
-> 'findSourceMapURLCallback option
311
+
-> string option
312
+
-> 'action = "createServerReference"
313
+
314
+
external encodeReply : 'arg list -> string Js.Promise.t = "encodeReply"
315
+
316
+
let callServerRef = (ref None : callServer option ref)
317
+
318
+
let setCallServer callServer = callServerRef := Some callServer
319
+
320
+
let getCallServer () = !callServerRef
321
+
322
+
let createFromReadableStream ?callServer stream : React.element Js.Promise.t =
323
+
match callServer with
324
+
| Some callServer ->
325
+
setCallServer callServer ;
326
+
createFromReadableStreamImpl stream ~options:{callServer} ()
327
+
| None ->
328
+
createFromReadableStreamImpl stream ()
329
+
330
+
let createFromFetch ?callServer promise =
331
+
match callServer with
332
+
| Some callServer ->
333
+
setCallServer callServer ;
334
+
createFromFetchImpl promise ~options:{callServer} ()
335
+
| None ->
336
+
createFromFetchImpl promise ()
337
+
338
+
let createServerReference serverReferenceId =
339
+
let callServer =
340
+
match getCallServer () with
341
+
| Some callServer ->
342
+
callServer
343
+
| None ->
344
+
raise
345
+
(Invalid_argument
346
+
"No callServer has been set, you are trying to create a server \
347
+
function without passing callServer to createFromFetch or \
348
+
createFromReadableStream" )
349
+
in
350
+
createServerReferenceImpl serverReferenceId callServer None None None
+9
frontend/lib/vendor/react-server-dom-esbuild/dune
+9
frontend/lib/vendor/react-server-dom-esbuild/dune
+1
-2
pegasus.opam
+1
-2
pegasus.opam
+6
-5
pegasus/lib/api/account_/login.ml
+6
-5
pegasus/lib/api/account_/login.ml
···
8
8
in
9
9
let csrf_token = Dream.csrf_token ctx.req in
10
10
let html =
11
-
JSX.render (Templates.Login.make ~redirect_url ~csrf_token ())
11
+
ReactDOM.renderToStaticMarkup
12
+
(Frontend.Templates.Login.make ~redirect_url ~csrf_token ())
12
13
in
13
14
Dream.html html )
14
15
···
29
30
match actor with
30
31
| None ->
31
32
let html =
32
-
JSX.render
33
-
(Templates.Login.make ~redirect_url
33
+
ReactDOM.renderToStaticMarkup
34
+
(Frontend.Templates.Login.make ~redirect_url
34
35
~error:"Invalid username or password. Please try again."
35
36
~csrf_token () )
36
37
in
···
41
42
Dream.redirect ctx.req redirect_url )
42
43
| _ ->
43
44
let html =
44
-
JSX.render
45
-
(Templates.Login.make ~redirect_url:"/account"
45
+
ReactDOM.renderToStaticMarkup
46
+
(Frontend.Templates.Login.make ~redirect_url:"/account"
46
47
~error:"Invalid credentials provided. Please try again."
47
48
~csrf_token () )
48
49
in
+3
-3
pegasus/lib/dune
+3
-3
pegasus/lib/dune
···
9
9
cohttp-lwt-unix
10
10
dns-client.unix
11
11
dream
12
-
html_of_jsx
12
+
frontend
13
13
ipld
14
14
kleidos
15
15
lwt
···
17
17
mist
18
18
re
19
19
safepass
20
-
str
20
+
server-reason-react.reactDom
21
21
timedesc
22
22
uri
23
23
uuidm
···
26
26
ppx_deriving_yojson.runtime
27
27
ppx_rapper_lwt)
28
28
(preprocess
29
-
(pps html_of_jsx.ppx lwt_ppx ppx_deriving_yojson ppx_rapper)))
29
+
(pps lwt_ppx ppx_deriving_yojson ppx_rapper)))
30
30
31
31
(include_subdirs qualified)
+2
-2
pegasus/lib/migrations.ml
+2
-2
pegasus/lib/migrations.ml
···
41
41
let db = Sqlite3.db_open db_path in
42
42
try
43
43
let rc = Sqlite3.exec db sql in
44
-
let _ = Sqlite3.db_close db in
44
+
let _ = try Sqlite3.db_close db with _ -> true in
45
45
match rc with
46
46
| Sqlite3.Rc.OK ->
47
47
Lwt.return_ok ()
···
49
49
let err_msg = Sqlite3.errmsg db in
50
50
Lwt.return_error (Failure ("sql error: " ^ err_msg))
51
51
with e ->
52
-
let _ = Sqlite3.db_close db in
52
+
let _ = try Sqlite3.db_close db with _ -> true in
53
53
Lwt.return_error e
54
54
55
55
let parse_migration_filename filename =
+57
pegasus/lib/rsc.ml
+57
pegasus/lib/rsc.ml
···
1
+
let debug = Sys.getenv_opt "DEMO_ENV" == Some "development"
2
+
3
+
let is_react_component_header str =
4
+
String.equal str "application/react.component"
5
+
6
+
let stream_model ~location app =
7
+
Dream.stream
8
+
~headers:
9
+
[ ("Content-Type", "application/react.component")
10
+
; ("X-Content-Type-Options", "nosniff")
11
+
; ("X-Location", location) ]
12
+
(fun stream ->
13
+
[%lwt
14
+
let () =
15
+
ReactServerDOM.render_model ~debug
16
+
~subscribe:(fun chunk ->
17
+
if debug then (Dream.log "Chunk" ; Dream.log "%s" chunk) ;
18
+
[%lwt
19
+
let () = Dream.write stream chunk in
20
+
Dream.flush stream] )
21
+
app
22
+
in
23
+
Dream.flush stream] )
24
+
25
+
let stream_html ?(skipRoot = false) ?bootstrapScriptContent
26
+
?(bootstrapScripts = []) ?(bootstrapModules = []) app =
27
+
Dream.stream
28
+
~headers:[("Content-Type", "text/html")]
29
+
(fun stream ->
30
+
[%lwt
31
+
let html, subscribe =
32
+
ReactServerDOM.render_html ~skipRoot ?bootstrapScriptContent
33
+
~bootstrapScripts ~bootstrapModules ~debug app
34
+
in
35
+
[%lwt
36
+
let () = Dream.write stream html in
37
+
[%lwt
38
+
let () = Dream.flush stream in
39
+
[%lwt
40
+
let () =
41
+
subscribe (fun chunk ->
42
+
if debug then (Dream.log "Chunk" ; Dream.log "%s" chunk) ;
43
+
[%lwt
44
+
let () = Dream.write stream chunk in
45
+
Dream.flush stream] )
46
+
in
47
+
Dream.flush stream]]]] )
48
+
49
+
let createFromRequest ?(disableSSR = false) ?(layout = fun children -> children)
50
+
?(bootstrapModules = []) ?(bootstrapScripts = [])
51
+
?(bootstrapScriptContent = "") element request =
52
+
match Dream.header request "accept" with
53
+
| Some accept when is_react_component_header accept ->
54
+
stream_model ~location:(Dream.target request) (React.Model.Element element)
55
+
| _ ->
56
+
stream_html ~skipRoot:disableSSR ~bootstrapScriptContent ~bootstrapScripts
57
+
~bootstrapModules (layout element)
+13
-11
pegasus/lib/templates/components/button.mlx
frontend/lib/components/Button.mlx
+13
-11
pegasus/lib/templates/components/button.mlx
frontend/lib/components/Button.mlx
···
1
1
let base_classes =
2
2
"py-1 px-4 text-lg rounded-lg w-full flex items-center justify-center \
3
-
transition delay-50 duration-300 focus-visible:outline-none disabled:text-mist-80"
3
+
transition delay-50 duration-300 focus-visible:outline-none \
4
+
disabled:text-mist-80"
4
5
5
-
type kind = Primary | Secondary | Tertiary | Danger
6
+
type kind = [`Primary | `Secondary | `Tertiary | `Danger]
6
7
7
8
let classes = function
8
-
| Primary ->
9
+
| `Primary ->
9
10
base_classes
10
11
^ " bg-white font-serif text-mana-200 shadow-whisper \
11
12
hover:shadow-shimmer hover:bg-mist-20 focus-visible:shadow-shimmer \
12
13
focus-visible:bg-mist-20 active:shadow-glow disabled:bg-mana-40"
13
-
| Secondary ->
14
+
| `Secondary ->
14
15
base_classes
15
16
^ " bg-feather font-serif underline text-mana-100 hover:no-underline \
16
-
focus-visible:shadow-whisper active:shadow-whisper disabled:no-underline \
17
-
disabled:bg-mana-40"
18
-
| Tertiary ->
17
+
focus-visible:shadow-whisper active:shadow-whisper \
18
+
disabled:no-underline disabled:bg-mana-40"
19
+
| `Tertiary ->
19
20
base_classes
20
21
^ " font-sans underline text-mana-100 hover:no-underline \
21
22
focus-visible:text-mana-200 active:text-mana-200"
22
-
| Danger ->
23
+
| `Danger ->
23
24
base_classes
24
25
^ " bg-white font-serif text-phoenix-100 shadow-bleed hover:bg-mist-20 \
25
26
hover:text-phoenix-40 focus:bg-mist-20 focus:text-phoenix-40 \
26
27
focus-visible:outline-none active:bg-phoenix-40 active:text-mist-20 \
27
28
disabled:bg-mana-40"
28
29
29
-
let make ?id ?name ?(kind = Primary) ?(type_ = "button") ?onclick ?value
30
-
?(class_ = "") ~children () =
31
-
<button ?id ?name type_ ?onclick ?value class_=(classes kind ^ " " ^ class_)>
30
+
let[@react.component] make ?id ?name ?(kind = `Primary) ?(type_ = "button")
31
+
?onClick ?value ?(className = "") ~children () =
32
+
<button
33
+
?id ?name type_ ?onClick ?value className=(classes kind ^ " " ^ className)>
32
34
children
33
35
</button>
-56
pegasus/lib/templates/components/input.mlx
-56
pegasus/lib/templates/components/input.mlx
···
1
-
open JSX
2
-
3
-
(* putting this inline messes with ocamlformat-mlx *)
4
-
let req_marker = " *"
5
-
6
-
let make ?id ~name ?(class_ = "") ?(type_ = "text") ?label ?(sr_only = false)
7
-
?value ?placeholder ?(required = false) ?(disabled = false) ?trailing () =
8
-
let id = Option.value id ~default:name in
9
-
let placeholder = if label <> None && sr_only then label else placeholder in
10
-
let input =
11
-
<input
12
-
id
13
-
type_
14
-
name
15
-
?placeholder
16
-
required
17
-
disabled
18
-
?value
19
-
class_="block min-w-0 grow text-mist-100 placeholder:text-mist-80 \
20
-
placeholder:font-medium focus-visible:outline-none"
21
-
/>
22
-
in
23
-
<div>
24
-
( match label with
25
-
| Some label ->
26
-
<div
27
-
class_=( "flex justify-between text-sm"
28
-
^ if sr_only then " sr-only" else "" )>
29
-
<label for_=id class_="text-mist-100">
30
-
( if required then
31
-
list
32
-
[ string label
33
-
; <span class_="text-phoenix-100">(string req_marker)</span>
34
-
]
35
-
else string label )
36
-
</label>
37
-
( if required then null
38
-
else <span class_="text-mist-80">"optional"</span> )
39
-
</div>
40
-
| None ->
41
-
null )
42
-
( if type_ = "hidden" then input
43
-
else
44
-
<div
45
-
class_=( "flex items-center rounded-lg py-1.5 px-3 outline-1 \
46
-
outline-mana-40 disabled:outline-mana-40/20 \
47
-
disabled:bg-mana-40/20 focus-within:outline-2 \
48
-
focus-within:outline-mana-100" ^ class_ )>
49
-
input
50
-
( match trailing with
51
-
| Some trailing ->
52
-
<div class_="shrink-0 text-mist-100 select-none">trailing</div>
53
-
| None ->
54
-
null )
55
-
</div> )
56
-
</div>
+2
-2
pegasus/lib/templates/icons/circle_alert.mlx
frontend/lib/icons/CircleAlert.mlx
+2
-2
pegasus/lib/templates/icons/circle_alert.mlx
frontend/lib/icons/CircleAlert.mlx
-16
pegasus/lib/templates/layout.mlx
-16
pegasus/lib/templates/layout.mlx
···
1
-
open JSX
2
-
3
-
let make ?(title = "Pegasus") ~children () =
4
-
<html lang="en">
5
-
<head>
6
-
<meta charset="utf-8" />
7
-
<meta name="viewport" content="width=device-width, initial-scale=1" />
8
-
<link rel="stylesheet" href="/public/index.css" />
9
-
<title>(string title)</title>
10
-
</head>
11
-
<body
12
-
class_="bg-feather-100 font-sans font-normal text-base tracking-normal \
13
-
flex items-center justify-center min-h-screen">
14
-
children
15
-
</body>
16
-
</html>
-35
pegasus/lib/templates/login.mlx
-35
pegasus/lib/templates/login.mlx
···
1
-
open JSX
2
-
open Components
3
-
4
-
let make ~redirect_url ?error ~csrf_token () =
5
-
<Layout title="Login">
6
-
<main class_="w-full h-auto max-w-xs px-4 sm:px-0">
7
-
<h1 class_="text-2xl font-serif text-mana-200 mb-2">"sign in"</h1>
8
-
<span class_="w-full text-balance text-mist-100">
9
-
"Enter your handle, email address, or DID, and your password."
10
-
</span>
11
-
<form method_="post" class_="w-full flex flex-col mt-4 mb-2 gap-y-2">
12
-
<input type_="hidden" name="dream.csrf" value=csrf_token />
13
-
<Input sr_only=true name="identifier" type_="text" label="identifier" />
14
-
<Input sr_only=true name="password" type_="password" label="password" />
15
-
<input type_="hidden" name="redirect_url" value=redirect_url />
16
-
( match error with
17
-
| Some error ->
18
-
<span class_="inline-flex items-center text-phoenix-100 text-sm">
19
-
<Icons.Circle_alert class_="w-4 h-4 mr-2" /> (string error)
20
-
</span>
21
-
| None ->
22
-
null )
23
-
<Button type_="submit" class_="mt-2">"sign in"</Button>
24
-
</form>
25
-
<span class_="text-sm text-mist-100">
26
-
"Or "
27
-
<a
28
-
href="/account/signup"
29
-
class_="text-mana-100 underline hover:text-mana-200">
30
-
"create an account"
31
-
</a>
32
-
"."
33
-
</span>
34
-
</main>
35
-
</Layout>
+16
public/index.html
+16
public/index.html
···
1
+
<!doctype html>
2
+
<html lang="en">
3
+
<head>
4
+
<meta charset="utf-8" />
5
+
<meta name="viewport" content="width=device-width, initial-scale=1" />
6
+
<link rel="stylesheet" href="/public/index.css" />
7
+
<script type="module" src="/public/index.js" />
8
+
<title>Pegasus</title>
9
+
</head>
10
+
<body>
11
+
<div
12
+
id="root"
13
+
class="bg-feather-100 font-sans font-normal text-base tracking-normal \ flex items-center justify-center min-h-screen"
14
+
></div>
15
+
</body>
16
+
</html>
+1
public/index.js
+1
public/index.js
···
1
+
import "../_build/default/pegasus/lib/client/js/src/client/App.js";