some progress

This commit is contained in:
cqc
2024-02-14 16:15:49 -06:00
parent 0f1fd67e8a
commit e2a574d215
18 changed files with 1420 additions and 216 deletions

0
.ocamlformat Normal file
View File

View File

@ -1,28 +0,0 @@
open Js_of_ocaml
open Js_of_ocaml_tyxml
let text ~a_class:cl s = Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ])
let ocaml = text
let highlight from_ to_ e =
match Js.Opt.to_option e##.textContent with
| None -> assert false
| Some x ->
let x = Js.to_string x in
let (`Pos from_) = from_ in
let to_ =
match to_ with
| `Pos n -> n
| `Last -> String.length x - 1
in
e##.innerHTML := Js.string "";
let span kind s =
if s <> ""
then
let span = Tyxml_js.Html.(span ~a:[ a_class [ kind ] ] [ txt s ]) in
Dom.appendChild e (Tyxml_js.To_dom.of_element span)
in
span "normal" (String.sub x 0 from_);
span "errorloc" (String.sub x from_ (to_ - from_));
span "normal" (String.sub x to_ (String.length x - to_))

215
cors_proxy.ml Normal file
View File

@ -0,0 +1,215 @@
module Format = Stdlib.Format
module Arg = Stdlib.Arg
open Lwt.Infix
open Httpaf
module Server = struct
include Httpaf_lwt_unix.Server
let error_handler ?request:_ error start_response =
let response_body = start_response Headers.empty in
(match error with
| `Exn exn ->
Body.write_string response_body (Base.Exn.to_string exn);
Body.write_string response_body "\n"
| #Status.standard as error ->
Body.write_string response_body
(Status.default_reason_phrase error));
Body.close_writer response_body
end
let proxy_host = "gitea.departmentofinter.net"
let file_response_headers =
[
("accept-ranges", "bytes");
("access-control-allow-origin", "*");
( "access-control-allow-headers",
"Origin, X-Requested-With, Content-Type, Accept, Range" );
("cache-control", "no-cache, no-store, must-revalidate");
("etag", "W/\"6861266-5562-2024-02-11T19:05:04.733Z\"");
("content-type", "text/html; charset=UTF-8");
("connection", "close");
]
let proxy_handler reqd : unit =
match Reqd.request reqd with
| Request.{ meth; headers; target; _ } ->
Lwt.async (fun () ->
let filename = Fmt.str "./%s" target in
if Sys.file_exists filename && Sys.is_regular_file filename
then (
let file =
Lwt_io.open_file ~flags:[ O_RDONLY ] ~mode:Lwt_io.input
filename
in
let headers = Headers.of_list file_response_headers in
Lwt_io.file_length filename >>= fun file_len ->
let headers =
Headers.add_list headers
[ ("content-length", Int64.to_string file_len) ]
in
Format.printf ">>> Response with File:\nHeaders:\n%s\n %!"
(Headers.to_string headers);
let response = Response.create ~headers `OK in
let response_body =
Reqd.respond_with_streaming reqd response
in
file >>= fun file ->
let rec reader () =
if
Int64.compare
(Int64.sub file_len (Lwt_io.position file))
Int64.zero
> 0
then (
Lwt_io.read file >>= fun s ->
Format.printf ".%i\n%!" (String.length s);
Body.write_string response_body s;
reader ())
else Lwt.return_unit >>= fun () -> Lwt.return_unit
in
reader () >>= fun () ->
Body.close_writer response_body;
Lwt_io.close file >>= fun () ->
Format.printf "done%!";
Lwt.return_unit)
else
let uri = Fmt.str "https://%s%s" proxy_host target in
let proxy_finished, proxy_notify_finished = Lwt.wait () in
let proxy_response_handler _
(proxy_response_body_acc : Buffer.t)
proxy_response_body =
Format.printf ">>> proxy_response_body chunk: %i\n%!"
(String.length proxy_response_body);
Buffer.add_string proxy_response_body_acc
proxy_response_body;
Lwt.return proxy_response_body_acc
in
let request_headers =
Headers.replace headers "Host" proxy_host
in
let request_headers =
Headers.replace request_headers "origin"
(Fmt.str "https://%s" proxy_host)
in
let request_headers =
Headers.replace request_headers "content-type"
"application/x-git-upload-pack-request"
in
let proxy_request_headers =
Headers.of_list
[
("Accept-Language", "en-US, *;q=0.9");
("Accept", "application/x-git-upload-pack-result");
( "Content-Type",
"application/x-git-receive-upload-request" );
("Accept-Encoding", "deflate, gzip, br, zstd");
("User-Agent", "git/2.43.0");
( "Authorization",
"Basic \
Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM="
);
("Host", "gitea.departmentofinter.net");
( "Content-Length",
Option.fold ~some:Fun.id ~none:"0"
(Headers.get headers "content-length") );
]
in
let request_body = Reqd.request_body reqd in
let request_body_buffer =
Bigstringaf.create
(Option.fold ~some:int_of_string ~none:4096
(Headers.get headers "content-length"))
in
let response_body_buffer = Buffer.create 0 in
let rec on_read buffer ~off ~len =
Bigstringaf.blit buffer ~src_off:off request_body_buffer
~dst_off:off ~len;
Body.schedule_read request_body ~on_eof ~on_read
and on_eof () = Body.close_reader request_body in
Body.schedule_read request_body ~on_eof ~on_read;
Format.printf
">>> Proxy Request: Target:%s Headers:\n%s\n%!" target
(String.trim (Headers.to_string request_headers));
Format.printf ">>> Proxy Request Body length: %i\n%!"
(Bigstringaf.length request_body_buffer);
Http_lwt_client.request
?config:(Some (`HTTP_1_1 Httpaf.Config.default))
~meth
~headers:(Headers.to_list request_headers)
?body:(Some (Bigstringaf.to_string request_body_buffer))
~follow_redirect:false uri proxy_response_handler
response_body_buffer
>>= function
| Ok
( { version; status; reason; headers },
proxy_response_body_acc ) ->
Format.printf
">>> Response Ok: Code: %i Reason: %s Headers:\n\
%s\n\
%!"
(H2.Status.to_code status)
reason
(String.trim (H2.Headers.to_string headers));
let headers =
Headers.of_list (H2.Headers.to_list headers)
in
let status =
Status.of_code (H2.Status.to_code status)
in
let response =
let content_type =
match Headers.get headers "content-type" with
| None -> "application/octet-stream"
| Some x -> x
in
Response.create ~reason ~version
~headers:
(Headers.replace headers "content-type"
content_type)
status
in
let response_body =
Reqd.respond_with_streaming reqd response
in
Body.write_string response_body ~off:0
~len:(Buffer.length proxy_response_body_acc)
(Buffer.contents proxy_response_body_acc);
Body.close_writer response_body;
Lwt.wakeup_later proxy_notify_finished ();
Lwt.return_unit
| Error (`Msg msg) ->
Format.printf "Request failed with %s%!" msg;
Lwt.return_unit >>= fun () -> proxy_finished)
(* | _ ->
let headers = Headers.of_list [ ("connection", "close") ] in
Reqd.respond_with_string reqd
(Response.create ~headers `Method_not_allowed)
"" *)
let request_handler (_ : Unix.sockaddr) = proxy_handler
let error_handler (_ : Unix.sockaddr) = Server.error_handler
let main port =
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in
Lwt.async (fun () ->
Lwt_io.establish_server_with_client_socket listen_address
(Server.create_connection_handler ~request_handler
~error_handler)
>|= fun _server ->
Stdio.printf
"Listening on localhost:%i and proxying requests via \
https://%s.\n\
%!"
port proxy_host);
let forever, _ = Lwt.wait () in
Lwt_main.run forever
let () =
let port = ref 8080 in
main !port

17
cors_proxy.sh Executable file
View File

@ -0,0 +1,17 @@
#!/bin/bash
#if [ ! -f /tmp/key.pem ]; then
# echo Creating key
# openssl req -newkey rsa:2048 -new -nodes -x509 -days 3650 -keyout /tmp/key.pem -out /tmp/cert.pem -batch
#fi
npx http-server --cors -S -P https://gitea.departmentofinter.net --log-ip -c-1 -C /tmp/cert.pem -K /tmp/key.pem
# HTTP/1.1 204 No Content
# accept-ranges: bytes
# access-control-allow-origin: *
# access-control-allow-headers: Origin, X-Requested-With, Content-Type, Accept, Range
# Date: Tue, 13 Feb 2024 00:42:59 GMT
# Connection: keep-alive
# Keep-Alive: timeout=5
#mitmproxy --map-local="|localhost:8080/|$(pwd)" --map-remote="|localhost:8080/console|https://gitea.departmentofinter.#net/console" -H="|Access-Control-Allow-Origin|*" -H "|Access-Control-Allow-Credentials|true" -H "|Access-Control-Allow#-Methods|GET, POST, OPTIONS" -H "|Access-Control-Allow-Headers|*" -H "|Access-Control-Max-Age|86400" -H="|Authorizatio#n|Basic cqc:d9c2b491e70e31a760ce70bc431036c91325f683"

79
dune
View File

@ -1,40 +1,43 @@
(env
(dev (flags (:standard -warn-error -A))))
(executables
(names toplevel)
(names cors_proxy)
(libraries httpaf httpaf-lwt-unix base stdio fmt http-lwt-client)
(modules cors_proxy)
)
(library (name store)
(libraries
js_of_ocaml-compiler
js_of_ocaml-tyxml
js_of_ocaml-toplevel
lwt
js_of_ocaml-lwt
digestif.ocaml
checkseum.ocaml
irmin.mem
git
irmin-git
cohttp-lwt-jsoo
mimic
js_of_ocaml)
(modules store)
(preprocess
(pps js_of_ocaml-ppx)))
(executables
(names oplevel)
(libraries
store
js_of_ocaml-compiler js_of_ocaml-tyxml js_of_ocaml-toplevel
lwt js_of_ocaml-lwt
;; not used directly
graphics
js_of_ocaml.deriving
react
reactiveData
str
dynlink
(select
ocp_indent.ml
from
(ocp-indent.lib -> ocp_indent.ok.ml)
(-> ocp_indent.fake.ml))
(select
colorize.ml
from
(higlo -> colorize.higlo.ml)
(!higlo -> colorize.fake.ml))
(select
graphics_support.ml
from
(js_of_ocaml-lwt.graphics -> graphics_support.enabled.ml)
(-> graphics_support.disabled.ml))
(select
ppx_support.ml
from
(js_of_ocaml-ppx -> ppx_support.enabled.ml)
(-> ppx_support.disabled.ml)))
react reactiveData
str dynlink
ocp-indent.lib
higlo
js_of_ocaml-lwt.graphics
js_of_ocaml-ppx)
(flags
(:standard -rectypes))
(:standard -rectypes -warn-error -A))
(link_flags
(:standard -linkall))
(modes byte js)
@ -42,7 +45,7 @@
(link_flags (:standard))
(build_runtime_flags
(:standard
+toplevel.js
;; +oplevel.js
+dynlink.js
--file
%{dep:examples.ml}
@ -55,7 +58,7 @@
--toplevel
(:include effects_flags.sexp))))
(modules
(:standard \ test_dynlink examples effects_flags))
oplevel toplevel ppx_support graphics_support colorize ocp_indent indent b64)
(preprocess
(pps js_of_ocaml-ppx)))
@ -84,11 +87,9 @@
-o
%{targets}
stdlib
graphics
str
dynlink
js_of_ocaml-compiler.runtime
js_of_ocaml-lwt.graphics
js_of_ocaml.graphics
js_of_ocaml-ppx.as-lib
js_of_ocaml.deriving
lwt
@ -120,7 +121,7 @@
(run ./effects_flags.exe txt))))
(rule
(targets toplevel.js)
(targets oplevel.js)
(action
(run
%{bin:js_of_ocaml}
@ -141,10 +142,10 @@
--toplevel
--disable
shortvar
%{dep:toplevel.bc}
%{dep:oplevel.bc}
-o
%{targets})))
(alias
(name default)
(deps toplevel.js toplevel.bc.js index.html))
(deps oplevel.js oplevel.bc.js index.html))

View File

@ -1 +0,0 @@
let init _ = ()

View File

@ -153,14 +153,14 @@
var fields = hash.split(/&/);
var prefix = "";
var version = "";
var main = "toplevel.bc.js";
var main = "oplevel.bc.js";
for(var f in fields){
var data = fields[f].split(/=/);
if(data[0] == "version"){
version = data[1].replace(/%20|%2B/g,"+");
}
else if (data[0] == "separate"){
main = "toplevel.bc.js";
main = "oplevel.bc.js";
}
}
function load_script(url){
@ -185,45 +185,9 @@
</div>
</div>
<div id="toplevel-side">
<h3>Js_of_ocaml</h3>
<h4>A compiler from OCaml bytecode to Javascript.</h4>
<p>It makes OCaml programs that run on Web browsers. It is
easy to install as it works with an existing installation of OCaml,
with no need to recompile any library. It comes with bindings for a
large part of the browser APIs.</p>
<p>This web-based OCaml toplevel is compiled using Js_of_ocaml.</p>
<h4>Command</h4>
<table class="table table-striped table-condensed">
<tbody class>
<tr>
<td>Enter/Return</td>
<td>Submit code</td>
</tr>
<tr>
<td>Ctrl + Enter</td>
<td>Newline</td>
</tr>
<tr>
<td>Up / Down</td>
<td>Browse history</td>
</tr>
<tr>
<td>Ctrl + l</td>
<td>Clear display</td>
</tr>
<tr>
<td>Ctrl + k</td>
<td>Reset toplevel</td>
</tr>
<tr>
<td>Tab</td>
<td>Indent code</td>
</tr>
</tbody>
</table>
<h4>Try to execute samples</h4>
<div id="toplevel-examples" class="list-group"></div>
<h3>OpLevel</h3>
<h4>A programming system based on a compiler from OCaml bytecode to Javascript.</h4>
<div id="toplevel-storeview" class="list-group"></div>
<canvas width=200 height=200 id="test-canvas"></canvas>
<h4 class="clear">See the generated javascript code</h4>
<pre id="last-js">

544
notes.org Normal file
View File

@ -0,0 +1,544 @@
* Test run with git where it was authorizied
Listening on localhost:8080 and proxying requests via https://gitea.departmentofinter.net.
>>> Proxy Request:
n Target:/console/rootstore.git/info/refs?service=git-receive-pack
Headers:
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-receive-pack-result
Content-Type: application/x-git-receive-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Host: gitea.departmentofinter.net
Content-Length: 0
>>> Proxy Request Body length: 4096
>>> proxy_response_body chunk: 294
>>> Response Ok:
Code: 200
Reason: OK
Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: macaron_flash=; Path=/; Max-Age=0; HttpOnly; SameSite=Lax
Set-Cookie: _csrf=9B1dfE3ibHWnhqKjxmgNjhDWKxs6MTcwNzg4NTQ0Mzc0ODQ5MDMwMQ; Path=/; Expires=Thu, 15 Feb 2024 04:37:23 GMT; HttpOnly; SameSite=Lax
Set-Cookie: i_like_gitea=d0e6d2fab0abe4d6; Path=/; HttpOnly; SameSite=Lax
Pragma: no-cache
Expires: Fri, 01 Jan 1980 00:00:00 GMT
Date: Wed, 14 Feb 2024 04:37:24 GMT
Content-Type: application/x-git-receive-pack-advertisement
Content-Length: 294
Cache-Control: no-cache, max-age=0, must-revalidate
>>> Proxy Request:
Target:/console/rootstore.git/git-receive-pack
Headers:
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-receive-pack-result
Content-Type: application/x-git-receive-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Host: gitea.departmentofinter.net
Content-Length: 464
>>> Proxy Request Body length: 464
>>> proxy_response_body chunk: 116
>>> Response Ok:
Code: 200
Reason: OK
Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: macaron_flash=; Path=/; Max-Age=0; HttpOnly; SameSite=Lax
Set-Cookie: _csrf=ojkPfPuEmoUZzTWaBmEdDVhIk246MTcwNzg4NTQ0NTE1Mzc0NDc4OQ; Path=/; Expires=Thu, 15 Feb 2024 04:37:25 GMT; HttpOnly; SameSite=Lax
Set-Cookie: i_like_gitea=84bbdd580c4b7420; Path=/; HttpOnly; SameSite=Lax
Date: Wed, 14 Feb 2024 04:37:25 GMT
Content-Type: application/x-git-receive-pack-result
Content-Length: 116
Cache-Control: no-store, no-transform
* Test run with page
Listening on localhost:8080 and proxying requests via https://gitea.departmentofinter.net.
>>> Proxy Request:
Target:/console/rootstore.git/info/refs?service=git-upload-pack
Headers:
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-receive-pack-result
Content-Type: application/x-git-receive-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Host: gitea.departmentofinter.net
Content-Length: 0
>>> Proxy Request Body length: 4096
>>> proxy_response_body chunk: 493
>>> Response Ok:
Code: 200
Reason: OK
Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: macaron_flash=; Path=/; Max-Age=0; HttpOnly; SameSite=Lax
Set-Cookie: _csrf=QSgFph8tFKawVujaLiaMUkCX9ss6MTcwNzg4NTU5OTM3NDQ0MTEzOA; Path=/; Expires=Thu, 15 Feb 2024 04:39:59 GMT; HttpOnly; SameSite=Lax
Set-Cookie: i_like_gitea=8523da01c899aa94; Path=/; HttpOnly; SameSite=Lax
Pragma: no-cache
Expires: Fri, 01 Jan 1980 00:00:00 GMT
Date: Wed, 14 Feb 2024 04:39:59 GMT
Content-Type: application/x-git-upload-pack-advertisement
Content-Length: 493
Cache-Control: no-cache, max-age=0, must-revalidate
>>> Proxy Request:
Target:/console/rootstore.git/git-upload-pack
Headers:
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-receive-pack-result
Content-Type: application/x-git-receive-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Host: gitea.departmentofinter.net
Content-Length: 138
>>> Proxy Request Body length: 138
>>> Response Ok:
Code: 401
Reason: Unauthorized
Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: macaron_flash=; Path=/; Max-Age=0; HttpOnly; SameSite=Lax
Set-Cookie: _csrf=luUPjvQAbFIg7suxGKPyMCw-5fo6MTcwNzg4NTYwNDE1NTgyMTQzMg; Path=/; Expires=Thu, 15 Feb 2024 04:40:04 GMT; HttpOnly; SameSite=Lax
Set-Cookie: i_like_gitea=0ce470d76f806db3; Path=/; HttpOnly; SameSite=Lax
Date: Wed, 14 Feb 2024 04:40:04 GMT
Content-Length: 0
Cache-Control: no-store, no-transform
>>> Proxy Request:
Target:/console/rootstore.git/git-upload-pack
Headers:
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-receive-pack-result
Content-Type: application/x-git-receive-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Host: gitea.departmentofinter.net
Content-Length: 138
>>> Proxy Request Body length: 138
>>> Response Ok:
Code: 401
Reason: Unauthorized
Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: macaron_flash=; Path=/; Max-Age=0; HttpOnly; SameSite=Lax
Set-Cookie: _csrf=3YQlQofulzTt1HGj63HWwi_ZUiE6MTcwNzg4NTYwNTE5NzQ3NDE5OA; Path=/; Expires=Thu, 15 Feb 2024 04:40:05 GMT; HttpOnly; SameSite=Lax
Set-Cookie: i_like_gitea=9e96683a834cc04e; Path=/; HttpOnly; SameSite=Lax
Date: Wed, 14 Feb 2024 04:40:05 GMT
Content-Length: 0
Cache-Control: no-store, no-transform
>>> Proxy Request:
Target:/console/rootstore.git/git-upload-pack
Headers:
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-receive-pack-result
Content-Type: application/x-git-receive-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Host: gitea.departmentofinter.net
Content-Length: 138
>>> Proxy Request Body length: 138
>>> Response Ok:
Code: 401
Reason: Unauthorized
Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: macaron_flash=; Path=/; Max-Age=0; HttpOnly; SameSite=Lax
Set-Cookie: _csrf=diinSAVNEPgvhLYFkvoHo04NZt46MTcwNzg4NTYwNjAxNTEyMzg1NA; Path=/; Expires=Thu, 15 Feb 2024 04:40:06 GMT; HttpOnly; SameSite=Lax
Set-Cookie: i_like_gitea=f1eff7cbc8df2543; Path=/; HttpOnly; SameSite=Lax
Date: Wed, 14 Feb 2024 04:40:06 GMT
Content-Length: 0
Cache-Control: no-store, no-transform
>>> Proxy Request:
Target:/console/rootstore.git/git-upload-pack
Headers:
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-receive-pack-result
Content-Type: application/x-git-receive-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Host: gitea.departmentofinter.net
Content-Length: 138
>>> Proxy Request Body length: 138
>>> Response Ok:
Code: 401
Reason: Unauthorized
Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: macaron_flash=; Path=/; Max-Age=0; HttpOnly; SameSite=Lax
Set-Cookie: _csrf=PL2iwGpSxbMejEJrRoUw2bp1A1o6MTcwNzg4NTYwNzAzNjA2NzkzOQ; Path=/; Expires=Thu, 15 Feb 2024 04:40:07 GMT; HttpOnly; SameSite=Lax
Set-Cookie: i_like_gitea=0312f66d875208a7; Path=/; HttpOnly; SameSite=Lax
Date: Wed, 14 Feb 2024 04:40:07 GMT
Content-Length: 0
Cache-Control: no-store, no-transform
>>> Proxy Request:
Target:/console/rootstore.git/git-upload-pack
Headers:
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-receive-pack-result
Content-Type: application/x-git-receive-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Host: gitea.departmentofinter.net
Content-Length: 138
>>> Proxy Request Body length: 138
>>> Response Ok:
Code: 401
Reason: Unauthorized
Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: macaron_flash=; Path=/; Max-Age=0; HttpOnly; SameSite=Lax
Set-Cookie: _csrf=CdyLzLuA0n8vZ7X9VIfg9GeInuY6MTcwNzg4NTYwODI1NDAxODY5NA; Path=/; Expires=Thu, 15 Feb 2024 04:40:08 GMT; HttpOnly; SameSite=Lax
Set-Cookie: i_like_gitea=a8c14093c2142f60; Path=/; HttpOnly; SameSite=Lax
Date: Wed, 14 Feb 2024 04:40:08 GMT
Content-Length: 0
Cache-Control: no-store, no-transform
>>> Proxy Request:
Target:/console/rootstore.git/git-upload-pack
Headers:
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-receive-pack-result
Content-Type: application/x-git-receive-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Host: gitea.departmentofinter.net
Content-Length: 138
>>> Proxy Request Body length: 138
>>> Response Ok:
Code: 401
Reason: Unauthorized
Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: macaron_flash=; Path=/; Max-Age=0; HttpOnly; SameSite=Lax
Set-Cookie: _csrf=1dyw84Yclz2g2lVJ11gH2mmiXdU6MTcwNzg4NTYwOTgwMDAzNDUzMw; Path=/; Expires=Thu, 15 Feb 2024 04:40:09 GMT; HttpOnly; SameSite=Lax
Set-Cookie: i_like_gitea=4737119a3ab3e3bb; Path=/; HttpOnly; SameSite=Lax
Date: Wed, 14 Feb 2024 04:40:09 GMT
Content-Length: 0
Cache-Control: no-store, no-transform
>>> Proxy Request:
Target:/console/rootstore.git/git-upload-pack
Headers:
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-receive-pack-result
Content-Type: application/x-git-receive-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Host: gitea.departmentofinter.net
Content-Length: 138
>>> Proxy Request Body length: 138
>>> Response Ok:
Code: 401
Reason: Unauthorized
Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: macaron_flash=; Path=/; Max-Age=0; HttpOnly; SameSite=Lax
Set-Cookie: _csrf=ywmqqfjlqF7k5H5Oc1UCNYIXW-k6MTcwNzg4NTYxMTYzOTE0NTIyMg; Path=/; Expires=Thu, 15 Feb 2024 04:40:11 GMT; HttpOnly; SameSite=Lax
Set-Cookie: i_like_gitea=7a5d324cd756e03d; Path=/; HttpOnly; SameSite=Lax
Date: Wed, 14 Feb 2024 04:40:11 GMT
Content-Length: 0
Cache-Control: no-store, no-transform
* git clone with auth and header passthrough:
$ git clone http://cqc:d9c2b491e70e31a760ce70bc431036c91325f683@localhost:8080/console/rootstore.git
** proxy output
Listening on localhost:8080 and proxying requests via https://gitea.departmentofinter.net.
>>> Proxy Request: Target:/console/rootstore.git/info/refs?service=git-upload-pack Headers:
Git-Protocol: version=2
Pragma: no-cache
Accept-Language: en-US, *;q=0.9
Accept-Encoding: deflate, gzip, br, zstd
Accept: */*
User-Agent: git/2.43.0
Host: gitea.departmentofinter.net
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
>>> Proxy Request Body length: 4096
>>> proxy_response_body chunk: 188
>>> Response Ok: Code: 200 Reason: OK Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: _csrf=ZgQc7E7JFWSGDYWav6sgn8MiiUk6MTcwNzkzODY1NjM3Nzk0NDU0MQ; Path=/; Max-Age=86400; HttpOnly; Secure; SameSite=Lax
Set-Cookie: i_like_gitea=a62763108ab0c487; Path=/; HttpOnly; Secure; SameSite=Lax
Pragma: no-cache
Expires: Fri, 01 Jan 1980 00:00:00 GMT
Date: Wed, 14 Feb 2024 19:24:16 GMT
Content-Type: application/x-git-upload-pack-advertisement
Content-Length: 188
Cache-Control: no-cache, max-age=0, must-revalidate
>>> Proxy Request: Target:/console/rootstore.git/git-upload-pack Headers:
Content-Length: 175
Git-Protocol: version=2
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-upload-pack-result
Content-Type: application/x-git-upload-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Host: gitea.departmentofinter.net
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
>>> Proxy Request Body length: 175
>>> proxy_response_body chunk: 213
>>> Response Ok: Code: 200 Reason: OK Headers:
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: _csrf=7eT7vE683qPwLD-J7frOHX7L5W46MTcwNzkzODY1NzM1MDY3OTkzMw; Path=/; Max-Age=86400; HttpOnly; Secure; SameSite=Lax
Set-Cookie: i_like_gitea=b6bc4d03cd65fa36; Path=/; HttpOnly; Secure; SameSite=Lax
Date: Wed, 14 Feb 2024 19:24:17 GMT
Content-Type: application/x-git-upload-pack-result
Content-Length: 213
Cache-Control: max-age=0, private, must-revalidate, no-transform
>>> Proxy Request: Target:/console/rootstore.git/git-upload-pack Headers:
Content-Length: 252
Git-Protocol: version=2
Accept-Language: en-US, *;q=0.9
Accept: application/x-git-upload-pack-result
Content-Type: application/x-git-upload-pack-request
Accept-Encoding: deflate, gzip, br, zstd
User-Agent: git/2.43.0
Host: gitea.departmentofinter.net
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
>>> Proxy Request Body length: 252
>>> proxy_response_body chunk: 2190
>>> Response Ok: Code: 200 Reason: OK Headers:
Transfer-Encoding: chunked
Connection: close
X-Frame-Options: SAMEORIGIN
Set-Cookie: _csrf=7zYyIH5ErnK__EuiA2LfWYhl1Ck6MTcwNzkzODY1ODQ5ODM1NTM5NQ; Path=/; Max-Age=86400; HttpOnly; Secure; SameSite=Lax
Set-Cookie: i_like_gitea=85c4349ce30af2db; Path=/; HttpOnly; Secure; SameSite=Lax
Date: Wed, 14 Feb 2024 19:24:18 GMT
Content-Type: application/x-git-upload-pack-result
Cache-Control: max-age=0, private, must-revalidate, no-transform
* page
** proxy output
Listening on localhost:8080 and proxying requests via https://gitea.departmentofinter.net.
>>> Response with File:
Headers:
accept-ranges: bytes
access-control-allow-origin: *
access-control-allow-headers: Origin, X-Requested-With, Content-Type, Accept, Range
cache-control: no-cache, no-store, must-revalidate
etag: W/"6861266-5562-2024-02-11T19:05:04.733Z"
content-type: text/html; charset=UTF-8
connection: close
content-length: 5562
.5562
done>>> Proxy Request: Target:/_build/default/exported-unit.cmis.js Headers:
Sec-Fetch-Site: same-origin
Sec-Fetch-Mode: no-cors
Sec-Fetch-Dest: script
Cookie: i_like_gitea=4330f9e9bd8bd263; sessionid-VE347=a4WRuzgo5sDNscftfkoCXA9DVXUsuczK; CSRF-Token-VE347=t9zNXpugSSaH5byHNURnDXgxgLKMSSG6; CSRF-Token-VE347TS=UrWFFVX6Hn2iMc7yPKN6iMRXstxvZLjy; sessionid-VE347TS=x65FJhzkSk5xnz4SsGfZiRhqAvccsjiY; redirect_to=%2Fconsole%2Frootstore.git; _csrf=YmG2q0xEtZeOhjqW--KKWkXxkBI6MTcwNzkzODYwMTU5Mzg5NTAxNQ
Referer: http://localhost:8080/_build/default/index.html
Connection: keep-alive
DNT: 1
Accept-Encoding: gzip, deflate, br
Accept-Language: en-US,en;q=0.5
Accept: */*
User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:122.0) Gecko/20100101 Firefox/122.0
Host: gitea.departmentofinter.net
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
>>> Proxy Request Body length: 4096
>>> Response with File:
Headers:
accept-ranges: bytes
access-control-allow-origin: *
access-control-allow-headers: Origin, X-Requested-With, Content-Type, Accept, Range
cache-control: no-cache, no-store, must-revalidate
etag: W/"6861266-5562-2024-02-11T19:05:04.733Z"
content-type: text/html; charset=UTF-8
connection: close
content-length: 76224847
>>> proxy_response_body chunk: 11
>>> Response Ok: Code: 404 Reason: Not Found Headers:
X-Frame-Options: SAMEORIGIN
X-Content-Type-Options: nosniff
Date: Wed, 14 Feb 2024 19:25:27 GMT
Content-Type: text/plain;charset=utf-8
Content-Length: 11
Cache-Control: max-age=0, private, must-revalidate, no-transform
.76224847
done>>> Proxy Request: Target:/console/rootstore.git/info/refs?service=git-upload-pack Headers:
Sec-Fetch-Site: same-origin
Sec-Fetch-Mode: cors
Sec-Fetch-Dest: empty
Cookie: i_like_gitea=4330f9e9bd8bd263; sessionid-VE347=a4WRuzgo5sDNscftfkoCXA9DVXUsuczK; CSRF-Token-VE347=t9zNXpugSSaH5byHNURnDXgxgLKMSSG6; CSRF-Token-VE347TS=UrWFFVX6Hn2iMc7yPKN6iMRXstxvZLjy; sessionid-VE347TS=x65FJhzkSk5xnz4SsGfZiRhqAvccsjiY; redirect_to=%2Fconsole%2Frootstore.git; _csrf=YmG2q0xEtZeOhjqW--KKWkXxkBI6MTcwNzkzODYwMTU5Mzg5NTAxNQ
Referer: http://localhost:8080/_build/default/index.html
Connection: keep-alive
DNT: 1
git-protocol: version=1
content-type: application/x-git-upload-pack-request, application/x-git-upload-pack-request
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Accept-Encoding: gzip, deflate, br
Accept-Language: en-US,en;q=0.5
Accept: application/x-git-upload-pack-result
User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:122.0) Gecko/20100101 Firefox/122.0
Host: gitea.departmentofinter.net
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
>>> Proxy Request Body length: 4096
>>> proxy_response_body chunk: 507
>>> Response Ok: Code: 200 Reason: OK Headers:
X-Frame-Options: SAMEORIGIN
Pragma: no-cache
Expires: Fri, 01 Jan 1980 00:00:00 GMT
Date: Wed, 14 Feb 2024 19:25:37 GMT
Content-Type: application/x-git-upload-pack-advertisement
Content-Length: 507
Cache-Control: no-cache, max-age=0, must-revalidate
>>> Proxy Request: Target:/console/rootstore.git/git-upload-pack Headers:
Sec-Fetch-Site: same-origin
Sec-Fetch-Mode: cors
Sec-Fetch-Dest: empty
Cookie: i_like_gitea=4330f9e9bd8bd263; sessionid-VE347=a4WRuzgo5sDNscftfkoCXA9DVXUsuczK; CSRF-Token-VE347=t9zNXpugSSaH5byHNURnDXgxgLKMSSG6; CSRF-Token-VE347TS=UrWFFVX6Hn2iMc7yPKN6iMRXstxvZLjy; sessionid-VE347TS=x65FJhzkSk5xnz4SsGfZiRhqAvccsjiY; redirect_to=%2Fconsole%2Frootstore.git; _csrf=YmG2q0xEtZeOhjqW--KKWkXxkBI6MTcwNzkzODYwMTU5Mzg5NTAxNQ
Referer: http://localhost:8080/_build/default/index.html
Connection: keep-alive
DNT: 1
origin: https://gitea.departmentofinter.net
Content-Length: 138
git-protocol: version=1
content-type: application/x-git-upload-pack-request, application/x-git-upload-pack-request
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Accept-Encoding: gzip, deflate, br
Accept-Language: en-US,en;q=0.5
Accept: application/x-git-upload-pack-result
User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:122.0) Gecko/20100101 Firefox/122.0
Host: gitea.departmentofinter.net
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
>>> Proxy Request Body length: 138
>>> Response Ok: Code: 401 Reason: Unauthorized Headers:
X-Frame-Options: SAMEORIGIN
Date: Wed, 14 Feb 2024 19:25:41 GMT
Content-Length: 0
Cache-Control: max-age=0, private, must-revalidate, no-transform
>>> Proxy Request: Target:/console/rootstore.git/git-upload-pack Headers:
Sec-Fetch-Site: same-origin
Sec-Fetch-Mode: cors
Sec-Fetch-Dest: empty
Cookie: i_like_gitea=4330f9e9bd8bd263; sessionid-VE347=a4WRuzgo5sDNscftfkoCXA9DVXUsuczK; CSRF-Token-VE347=t9zNXpugSSaH5byHNURnDXgxgLKMSSG6; CSRF-Token-VE347TS=UrWFFVX6Hn2iMc7yPKN6iMRXstxvZLjy; sessionid-VE347TS=x65FJhzkSk5xnz4SsGfZiRhqAvccsjiY; redirect_to=%2Fconsole%2Frootstore.git; _csrf=YmG2q0xEtZeOhjqW--KKWkXxkBI6MTcwNzkzODYwMTU5Mzg5NTAxNQ
Referer: http://localhost:8080/_build/default/index.html
Connection: keep-alive
DNT: 1
origin: https://gitea.departmentofinter.net
Content-Length: 138
git-protocol: version=1
content-type: application/x-git-upload-pack-request, application/x-git-upload-pack-request
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Accept-Encoding: gzip, deflate, br
Accept-Language: en-US,en;q=0.5
Accept: application/x-git-upload-pack-result
User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:122.0) Gecko/20100101 Firefox/122.0
Host: gitea.departmentofinter.net
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
>>> Proxy Request Body length: 138
>>> Response Ok: Code: 401 Reason: Unauthorized Headers:
X-Frame-Options: SAMEORIGIN
Date: Wed, 14 Feb 2024 19:25:43 GMT
Content-Length: 0
Cache-Control: max-age=0, private, must-revalidate, no-transform
>>> Proxy Request: Target:/console/rootstore.git/git-upload-pack Headers:
Sec-Fetch-Site: same-origin
Sec-Fetch-Mode: cors
Sec-Fetch-Dest: empty
Cookie: i_like_gitea=4330f9e9bd8bd263; sessionid-VE347=a4WRuzgo5sDNscftfkoCXA9DVXUsuczK; CSRF-Token-VE347=t9zNXpugSSaH5byHNURnDXgxgLKMSSG6; CSRF-Token-VE347TS=UrWFFVX6Hn2iMc7yPKN6iMRXstxvZLjy; sessionid-VE347TS=x65FJhzkSk5xnz4SsGfZiRhqAvccsjiY; redirect_to=%2Fconsole%2Frootstore.git; _csrf=YmG2q0xEtZeOhjqW--KKWkXxkBI6MTcwNzkzODYwMTU5Mzg5NTAxNQ
Referer: http://localhost:8080/_build/default/index.html
Connection: keep-alive
DNT: 1
origin: https://gitea.departmentofinter.net
Content-Length: 138
git-protocol: version=1
content-type: application/x-git-upload-pack-request, application/x-git-upload-pack-request
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Accept-Encoding: gzip, deflate, br
Accept-Language: en-US,en;q=0.5
Accept: application/x-git-upload-pack-result
User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:122.0) Gecko/20100101 Firefox/122.0
Host: gitea.departmentofinter.net
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
>>> Proxy Request Body length: 138
>>> Response Ok: Code: 401 Reason: Unauthorized Headers:
X-Frame-Options: SAMEORIGIN
Date: Wed, 14 Feb 2024 19:25:44 GMT
Content-Length: 0
Cache-Control: max-age=0, private, must-revalidate, no-transform
>>> Proxy Request: Target:/console/rootstore.git/git-upload-pack Headers:
Sec-Fetch-Site: same-origin
Sec-Fetch-Mode: cors
Sec-Fetch-Dest: empty
Cookie: i_like_gitea=4330f9e9bd8bd263; sessionid-VE347=a4WRuzgo5sDNscftfkoCXA9DVXUsuczK; CSRF-Token-VE347=t9zNXpugSSaH5byHNURnDXgxgLKMSSG6; CSRF-Token-VE347TS=UrWFFVX6Hn2iMc7yPKN6iMRXstxvZLjy; sessionid-VE347TS=x65FJhzkSk5xnz4SsGfZiRhqAvccsjiY; redirect_to=%2Fconsole%2Frootstore.git; _csrf=YmG2q0xEtZeOhjqW--KKWkXxkBI6MTcwNzkzODYwMTU5Mzg5NTAxNQ
Referer: http://localhost:8080/_build/default/index.html
Connection: keep-alive
DNT: 1
origin: https://gitea.departmentofinter.net
Content-Length: 138
git-protocol: version=1
content-type: application/x-git-upload-pack-request, application/x-git-upload-pack-request
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
Accept-Encoding: gzip, deflate, br
Accept-Language: en-US,en;q=0.5
Accept: application/x-git-upload-pack-result
User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:122.0) Gecko/20100101 Firefox/122.0
Host: gitea.departmentofinter.net
Authorization: Basic Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=
>>> Proxy Request Body length: 138
C-c C-c
[cqc@fynn oplevel]$

View File

@ -1,3 +0,0 @@
let indent s _in_lines = s
(* ocp-indent not available *)

68
oplevel.ml Normal file
View File

@ -0,0 +1,68 @@
open Js_of_ocaml
open Js_of_ocaml_tyxml
open Lwt
open Store
let by_id s = Dom_html.getElementById s
let by_id_coerce s f =
Js.Opt.get
(f (Dom_html.getElementById s))
(fun () -> raise Not_found)
let do_by_id s f =
try f (Dom_html.getElementById s) with Not_found -> ()
let resize ~container ~textbox () =
Lwt.pause () >>= fun () ->
textbox##.style##.height := Js.string "auto";
textbox##.style##.height
:= Js.string (Printf.sprintf "%dpx" (max 18 textbox##.scrollHeight));
container##.scrollTop := container##.scrollHeight;
Lwt.return ()
let setup_storeview ~container ~textbox ~(storeview : Store.t Lwt.t) :
unit =
let storeview_container = by_id "toplevel-storeview" in
Lwt.async (fun _ ->
storeview >>= fun storeview ->
Firebug.console##log "setup_storeview";
Store.S.Tree.list storeview [] >>= fun all ->
ignore
(List.fold_left
(fun acc tok ->
match tok with
| step, _tree ->
let a =
Tyxml_js.Html.(
a
~a:
[
a_class [ "list-group-item" ];
a_onclick (fun _ ->
textbox##.value :=
(Js.string acc)##trim;
Lwt.async (fun () ->
resize ~container ~textbox ()
>>= fun () ->
textbox##focus;
Lwt.return_unit);
true);
]
[ txt step ])
in
Dom.appendChild storeview_container
(Tyxml_js.To_dom.of_a a);
"")
"" all);
Lwt.return_unit)
let _ =
Dom_html.window##.onload
:= Dom_html.handler (fun _ ->
Toplevel.run
(setup_storeview ~storeview:(Store.test_pull ()))
();
Js._false)

View File

@ -1 +0,0 @@
let init () = ()

382
store.ml Normal file
View File

@ -0,0 +1,382 @@
open Js_of_ocaml
open Lwt.Infix
module F = Fmt
module Cohttp_backend = Cohttp_lwt_jsoo
module Git_af = struct
open Lwt.Infix
type error = |
let git_af_scheme : [ `HTTP | `HTTPS ] Mimic.value =
Mimic.make ~name:"git-af-scheme"
let git_af_port : int Mimic.value = Mimic.make ~name:"git-af-port"
let git_af_hostname : string Mimic.value =
Mimic.make ~name:"git-af-hostname"
let pp_error : error Fmt.t = fun _ppf -> function _ -> .
let with_redirects ?(max = 10) ~f uri =
if max < 10 then invalid_arg "with_redirects";
let tbl = Hashtbl.create 0x10 in
let rec go max uri =
f uri >>= fun (resp, body) ->
let status_code =
Cohttp.(Response.status resp |> Code.code_of_status)
in
if Cohttp.Code.is_redirection status_code then
match
Cohttp.(Response.headers resp |> Header.get_location)
with
| Some uri' when Hashtbl.mem tbl uri' || max = 0 ->
Lwt.return (resp, body)
| Some uri' ->
Hashtbl.add tbl uri' ();
Cohttp_lwt.Body.drain_body body >>= fun () ->
go (pred max) uri'
| None -> Lwt.return (resp, body)
else Lwt.return (resp, body)
in
go max uri
let get ~ctx:_ ?(headers = []) uri =
Firebug.console##log (Js.string "Git_Cohttp_console.get()\n");
let headers = Cohttp.Header.of_list headers in
let f uri = Cohttp_backend.Client.get ~headers uri in
with_redirects ~f uri >>= fun (_resp, body) ->
Cohttp_lwt.Body.to_string body >>= fun body ->
Lwt.return_ok ((), body)
let post ~ctx:_ ?(headers = []) uri body =
let headers = Cohttp.Header.of_list headers in
let body = Cohttp_lwt.Body.of_string body in
let f uri =
Cohttp_backend.Client.post ~headers ~chunked:false ~body uri
in
with_redirects ~f uri >>= fun (_resp, body) ->
Cohttp_lwt.Body.to_string body >>= fun body ->
Lwt.return_ok ((), body)
end
module Git_console_http = struct
open Lwt.Infix
let context ctx =
(* HTTP *)
let edn = Mimic.make ~name:"af-http-endpoint" in
let k1 git_af_scheme git_af_hostname git_af_port =
match git_af_scheme with
| `HTTP -> Lwt.return_some (git_af_hostname, git_af_port)
| _ -> Lwt.return_none
in
let ctx =
Mimic.fold edn
Mimic.Fun.
[
req Git_af.git_af_scheme;
req Git_af.git_af_hostname;
dft Git_af.git_af_port 80;
]
~k:k1 ctx
in
(* HTTPS *)
let edn = Mimic.make ~name:"af-https-endpoint" in
let k1 git_af_scheme git_af_hostname git_af_port =
match git_af_scheme with
| `HTTPS -> Lwt.return_some (git_af_hostname, git_af_port)
| _ -> Lwt.return_none
in
let ctx =
Mimic.fold edn
Mimic.Fun.
[
req Git_af.git_af_scheme;
req Git_af.git_af_hostname;
dft Git_af.git_af_port 443;
]
~k:k1 ctx
in
ctx
module HTTP = struct
type state =
| Handshake
| Get of {
advertised_refs : string;
uri : Uri.t;
headers : (string * string) list;
ctx : Mimic.ctx;
}
| Post of {
mutable output : string;
uri : Uri.t;
headers : (string * string) list;
ctx : Mimic.ctx;
}
| Error
type flow = { endpoint : Uri.t; mutable state : state }
type error = [ `Msg of string ]
type write_error = [ `Closed | `Msg of string ]
let pp_error ppf (`Msg err) = Fmt.string ppf err
let pp_write_error ppf = function
| `Closed -> Fmt.string ppf "Connection closed by peer"
| `Msg err -> Fmt.string ppf err
let write t cs =
match t.state with
| Handshake | Get _ ->
Lwt.return_error (`Msg "Handshake has not been done")
| Error -> Lwt.return_error (`Msg "Handshake got an error")
| Post ({ output; _ } as v) ->
let output = output ^ Cstruct.to_string cs in
v.output <- output;
Lwt.return_ok ()
let writev t css =
let rec go = function
| [] -> Lwt.return_ok ()
| x :: r -> (
write t x >>= function
| Ok () -> go r
| Error _ as err -> Lwt.return err)
in
go css
let read t =
match t.state with
| Handshake ->
Lwt.return_error (`Msg "Handshake has not been done")
| Error -> Lwt.return_error (`Msg "Handshake got an error")
| Get { advertised_refs; uri; headers; ctx } ->
t.state <- Post { output = ""; uri; headers; ctx };
Lwt.return_ok (`Data (Cstruct.of_string advertised_refs))
| Post { output; uri; headers; ctx } -> (
Git_af.post ~ctx ~headers uri output >>= function
| Ok (_resp, contents) ->
Lwt.return_ok (`Data (Cstruct.of_string contents))
| Error err ->
Lwt.return_error
(`Msg (Fmt.str "%a" Git_af.pp_error err)))
let close _ = Lwt.return_unit
type endpoint = Uri.t
let connect endpoint =
Firebug.console##log
(Js.string "Git_Console_http.HTTP.connect()\n");
Lwt.return_ok { endpoint; state = Handshake }
end
let http_endpoint, http_protocol =
Mimic.register ~name:"http" (module HTTP)
let connect (ctx : Mimic.ctx) =
Firebug.console##log (Js.string "Git_Console_http.connect()\n");
let module T = (val Mimic.repr http_protocol) in
let edn = Mimic.make ~name:"http-endpoint" in
let k0 uri = Lwt.return_some uri in
let k1 git_transmission git_scheme =
match (git_transmission, git_scheme) with
| `HTTP (uri, _), (`HTTP | `HTTPS) -> Lwt.return_some uri
| _ -> Lwt.return_none
in
let k2 git_scheme git_uri git_http_headers =
match git_scheme with
| `Git | `SSH | `Scheme _ -> Lwt.return_none
| `HTTP | `HTTPS ->
let headers =
("content-type", "application/x-git-upload-pack-request")
:: git_http_headers
in
let handshake ~uri0 ~uri1 = function
| T.T flow -> (
Firebug.console##log
(Js.string
(F.str
"Git_Console_http.connect.k2.handshake \
uri0='%s' uri1='%s'\n"
(Uri.to_string uri0) (Uri.to_string uri1)));
let ctx = context Mimic.empty in
Git_af.get ~ctx ~headers uri0 >>= function
| Ok (_resp, advertised_refs) ->
flow.state <-
HTTP.Get
{ advertised_refs; uri = uri1; headers; ctx };
Lwt.return_unit
| Error _ ->
flow.state <- Error;
Lwt.return_unit)
| _ -> Lwt.return_unit
in
let git_transmission = `HTTP (git_uri, handshake) in
Lwt.return_some git_transmission
in
let ctx =
Mimic.fold http_endpoint Mimic.Fun.[ req edn ] ~k:k0 ctx
in
let ctx =
Mimic.fold edn
Mimic.Fun.
[ req Smart_git.git_transmission; req Smart_git.git_scheme ]
~k:k1 ctx
in
let ctx =
Mimic.fold Smart_git.git_transmission
Mimic.Fun.
[
req Smart_git.git_scheme;
req Smart_git.git_uri;
dft Smart_git.git_http_headers List.[];
]
~k:k2 ctx
in
Lwt.return ctx
end
module Config = struct
open Irmin.Backend.Conf
let spec = Spec.v "console_js_git"
module Key = struct
let reference : Git.Reference.t Irmin.Type.t =
let of_string str =
Git.Reference.of_string str |> Result.get_ok
in
let to_string r = Git.Reference.to_string r in
Irmin.Type.(map string) of_string to_string
let head =
key ~spec ~doc:"The main branch of the Git repository." "head"
Irmin.Type.(option reference)
None
let bare =
key ~spec ~doc:"Do not expand the filesystem on the disk."
"bare" Irmin.Type.bool false
let level =
key ~spec ~doc:"The Zlib compression level." "level"
Irmin.Type.(option int)
None
let buffers =
key ~spec ~doc:"The number of 4K pre-allocated buffers."
"buffers"
Irmin.Type.(option int)
None
end
let init ?head ?level ?buffers _root =
let module C = Irmin.Backend.Conf in
let config = C.empty spec in
let config = C.add config Key.head head in
let config = C.add config Key.level level in
let config = C.add config Key.buffers buffers in
C.verify config
end
module S = struct
module Schema =
Irmin_git.Schema.Make (Git.Mem.Store) (Irmin.Contents.String)
(Irmin_git.Branch.Make (Irmin.Branch.String))
module Sync' = struct
module GitMemSync = Git.Mem.Sync (Git.Mem.Store)
include GitMemSync
(* This is where the fetch and push are broken *)
end
module SMaker = Irmin_git.Maker (Git.Mem.Store) (Sync')
module SMade = SMaker.Make (Schema)
include SMade
type endpoint = Mimic.ctx * Smart_git.Endpoint.t
let remote ?(ctx = Mimic.empty) ?headers uri =
E
(Firebug.console##log
(Js.string (F.str "Nav.S.remote(uri=%s)\n" uri));
let ( ! ) f a b = f b a in
match Smart_git.Endpoint.of_string uri with
| Ok edn ->
let edn =
Option.fold ~none:edn
~some:(!Smart_git.Endpoint.with_headers_if_http edn)
headers
in
Firebug.console##log
(Js.string "Nav.S.remote() = (ctx, edn) \n");
(ctx, edn)
| Error (`Msg err) -> Fmt.invalid_arg "remote: %s" err)
module Backend = struct
include Backend
module R = Remote
module Remote = struct
include R
type endpoint = Mimic.ctx * Smart_git.Endpoint.t
let ctx e = fst e
let edn e = snd e
let fetch t ?depth endpoint branch =
Firebug.console##log
(Js.string "S.Backend.Remote.wrapped_fetch()\n");
R.fetch t ?depth endpoint branch
end
end
end
module Sync = Irmin.Sync.Make (S)
type t = S.tree
type tree = t
type step = S.step
type path = step list
let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
let test_populate () : t Lwt.t =
let add p s t = S.Tree.add t p s in
add [ "hello" ] "world" (S.Tree.empty ())
>>= add [ "hello"; "daddy" ] "ily"
>>= add [ "beep"; "beep" ] "motherfucker"
let test_pull () : t Lwt.t =
(* test_populate ()*)
Firebug.console##log (Js.string "Nav.test_pull()\n");
S.Repo.v (Config.init "") >>= fun repo ->
Firebug.console##log (Js.string "Nav.test_pull(2)\n");
S.of_branch repo "current" >>= fun t ->
Firebug.console##log (Js.string "Nav.test_pull(3)\n");
Git_console_http.connect Mimic.empty >>= fun ctx ->
Firebug.console##log (Js.string "Nav.test_pull(4)\n");
let upstream =
S.remote ~ctx
~headers:
[
( "Authorization",
"Basic \
Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM="
);
]
"http://localhost:8080/console/rootstore.git"
in
Firebug.console##log (Js.string "Nav.test_pull(5)\n");
Sync.pull_exn t upstream `Set >>= fun _ ->
Firebug.console##log (Js.string "Nav.test_pull(6)\n");
S.tree t
(* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)

View File

@ -23,27 +23,30 @@ open Js_of_ocaml_lwt
open Js_of_ocaml_tyxml
open Js_of_ocaml_toplevel
open Lwt
open Store
let compiler_name = "OCaml"
let by_id s = Dom_html.getElementById s
let by_id_coerce s f =
Js.Opt.get (f (Dom_html.getElementById s)) (fun () -> raise Not_found)
Js.Opt.get
(f (Dom_html.getElementById s))
(fun () -> raise Not_found)
let do_by_id s f = try f (Dom_html.getElementById s) with Not_found -> ()
let do_by_id s f =
try f (Dom_html.getElementById s) with Not_found -> ()
(* load file using a synchronous XMLHttpRequest *)
let load_resource_aux filename url =
Js_of_ocaml_lwt.XmlHttpRequest.perform_raw ~response_type:XmlHttpRequest.ArrayBuffer url
Js_of_ocaml_lwt.XmlHttpRequest.perform_raw
~response_type:XmlHttpRequest.ArrayBuffer url
>|= fun frame ->
if frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200
then
Js.Opt.case
frame.Js_of_ocaml_lwt.XmlHttpRequest.content
if frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200 then
Js.Opt.case frame.Js_of_ocaml_lwt.XmlHttpRequest.content
(fun () -> Printf.eprintf "Could not load %s\n" filename)
(fun b ->
Sys_js.update_file ~name:filename ~content:(Typed_array.String.of_arrayBuffer b))
Sys_js.update_file ~name:filename
~content:(Typed_array.String.of_arrayBuffer b))
else ()
let load_resource scheme ~prefix ~path:suffix =
@ -57,7 +60,8 @@ let setup_pseudo_fs ~load_cmis_from_server =
Sys_js.mount ~path:"/http/" (load_resource "http://");
Sys_js.mount ~path:"/https/" (load_resource "https://");
Sys_js.mount ~path:"/ftp/" (load_resource "ftp://");
if load_cmis_from_server then Sys_js.mount ~path:"/home/" (load_resource "filesys/")
if load_cmis_from_server then
Sys_js.mount ~path:"/home/" (load_resource "filesys/")
let exec' s =
let res : bool = JsooTop.use Format.std_formatter s in
@ -69,10 +73,10 @@ module Version = struct
let split_char ~sep p =
let len = String.length p in
let rec split beg cur =
if cur >= len
then if cur - beg > 0 then [ String.sub p beg (cur - beg) ] else []
else if sep p.[cur]
then String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
if cur >= len then
if cur - beg > 0 then [ String.sub p beg (cur - beg) ] else []
else if sep p.[cur] then
String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
else split beg (cur + 1)
in
split 0 0
@ -80,68 +84,67 @@ module Version = struct
let split v =
match
split_char
~sep:(function
| '+' | '-' | '~' -> true
| _ -> false)
~sep:(function '+' | '-' | '~' -> true | _ -> false)
v
with
| [] -> assert false
| x :: _ ->
List.map
int_of_string
(split_char
~sep:(function
| '.' -> true
| _ -> false)
x)
List.map int_of_string
(split_char ~sep:(function '.' -> true | _ -> false) x)
let current : t = split Sys.ocaml_version
let compint (a : int) b = compare a b
let rec compare v v' =
match v, v' with
match (v, v') with
| [ x ], [ y ] -> compint x y
| [], [] -> 0
| [], y :: _ -> compint 0 y
| x :: _, [] -> compint x 0
| x :: xs, y :: ys -> (
match compint x y with
| 0 -> compare xs ys
| n -> n)
match compint x y with 0 -> compare xs ys | n -> n)
end
let setup_toplevel () =
Clflags.debug := true;
JsooTop.initialize ();
Sys.interactive := false;
if Version.compare Version.current [ 4; 07 ] >= 0 then exec' "open Stdlib";
if Version.compare Version.current [ 4; 07 ] >= 0 then
exec' "open Stdlib";
exec'
"module Lwt_main = struct\n\
\ let run t = match Lwt.state t with\n\
\ | Lwt.Return x -> x\n\
\ | Lwt.Fail e -> raise e\n\
\ | Lwt.Sleep -> failwith \"Lwt_main.run: thread didn't return\"\n\
\ | Lwt.Sleep -> failwith \"Lwt_main.run: thread didn't \
return\"\n\
\ end";
let header1 = Printf.sprintf " %s version %%s" compiler_name in
let header2 =
Printf.sprintf " Compiled with Js_of_ocaml version %s" Sys_js.js_of_ocaml_version
let header1 =
Printf.sprintf " %s version %%s" compiler_name
in
exec' (Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;" header1);
let header2 =
Printf.sprintf " Compiled with Js_of_ocaml version %s"
Sys_js.js_of_ocaml_version
in
exec'
(Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;"
header1);
exec' (Printf.sprintf "Format.printf \"%s@.\";;" header2);
exec' "#enable \"pretty\";;";
exec' "#disable \"shortvar\";;";
Ppx_support.init ();
Toploop.add_directive
"load_js"
(Toploop.Directive_string (fun name -> Js.Unsafe.global##load_script_ name))
{ section = "js_of_ocaml-toplevel-example"; doc = "Load the given javascript file" };
Toploop.add_directive "load_js"
(Toploop.Directive_string
(fun name -> Js.Unsafe.global##load_script_ name))
{
section = "js_of_ocaml-toplevel-example";
doc = "Load the given javascript file";
};
Sys.interactive := true;
()
let resize ~container ~textbox () =
Lwt.pause ()
>>= fun () ->
Lwt.pause () >>= fun () ->
textbox##.style##.height := Js.string "auto";
textbox##.style##.height
:= Js.string (Printf.sprintf "%dpx" (max 18 textbox##.scrollHeight));
@ -150,11 +153,15 @@ let resize ~container ~textbox () =
let setup_printers () =
exec'
"let _print_error fmt e = Format.pp_print_string fmt (Js_of_ocaml.Js_error.to_string \
e)";
Topdirs.dir_install_printer Format.std_formatter Longident.(Lident "_print_error");
exec' "let _print_unit fmt (_ : 'a) : 'a = Format.pp_print_string fmt \"()\"";
Topdirs.dir_install_printer Format.std_formatter Longident.(Lident "_print_unit")
"let _print_error fmt e = Format.pp_print_string fmt \
(Js_of_ocaml.Js_error.to_string e)";
Topdirs.dir_install_printer Format.std_formatter
Longident.(Lident "_print_error");
exec'
"let _print_unit fmt (_ : 'a) : 'a = Format.pp_print_string fmt \
\"()\"";
Topdirs.dir_install_printer Format.std_formatter
Longident.(Lident "_print_unit")
let setup_examples ~container ~textbox =
let r = Regexp.regexp "^\\(\\*+(.*)\\*+\\)$" in
@ -186,22 +193,22 @@ let setup_examples ~container ~textbox =
Tyxml_js.Html.(
a
~a:
[ a_class [ "list-group-item" ]
; a_onclick (fun _ ->
[
a_class [ "list-group-item" ];
a_onclick (fun _ ->
textbox##.value := (Js.string acc)##trim;
Lwt.async (fun () ->
resize ~container ~textbox ()
>>= fun () ->
textbox##focus;
Lwt.return_unit);
true)
true);
]
[ txt name ])
in
Dom.appendChild example_container (Tyxml_js.To_dom.of_a a);
"")
""
!all
"" !all
in
()
@ -213,7 +220,8 @@ let parse_hash () =
let rec iter_on_sharp ~f x =
Js.Opt.iter (Dom_html.CoerceTo.element x) (fun e ->
if Js.to_bool (e##.classList##contains (Js.string "sharp")) then f e);
if Js.to_bool (e##.classList##contains (Js.string "sharp")) then
f e);
match Js.Opt.to_option x##.nextSibling with
| None -> ()
| Some n -> iter_on_sharp ~f n
@ -225,44 +233,59 @@ let setup_share_button ~output =
Dom_html.handler (fun _ ->
(* get all ocaml code *)
let code = ref [] in
Js.Opt.iter
output##.firstChild
Js.Opt.iter output##.firstChild
(iter_on_sharp ~f:(fun e ->
code :=
Js.Opt.case e##.textContent (fun () -> "") Js.to_string :: !code));
let code_encoded = B64.encode (String.concat "" (List.rev !code)) in
Js.Opt.case e##.textContent
(fun () -> "")
Js.to_string
:: !code));
let code_encoded =
B64.encode (String.concat "" (List.rev !code))
in
let url, is_file =
match Url.Current.get () with
| Some (Url.Http url) -> Url.Http { url with Url.hu_fragment = "" }, false
| Some (Url.Https url) -> Url.Https { url with Url.hu_fragment = "" }, false
| Some (Url.File url) -> Url.File { url with Url.fu_fragment = "" }, true
| Some (Url.Http url) ->
(Url.Http { url with Url.hu_fragment = "" }, false)
| Some (Url.Https url) ->
(Url.Https { url with Url.hu_fragment = "" }, false)
| Some (Url.File url) ->
(Url.File { url with Url.fu_fragment = "" }, true)
| _ -> assert false
in
let frag =
let frags = parse_hash () in
let frags = List.remove_assoc "code" frags @ [ "code", code_encoded ] in
let frags =
List.remove_assoc "code" frags
@ [ ("code", code_encoded) ]
in
Url.encode_arguments frags
in
let uri = Url.string_of_url url ^ "#" ^ frag in
let append_url str =
let dom =
Tyxml_js.Html.(
p [ txt "Share this url : "; a ~a:[ a_href str ] [ txt str ] ])
p
[
txt "Share this url : ";
a ~a:[ a_href str ] [ txt str ];
])
in
Dom.appendChild output (Tyxml_js.To_dom.of_element dom)
in
Lwt.async (fun () ->
Lwt.catch
(fun () ->
if is_file
then failwith "Cannot shorten url with file scheme"
if is_file then
failwith "Cannot shorten url with file scheme"
else
let uri =
Printf.sprintf
"http://is.gd/create.php?format=json&url=%s"
(Url.urlencode uri)
in
Lwt.bind (Js_of_ocaml_lwt.Jsonp.call uri) (fun o ->
Lwt.bind (Js_of_ocaml_lwt.Jsonp.call uri)
(fun o ->
let str = Js.to_string o##.shorturl in
append_url str;
Lwt.return_unit))
@ -277,8 +300,7 @@ let setup_share_button ~output =
let setup_js_preview () =
let ph = by_id "last-js" in
let runcode : string -> 'a = Js.Unsafe.global##.toplevelEval in
Js.Unsafe.global##.toplevelEval
:= fun bc ->
Js.Unsafe.global##.toplevelEval := fun bc ->
ph##.innerHTML := Js.string bc;
runcode bc
@ -288,24 +310,29 @@ let highlight_location loc =
let x = ref 0 in
let output = by_id "output" in
let first =
Js.Opt.get (output##.childNodes##item !current_position) (fun _ -> assert false)
Js.Opt.get
(output##.childNodes##item !current_position)
(fun _ -> assert false)
in
iter_on_sharp first ~f:(fun e ->
incr x;
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
if !x >= line1 && !x <= line2
then
let _file1, line1, col1 =
Location.get_pos_info loc.Location.loc_start
in
let _file2, line2, col2 =
Location.get_pos_info loc.Location.loc_end
in
if !x >= line1 && !x <= line2 then
let from_ = if !x = line1 then `Pos col1 else `Pos 0 in
let to_ = if !x = line2 then `Pos col2 else `Last in
Colorize.highlight from_ to_ e)
let append colorize output cl s =
Dom.appendChild output (Tyxml_js.To_dom.of_element (colorize ~a_class:cl s))
Dom.appendChild output
(Tyxml_js.To_dom.of_element (colorize ~a_class:cl s))
module History = struct
let data = ref [| "" |]
let idx = ref 0
let get_storage () =
@ -341,31 +368,38 @@ module History = struct
let current text = !data.(!idx) <- text
let previous textbox =
if !idx > 0
then (
if !idx > 0 then (
decr idx;
textbox##.value := Js.string !data.(!idx))
let next textbox =
if !idx < Array.length !data - 1
then (
if !idx < Array.length !data - 1 then (
incr idx;
textbox##.value := Js.string !data.(!idx))
end
let run _ =
let run setup_storeview () =
Firebug.console##log "run";
let container = by_id "toplevel-container" in
let output = by_id "output" in
let textbox : 'a Js.t = by_id_coerce "userinput" Dom_html.CoerceTo.textarea in
let textbox : 'a Js.t =
by_id_coerce "userinput" Dom_html.CoerceTo.textarea
in
let sharp_chan = open_out "/dev/null0" in
let sharp_ppf = Format.formatter_of_out_channel sharp_chan in
let caml_chan = open_out "/dev/null1" in
let caml_ppf = Format.formatter_of_out_channel caml_chan in
Firebug.console##log "run(Store.test_pull)";
let execute () =
let content = Js.to_string textbox##.value##trim in
let content' =
let len = String.length content in
if try content <> "" && content.[len - 1] <> ';' && content.[len - 2] <> ';'
if
try
content <> ""
&& content.[len - 1] <> ';'
&& content.[len - 2] <> ';'
with _ -> true
then content ^ ";;"
else content
@ -373,9 +407,9 @@ let run _ =
current_position := output##.childNodes##.length;
textbox##.value := Js.string "";
History.push content;
JsooTop.execute true ~pp_code:sharp_ppf ~highlight_location caml_ppf content';
resize ~container ~textbox ()
>>= fun () ->
JsooTop.execute true ~pp_code:sharp_ppf ~highlight_location
caml_ppf content';
resize ~container ~textbox () >>= fun () ->
container##.scrollTop := container##.scrollHeight;
textbox##focus;
Lwt.return_unit
@ -441,32 +475,40 @@ let run _ =
| _ -> Js._true);
(Lwt.async_exception_hook :=
fun exc ->
Format.eprintf "exc during Lwt.async: %s@." (Printexc.to_string exc);
Format.eprintf "exc during Lwt.async: %s@."
(Printexc.to_string exc);
match exc with
| Js_error.Exn e ->
let e = Js_error.to_error e in
Firebug.console##log e##.stack
| _ -> ());
Lwt.async (fun () ->
resize ~container ~textbox ()
>>= fun () ->
resize ~container ~textbox () >>= fun () ->
textbox##focus;
Lwt.return_unit);
Graphics_support.init (by_id_coerce "test-canvas" Dom_html.CoerceTo.canvas);
Sys_js.set_channel_flusher caml_chan (append Colorize.ocaml output "caml");
Sys_js.set_channel_flusher sharp_chan (append Colorize.ocaml output "sharp");
Sys_js.set_channel_flusher stdout (append Colorize.text output "stdout");
Sys_js.set_channel_flusher stderr (append Colorize.text output "stderr");
Graphics_support.init
(by_id_coerce "test-canvas" Dom_html.CoerceTo.canvas);
Sys_js.set_channel_flusher caml_chan
(append Colorize.ocaml output "caml");
Sys_js.set_channel_flusher sharp_chan
(append Colorize.ocaml output "sharp");
Sys_js.set_channel_flusher stdout
(append Colorize.text output "stdout");
Sys_js.set_channel_flusher stderr
(append Colorize.text output "stderr");
let readline () =
Js.Opt.case
(Dom_html.window##prompt (Js.string "The toplevel expects inputs:") (Js.string ""))
(Dom_html.window##prompt
(Js.string "The toplevel expects inputs:")
(Js.string ""))
(fun () -> "")
(fun s -> Js.to_string s ^ "\n")
in
Sys_js.set_channel_filler stdin readline;
setup_share_button ~output;
setup_examples ~container ~textbox;
(* setup_examples ~container ~textbox; *)
setup_pseudo_fs ~load_cmis_from_server:false;
setup_storeview ~container ~textbox;
setup_toplevel ();
setup_js_preview ();
setup_printers ();
@ -480,13 +522,6 @@ let run _ =
with
| Not_found -> ()
| exc ->
Firebug.console##log_3
(Js.string "exception")
Firebug.console##log_3 (Js.string "exception")
(Js.string (Printexc.to_string exc))
exc
let _ =
Dom_html.window##.onload :=
Dom_html.handler (fun _ ->
run ();
Js._false)

11
toplevel.mli Normal file
View File

@ -0,0 +1,11 @@
open Js_of_ocaml
open Store
val run :
(container:
(* storeview:S.tree Lwt.t ->*)
Js_of_ocaml.Dom_html.element Js_of_ocaml.Js.t ->
textbox:Js_of_ocaml.Dom_html.textAreaElement Js_of_ocaml.Js.t ->
unit) ->
unit ->
unit