it worked but we couldn't figure out how to do the fucking keyboard shortcuts without patching lablgtk3 and understanding a whole bunch of c interface stuff
This commit is contained in:
cqc
2
.gitignore
vendored
2
.gitignore
vendored
@ -1,3 +1,3 @@
|
|||||||
*~
|
*~
|
||||||
_build/
|
_build/
|
||||||
gitkey.ml
|
secrets.ml
|
||||||
|
|||||||
82
b64.ml
82
b64.ml
@ -1,82 +0,0 @@
|
|||||||
(*
|
|
||||||
* Copyright (c) 2006-2009 Citrix Systems Inc.
|
|
||||||
* Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.com>
|
|
||||||
*
|
|
||||||
* Permission to use, copy, modify, and distribute this software for any
|
|
||||||
* purpose with or without fee is hereby granted, provided that the above
|
|
||||||
* copyright notice and this permission notice appear in all copies.
|
|
||||||
*
|
|
||||||
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
||||||
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
||||||
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
||||||
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
||||||
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
||||||
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
||||||
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
*
|
|
||||||
*)
|
|
||||||
|
|
||||||
let default_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
|
|
||||||
|
|
||||||
let uri_safe_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"
|
|
||||||
|
|
||||||
let padding = '='
|
|
||||||
|
|
||||||
let of_char ?(alphabet = default_alphabet) x =
|
|
||||||
if x = padding then 0 else String.index alphabet x
|
|
||||||
|
|
||||||
let to_char ?(alphabet = default_alphabet) x = alphabet.[x]
|
|
||||||
|
|
||||||
let decode ?alphabet input =
|
|
||||||
let length = String.length input in
|
|
||||||
let input =
|
|
||||||
if length mod 4 = 0 then input else input ^ String.make (4 - (length mod 4)) padding
|
|
||||||
in
|
|
||||||
let length = String.length input in
|
|
||||||
let words = length / 4 in
|
|
||||||
let padding =
|
|
||||||
match length with
|
|
||||||
| 0 -> 0
|
|
||||||
| _ when input.[length - 2] = padding -> 2
|
|
||||||
| _ when input.[length - 1] = padding -> 1
|
|
||||||
| _ -> 0
|
|
||||||
in
|
|
||||||
let output = Bytes.make ((words * 3) - padding) '\000' in
|
|
||||||
for i = 0 to words - 1 do
|
|
||||||
let a = of_char ?alphabet input.[(4 * i) + 0]
|
|
||||||
and b = of_char ?alphabet input.[(4 * i) + 1]
|
|
||||||
and c = of_char ?alphabet input.[(4 * i) + 2]
|
|
||||||
and d = of_char ?alphabet input.[(4 * i) + 3] in
|
|
||||||
let n = (a lsl 18) lor (b lsl 12) lor (c lsl 6) lor d in
|
|
||||||
let x = (n lsr 16) land 255 and y = (n lsr 8) land 255 and z = n land 255 in
|
|
||||||
Bytes.set output ((3 * i) + 0) (char_of_int x);
|
|
||||||
if i <> words - 1 || padding < 2 then Bytes.set output ((3 * i) + 1) (char_of_int y);
|
|
||||||
if i <> words - 1 || padding < 1 then Bytes.set output ((3 * i) + 2) (char_of_int z)
|
|
||||||
done;
|
|
||||||
Bytes.unsafe_to_string output
|
|
||||||
|
|
||||||
let encode ?(pad = true) ?alphabet input =
|
|
||||||
let length = String.length input in
|
|
||||||
let words = (length + 2) / 3 in
|
|
||||||
(* rounded up *)
|
|
||||||
let padding_len = if length mod 3 = 0 then 0 else 3 - (length mod 3) in
|
|
||||||
let output = Bytes.make (words * 4) '\000' in
|
|
||||||
let get i = if i >= length then 0 else int_of_char input.[i] in
|
|
||||||
for i = 0 to words - 1 do
|
|
||||||
let x = get ((3 * i) + 0) and y = get ((3 * i) + 1) and z = get ((3 * i) + 2) in
|
|
||||||
let n = (x lsl 16) lor (y lsl 8) lor z in
|
|
||||||
let a = (n lsr 18) land 63
|
|
||||||
and b = (n lsr 12) land 63
|
|
||||||
and c = (n lsr 6) land 63
|
|
||||||
and d = n land 63 in
|
|
||||||
Bytes.set output ((4 * i) + 0) (to_char ?alphabet a);
|
|
||||||
Bytes.set output ((4 * i) + 1) (to_char ?alphabet b);
|
|
||||||
Bytes.set output ((4 * i) + 2) (to_char ?alphabet c);
|
|
||||||
Bytes.set output ((4 * i) + 3) (to_char ?alphabet d)
|
|
||||||
done;
|
|
||||||
for i = 1 to padding_len do
|
|
||||||
Bytes.set output (Bytes.length output - i) padding
|
|
||||||
done;
|
|
||||||
if pad
|
|
||||||
then Bytes.unsafe_to_string output
|
|
||||||
else Bytes.sub_string output 0 (Bytes.length output - padding_len)
|
|
||||||
40
b64.mli
40
b64.mli
@ -1,40 +0,0 @@
|
|||||||
(*
|
|
||||||
* Copyright (c) 2006-2009 Citrix Systems Inc.
|
|
||||||
* Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.com>
|
|
||||||
* Copyright (c) 2014-2016 Anil Madhavapeddy <anil@recoil.org>
|
|
||||||
*
|
|
||||||
* Permission to use, copy, modify, and distribute this software for any
|
|
||||||
* purpose with or without fee is hereby granted, provided that the above
|
|
||||||
* copyright notice and this permission notice appear in all copies.
|
|
||||||
*
|
|
||||||
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
||||||
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
||||||
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
||||||
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
||||||
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
||||||
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
||||||
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
*
|
|
||||||
*)
|
|
||||||
|
|
||||||
(** Base64 RFC4648 implementation.
|
|
||||||
|
|
||||||
Base64 is a group of similar binary-to-text encoding schemes that represent binary
|
|
||||||
data in an ASCII string format by translating it into a radix-64 representation. It
|
|
||||||
is specified in RFC 4648. *)
|
|
||||||
|
|
||||||
val default_alphabet : string
|
|
||||||
(** A 64-character string specifying the regular Base64 alphabet. *)
|
|
||||||
|
|
||||||
val uri_safe_alphabet : string
|
|
||||||
(** A 64-character string specifying the URI- and filename-safe Base64 alphabet. *)
|
|
||||||
|
|
||||||
val decode : ?alphabet:string -> string -> string
|
|
||||||
(** [decode s] decodes the string [s] that is encoded in Base64 format. Will leave
|
|
||||||
trailing NULLs on the string, padding it out to a multiple of 3 characters.
|
|
||||||
[alphabet] defaults to {!default_alphabet}.
|
|
||||||
@raise Not_found if [s] is not a valid Base64 string. *)
|
|
||||||
|
|
||||||
val encode : ?pad:bool -> ?alphabet:string -> string -> string
|
|
||||||
(** [encode s] encodes the string [s] into base64. If [pad] is false, no trailing padding
|
|
||||||
is added. [pad] defaults to [true], and [alphabet] to {!default_alphabet}. *)
|
|
||||||
39
colorize.ml
39
colorize.ml
@ -1,39 +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 ~a_class:cl s =
|
|
||||||
let tks = Higlo.Lang.parse ~lang:"ocaml" s in
|
|
||||||
let span' cl (s, _) = Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ]) in
|
|
||||||
let make_span = function
|
|
||||||
| Higlo.Lang.Bcomment s -> span' "comment" s
|
|
||||||
| Higlo.Lang.Constant s -> span' "constant" s
|
|
||||||
| Higlo.Lang.Directive s -> span' "directive" s
|
|
||||||
| Higlo.Lang.Escape s -> span' "escape" s
|
|
||||||
| Higlo.Lang.Id s -> span' "id" s
|
|
||||||
| Higlo.Lang.Keyword (level, s) -> span' (Printf.sprintf "kw%d" level) s
|
|
||||||
| Higlo.Lang.Lcomment s -> span' "comment" s
|
|
||||||
| Higlo.Lang.Numeric s -> span' "numeric" s
|
|
||||||
| Higlo.Lang.String s -> span' "string" s
|
|
||||||
| Higlo.Lang.Symbol (level, s) -> span' (Printf.sprintf "sym%d" level) s
|
|
||||||
| Higlo.Lang.Text s -> span' "text" s
|
|
||||||
| Higlo.Lang.Title (_, s) -> span' "text" s
|
|
||||||
in
|
|
||||||
Tyxml_js.Html.(div ~a:[ a_class [ cl ] ] (List.map make_span tks))
|
|
||||||
|
|
||||||
let highlight (`Pos from_) to_ e =
|
|
||||||
let _ =
|
|
||||||
List.fold_left
|
|
||||||
(fun pos e ->
|
|
||||||
match Js.Opt.to_option (Dom_html.CoerceTo.element e) with
|
|
||||||
| None -> pos
|
|
||||||
| Some e ->
|
|
||||||
let size = Js.Opt.case e##.textContent (fun () -> 0) (fun t -> t##.length) in
|
|
||||||
if pos + size > from_ && (to_ = `Last || `Pos pos < to_)
|
|
||||||
then e##.classList##add (Js.string "errorloc");
|
|
||||||
pos + size)
|
|
||||||
0
|
|
||||||
(Dom.list_of_nodeList e##.childNodes)
|
|
||||||
in
|
|
||||||
()
|
|
||||||
@ -1,9 +0,0 @@
|
|||||||
open Js_of_ocaml
|
|
||||||
open Js_of_ocaml_tyxml
|
|
||||||
|
|
||||||
val text : a_class:string -> string -> [> Html_types.div_content ] Tyxml_js.Html.elt
|
|
||||||
|
|
||||||
val ocaml : a_class:string -> string -> [> Html_types.div_content ] Tyxml_js.Html.elt
|
|
||||||
|
|
||||||
val highlight :
|
|
||||||
[ `Pos of int ] -> [ `Last | `Pos of int ] -> Dom_html.element Js.t -> unit
|
|
||||||
217
cors_proxy.ml
217
cors_proxy.ml
@ -1,217 +0,0 @@
|
|||||||
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
|
|
||||||
@ -1,17 +0,0 @@
|
|||||||
#!/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"
|
|
||||||
172
dune
172
dune
@ -1,160 +1,32 @@
|
|||||||
(env
|
(env
|
||||||
(dev (flags (:standard -warn-error -A))))
|
(dev (flags (:standard -warn-error -A))))
|
||||||
|
|
||||||
(executables
|
|
||||||
(names cors_proxy)
|
|
||||||
(libraries httpaf httpaf-lwt-unix base stdio fmt http-lwt-client)
|
|
||||||
(modules cors_proxy))
|
|
||||||
|
|
||||||
(library (name store)
|
(library (name store)
|
||||||
(libraries
|
(libraries
|
||||||
digestif.ocaml
|
fmt
|
||||||
checkseum.ocaml
|
irmin.unix
|
||||||
irmin.mem
|
irmin-git.unix
|
||||||
git
|
irmin-graphql.unix
|
||||||
irmin-git
|
lwt
|
||||||
cohttp-lwt-jsoo
|
lwt.unix
|
||||||
mimic
|
)
|
||||||
js_of_ocaml)
|
(modules store)
|
||||||
(modules store gitkey)
|
)
|
||||||
(preprocess
|
|
||||||
(pps js_of_ocaml-ppx)))
|
|
||||||
|
|
||||||
(executables
|
(executables
|
||||||
(names oplevel)
|
(names oplevel)
|
||||||
|
(modules oplevel secrets)
|
||||||
(libraries
|
(libraries
|
||||||
store
|
|
||||||
js_of_ocaml-compiler js_of_ocaml-tyxml js_of_ocaml-toplevel
|
|
||||||
lwt js_of_ocaml-lwt
|
|
||||||
;; not used directly
|
|
||||||
graphics
|
|
||||||
tyxml
|
|
||||||
tyxml.functor
|
|
||||||
js_of_ocaml.deriving
|
|
||||||
react reactiveData
|
|
||||||
str dynlink
|
|
||||||
ocp-indent.lib
|
|
||||||
higlo
|
|
||||||
js_of_ocaml-lwt.graphics
|
|
||||||
js_of_ocaml-ppx
|
|
||||||
js_of_ocaml-compiler.runtime
|
|
||||||
js_of_ocaml-compiler.dynlink
|
|
||||||
uucp
|
|
||||||
httpaf
|
|
||||||
tyxml-ppx
|
|
||||||
tyxml-syntax)
|
|
||||||
(flags
|
|
||||||
(:standard -rectypes -warn-error -A))
|
|
||||||
(link_flags
|
|
||||||
(:standard -linkall -keep-docs -keep-locs ))
|
|
||||||
(modes js byte )
|
|
||||||
(js_of_ocaml
|
|
||||||
(link_flags (:standard))
|
|
||||||
(build_runtime_flags
|
|
||||||
(:standard
|
|
||||||
+toplevel.js
|
|
||||||
+dynlink.js
|
|
||||||
--file
|
|
||||||
%{dep:examples.ml}
|
|
||||||
--file
|
|
||||||
%{dep:test_dynlink.cmo}
|
|
||||||
--file
|
|
||||||
%{dep:test_dynlink.js}
|
|
||||||
))
|
|
||||||
|
|
||||||
(flags
|
|
||||||
(:standard
|
|
||||||
--toplevel --linkall --target-env=browser
|
|
||||||
(:include effects_flags.sexp)
|
|
||||||
)))
|
|
||||||
(modules
|
|
||||||
oplevel toplevel ppx_support graphics_support colorize ocp_indent indent b64 )
|
|
||||||
(preprocess
|
|
||||||
(pps js_of_ocaml-ppx)))
|
|
||||||
|
|
||||||
(rule
|
|
||||||
(targets test_dynlink.cmo test_dynlink.cmi)
|
|
||||||
(action
|
|
||||||
(run ocamlc -c %{dep:test_dynlink.ml})))
|
|
||||||
|
|
||||||
(rule
|
|
||||||
(targets test_dynlink.js)
|
|
||||||
(action
|
|
||||||
(run %{bin:js_of_ocaml} --pretty --toplevel %{dep:test_dynlink.cmo})))
|
|
||||||
|
|
||||||
(rule
|
|
||||||
(targets export.txt)
|
|
||||||
(deps
|
|
||||||
(package js_of_ocaml-ppx)
|
|
||||||
(package js_of_ocaml)
|
|
||||||
(package js_of_ocaml-compiler)
|
|
||||||
(package js_of_ocaml-lwt)
|
|
||||||
(package js_of_ocaml-tyxml)
|
|
||||||
(package js_of_ocaml-toplevel))
|
|
||||||
(action
|
|
||||||
(run
|
|
||||||
jsoo_listunits
|
|
||||||
-o
|
|
||||||
%{targets}
|
|
||||||
stdlib
|
|
||||||
graphics
|
|
||||||
str
|
|
||||||
dynlink
|
|
||||||
js_of_ocaml-compiler.runtime
|
|
||||||
js_of_ocaml-lwt.graphics
|
|
||||||
js_of_ocaml-ppx.as-lib
|
|
||||||
js_of_ocaml.deriving
|
|
||||||
lwt
|
lwt
|
||||||
tyxml.functor
|
store
|
||||||
tyxml.functor:html_types.cmi
|
lablgtk3
|
||||||
react
|
lablgtk3-sourceview3
|
||||||
reactiveData
|
lwt_glib
|
||||||
js_of_ocaml
|
irmin-git
|
||||||
js_of_ocaml-lwt
|
compiler-libs.toplevel
|
||||||
js_of_ocaml-tyxml
|
)
|
||||||
js_of_ocaml-toplevel)))
|
(link_flags (-linkall))
|
||||||
|
(modes byte)
|
||||||
(executable
|
(preprocess
|
||||||
(name effects_flags)
|
(pps ppx_irmin))
|
||||||
(modules effects_flags))
|
)
|
||||||
|
|
||||||
(rule
|
|
||||||
(target effects_flags.sexp)
|
|
||||||
(action
|
|
||||||
(with-stdout-to
|
|
||||||
%{target}
|
|
||||||
(run ./effects_flags.exe sexp))))
|
|
||||||
|
|
||||||
(rule
|
|
||||||
(target effects_flags.txt)
|
|
||||||
(action
|
|
||||||
(with-stdout-to
|
|
||||||
%{target}
|
|
||||||
(run ./effects_flags.exe txt))))
|
|
||||||
|
|
||||||
(rule
|
|
||||||
(targets oplevel.js)
|
|
||||||
(action
|
|
||||||
(run
|
|
||||||
%{bin:js_of_ocaml}
|
|
||||||
compile
|
|
||||||
--pretty
|
|
||||||
%{read-strings:effects_flags.txt}
|
|
||||||
--Werror
|
|
||||||
--target-env
|
|
||||||
browser
|
|
||||||
--file
|
|
||||||
%{dep:examples.ml}
|
|
||||||
--file
|
|
||||||
%{dep:test_dynlink.cmo}
|
|
||||||
--file
|
|
||||||
%{dep:test_dynlink.js}
|
|
||||||
--toplevel
|
|
||||||
--linkall
|
|
||||||
%{dep:oplevel.bc}
|
|
||||||
-o
|
|
||||||
%{targets})))
|
|
||||||
|
|
||||||
(alias
|
|
||||||
(name default)
|
|
||||||
(deps oplevel.bc.js index.html))
|
|
||||||
|
|||||||
@ -1,15 +0,0 @@
|
|||||||
let enable b n =
|
|
||||||
let f = if b then "--enable" else "--disable" in
|
|
||||||
[ f; n ]
|
|
||||||
|
|
||||||
let () =
|
|
||||||
let major = String.split_on_char '.' Sys.ocaml_version |> List.hd |> int_of_string in
|
|
||||||
let has_effect = major >= 5 in
|
|
||||||
let l = enable has_effect "effects" in
|
|
||||||
match Sys.argv |> Array.to_list |> List.tl with
|
|
||||||
| "txt" :: [] -> List.iter print_endline l
|
|
||||||
| "sexp" :: [] ->
|
|
||||||
print_endline "(";
|
|
||||||
List.iter print_endline l;
|
|
||||||
print_endline ")"
|
|
||||||
| _ -> assert false
|
|
||||||
@ -1 +0,0 @@
|
|||||||
let init elt = Graphics_js.open_canvas elt
|
|
||||||
43
indent.ml
43
indent.ml
@ -1,43 +0,0 @@
|
|||||||
open Js_of_ocaml
|
|
||||||
|
|
||||||
let textarea (textbox : Dom_html.textAreaElement Js.t) : unit =
|
|
||||||
let rec loop s acc (i, pos') =
|
|
||||||
try
|
|
||||||
let pos = String.index_from s pos' '\n' in
|
|
||||||
loop s ((i, (pos', pos)) :: acc) (succ i, succ pos)
|
|
||||||
with _ -> List.rev ((i, (pos', String.length s)) :: acc)
|
|
||||||
in
|
|
||||||
let rec find (l : (int * (int * int)) list) c =
|
|
||||||
match l with
|
|
||||||
| [] -> assert false
|
|
||||||
| (i, (lo, up)) :: _ when up >= c -> c, i, lo, up
|
|
||||||
| (_, (_lo, _up)) :: rem -> find rem c
|
|
||||||
in
|
|
||||||
let v = textbox##.value in
|
|
||||||
let pos =
|
|
||||||
let c1 = textbox##.selectionStart and c2 = textbox##.selectionEnd in
|
|
||||||
if Js.Opt.test (Js.Opt.return c1) && Js.Opt.test (Js.Opt.return c2)
|
|
||||||
then
|
|
||||||
let l = loop (Js.to_string v) [] (0, 0) in
|
|
||||||
Some (find l c1, find l c2)
|
|
||||||
else None
|
|
||||||
in
|
|
||||||
let f =
|
|
||||||
match pos with
|
|
||||||
| None -> fun _ -> true
|
|
||||||
| Some ((_c1, line1, _lo1, _up1), (_c2, line2, _lo2, _up2)) ->
|
|
||||||
fun l -> l >= line1 + 1 && l <= line2 + 1
|
|
||||||
in
|
|
||||||
let v = Ocp_indent.indent (Js.to_string v) f in
|
|
||||||
textbox##.value := Js.string v;
|
|
||||||
match pos with
|
|
||||||
| Some ((c1, line1, _lo1, up1), (c2, line2, _lo2, up2)) ->
|
|
||||||
let l = loop v [] (0, 0) in
|
|
||||||
let lo1'', up1'' = List.assoc line1 l in
|
|
||||||
let lo2'', up2'' = List.assoc line2 l in
|
|
||||||
let n1 = max (c1 + up1'' - up1) lo1'' in
|
|
||||||
let n2 = max (c2 + up2'' - up2) lo2'' in
|
|
||||||
let () = (Obj.magic textbox)##setSelectionRange n1 n2 in
|
|
||||||
textbox##focus;
|
|
||||||
()
|
|
||||||
| None -> ()
|
|
||||||
@ -1,3 +0,0 @@
|
|||||||
open Js_of_ocaml
|
|
||||||
|
|
||||||
val textarea : Dom_html.textAreaElement Js.t -> unit
|
|
||||||
188
index.html
188
index.html
@ -1,188 +0,0 @@
|
|||||||
<?xml version="1.0" encoding="utf-8"?>
|
|
||||||
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
|
|
||||||
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
|
|
||||||
<html xmlns="http://www.w3.org/1999/xhtml">
|
|
||||||
<head>
|
|
||||||
<title>OCaml toplevel</title>
|
|
||||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
|
|
||||||
<link rel="stylesheet" href="//maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css" />
|
|
||||||
<link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css" />
|
|
||||||
<style>
|
|
||||||
|
|
||||||
code, kbd, pre, samp {
|
|
||||||
font-family: Menlo,Monaco,Consolas,monospace;
|
|
||||||
}
|
|
||||||
body,html {
|
|
||||||
height: 100%;
|
|
||||||
background-color:#eee;
|
|
||||||
}
|
|
||||||
|
|
||||||
#toplevel-container {
|
|
||||||
width: 50%;
|
|
||||||
background-color: black;
|
|
||||||
color: #ccc;
|
|
||||||
overflow: auto;
|
|
||||||
overflow-x: hidden;
|
|
||||||
height: 100%;
|
|
||||||
float:left;
|
|
||||||
padding:10px;
|
|
||||||
padding-top: 20px;
|
|
||||||
}
|
|
||||||
|
|
||||||
#toplevel-container pre#output {
|
|
||||||
padding: 0px;
|
|
||||||
}
|
|
||||||
|
|
||||||
#toplevel-container .statusv {
|
|
||||||
background-color:transparent;
|
|
||||||
color: #ccc;
|
|
||||||
border: none;
|
|
||||||
line-height:18px;
|
|
||||||
font-size: 12px;
|
|
||||||
margin-bottom: 0px;
|
|
||||||
}
|
|
||||||
|
|
||||||
#toplevel-container #output {
|
|
||||||
width:90%;
|
|
||||||
line-height:18px;
|
|
||||||
font-size: 12px;
|
|
||||||
background-color: transparent;
|
|
||||||
color: #fff;
|
|
||||||
border: 0;
|
|
||||||
resize: none;
|
|
||||||
outline: none;
|
|
||||||
font-family: Menlo,Monaco,Consolas,monospace;
|
|
||||||
font-weight: bold;
|
|
||||||
float:left;
|
|
||||||
margin: 0px;
|
|
||||||
padding:0px;
|
|
||||||
}
|
|
||||||
#toplevel-container #sharp {
|
|
||||||
float: left;
|
|
||||||
line-height:18px;
|
|
||||||
font-size: 12px;
|
|
||||||
font-family: Menlo,Monaco,Consolas,monospace;
|
|
||||||
white-space: pre;
|
|
||||||
}
|
|
||||||
.sharp:before{
|
|
||||||
content:"# ";
|
|
||||||
line-height:18px;
|
|
||||||
font-size: 12px;
|
|
||||||
font-family: Menlo,Monaco,Consolas,monospace;
|
|
||||||
}
|
|
||||||
.caml{
|
|
||||||
color:rgb(110, 110, 201);
|
|
||||||
}
|
|
||||||
#toplevel-side{
|
|
||||||
position:relative;
|
|
||||||
width:45%;
|
|
||||||
height: 100%;
|
|
||||||
overflow: auto;
|
|
||||||
text-align:justify;
|
|
||||||
float:left;
|
|
||||||
margin-left:30px;
|
|
||||||
}
|
|
||||||
#toplevel-side ul{
|
|
||||||
padding: 0px;
|
|
||||||
list-style-type: none;
|
|
||||||
}
|
|
||||||
|
|
||||||
.stderr {
|
|
||||||
color: #d9534f;
|
|
||||||
}
|
|
||||||
.stdout {
|
|
||||||
|
|
||||||
}
|
|
||||||
.errorloc{
|
|
||||||
border-bottom-width: 3px;
|
|
||||||
border-bottom-style: solid;
|
|
||||||
border-bottom-color: red;
|
|
||||||
}
|
|
||||||
canvas {
|
|
||||||
border: 1px dashed black;
|
|
||||||
float: left;
|
|
||||||
margin: 7px;
|
|
||||||
}
|
|
||||||
#output canvas {
|
|
||||||
background-color: #464646;
|
|
||||||
float: none;
|
|
||||||
display: block;
|
|
||||||
border: 1px dashed while;
|
|
||||||
margin: 7px;
|
|
||||||
}
|
|
||||||
#output img {
|
|
||||||
display:block;
|
|
||||||
}
|
|
||||||
#toplevel-examples {
|
|
||||||
width: 270px;
|
|
||||||
float: left;
|
|
||||||
}
|
|
||||||
#toplevel-examples .list-group-item{
|
|
||||||
padding: 5px 15px;
|
|
||||||
}
|
|
||||||
#btn-share {
|
|
||||||
float:right;
|
|
||||||
margin-top:-20px;
|
|
||||||
background-color:rgb(92, 129, 184);
|
|
||||||
border-color: rgb(70, 75, 128);
|
|
||||||
padding: 1px 5px;
|
|
||||||
display:none;
|
|
||||||
}
|
|
||||||
.clear { clear:both; }
|
|
||||||
|
|
||||||
.sharp .id { color: #59B65C ; font-style: italic }
|
|
||||||
.sharp .kw0 { color: rgb(64, 75, 190); font-weight: bold ;}
|
|
||||||
.sharp .kw1 { color: rgb(150, 0, 108); font-weight: bold ;}
|
|
||||||
.sharp .kw2 { color: rgb(23, 100, 42); font-weight: bold ;}
|
|
||||||
.sharp .kw3 { color: #59B65C; font-weight: bold ;}
|
|
||||||
.sharp .kw4 { color: #59B65C; font-weight: bold ;}
|
|
||||||
.sharp .comment { color: green ; font-style: italic ; }
|
|
||||||
.sharp .string { color: #6B6B6B; font-weight: bold ; }
|
|
||||||
.sharp .text { }
|
|
||||||
.sharp .numeric { color: #729AAF; }
|
|
||||||
.sharp .directive { font-style: italic ; color : #EB00FF; } ;
|
|
||||||
.sharp .escape { color: #409290 ; }
|
|
||||||
.sharp .symbol0 { color: orange ; font-weight: bold ; }
|
|
||||||
.sharp .symbol1 { color: #993300 ; font-weight: bold ; }
|
|
||||||
.sharp .constant { color: rgb(0, 152, 255); }
|
|
||||||
</style>
|
|
||||||
<script type="text/javascript">
|
|
||||||
|
|
||||||
window.onhashchange = function() { window.location.reload() }
|
|
||||||
var hash = window.location.hash.replace(/^#/,"");
|
|
||||||
var fields = hash.split(/&/);
|
|
||||||
var prefix = "";
|
|
||||||
var version = "";
|
|
||||||
var main = "oplevel.bc.js";
|
|
||||||
function load_script(url){
|
|
||||||
var fileref=document.createElement('script');
|
|
||||||
fileref.setAttribute("type","text/javascript");
|
|
||||||
fileref.setAttribute("src", prefix+(version==""?"":(version+"/"))+url);
|
|
||||||
document.getElementsByTagName("head")[0].appendChild(fileref);
|
|
||||||
}
|
|
||||||
load_script("exported-unit.cmis.js");
|
|
||||||
load_script(main);
|
|
||||||
|
|
||||||
</script>
|
|
||||||
</head>
|
|
||||||
<body>
|
|
||||||
<div id="toplevel-container">
|
|
||||||
<pre id="output"></pre>
|
|
||||||
<div>
|
|
||||||
<div id="sharp" class="sharp"></div>
|
|
||||||
<textarea id="userinput">Loading ...</textarea>
|
|
||||||
<button type="button" class="btn btn-default"
|
|
||||||
id="btn-share">Share</button>
|
|
||||||
</div>
|
|
||||||
</div>
|
|
||||||
<div id="toplevel-side">
|
|
||||||
<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">
|
|
||||||
</pre>
|
|
||||||
</div>
|
|
||||||
</body>
|
|
||||||
</html>
|
|
||||||
@ -1,14 +0,0 @@
|
|||||||
let _ = Approx_lexer.enable_extension "lwt"
|
|
||||||
|
|
||||||
let indent s in_lines =
|
|
||||||
let output =
|
|
||||||
{ IndentPrinter.debug = false
|
|
||||||
; config = IndentConfig.default
|
|
||||||
; in_lines
|
|
||||||
; indent_empty = true
|
|
||||||
; adaptive = true
|
|
||||||
; kind = IndentPrinter.Print (fun s acc -> acc ^ s)
|
|
||||||
}
|
|
||||||
in
|
|
||||||
let stream = Nstream.of_string s in
|
|
||||||
IndentPrinter.proceed output stream IndentBlock.empty ""
|
|
||||||
310
oplevel.ml
310
oplevel.ml
@ -1,133 +1,201 @@
|
|||||||
open Js_of_ocaml
|
open Lwt.Infix
|
||||||
open Js_of_ocaml_tyxml
|
module F = Fmt
|
||||||
open Lwt
|
|
||||||
open Store
|
|
||||||
|
|
||||||
let by_id s = Dom_html.getElementById s
|
let lang_mime_type = "text/x-ocaml"
|
||||||
|
let lang_name = "ocaml"
|
||||||
|
let use_mime_type = true
|
||||||
|
let font_name = "Monospace 12"
|
||||||
|
|
||||||
let by_id_coerce s f =
|
let () =
|
||||||
Js.Opt.get
|
Lwt_main.run
|
||||||
(f (Dom_html.getElementById s))
|
((* Initializes GTK. *)
|
||||||
(fun () -> raise Not_found)
|
ignore (GMain.init ());
|
||||||
|
|
||||||
let resize ~container ~textbox () =
|
(* Install Lwt<->Glib integration. *)
|
||||||
Lwt.pause () >>= fun () ->
|
Lwt_glib.install ();
|
||||||
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 appendchild ~container html =
|
(* Thread which is wakeup when the main window is closed. *)
|
||||||
Dom.appendChild container (Tyxml_js.To_dom.of_a html)
|
let waiter, wakener = Lwt.wait () in
|
||||||
|
|
||||||
let _ =
|
let language_manager =
|
||||||
Dom_html.window##.onload
|
GSourceView3.source_language_manager ~default:true
|
||||||
:= Dom_html.handler (fun _ ->
|
|
||||||
Lwt.async (fun () ->
|
|
||||||
let output = by_id "output" in
|
|
||||||
let container = by_id "toplevel-container" in
|
|
||||||
appendchild ~container
|
|
||||||
Tyxml_js.Html.(
|
|
||||||
a
|
|
||||||
~a:[ a_class [ "window" ] ]
|
|
||||||
[
|
|
||||||
div
|
|
||||||
~a:[ a_class [ "status" ] ]
|
|
||||||
[ txt "starting..." ];
|
|
||||||
]);
|
|
||||||
let textbox : 'a Js.t =
|
|
||||||
by_id_coerce "userinput" Dom_html.CoerceTo.textarea
|
|
||||||
in
|
in
|
||||||
let rootrepo = Store.test_pull () in
|
|
||||||
rootrepo >>= fun (_upstream, t) ->
|
let lang =
|
||||||
|
if use_mime_type then
|
||||||
|
match
|
||||||
|
language_manager#guess_language
|
||||||
|
~content_type:lang_mime_type ()
|
||||||
|
with
|
||||||
|
| Some x -> x
|
||||||
|
| None ->
|
||||||
|
failwith (F.str "no language for %s" lang_mime_type)
|
||||||
|
else
|
||||||
|
match language_manager#language lang_name with
|
||||||
|
| Some x -> x
|
||||||
|
| None -> failwith (F.str "can't load %s" lang_name)
|
||||||
|
in
|
||||||
|
Store.init_default
|
||||||
|
(F.str "%s/console/rootstore.git" Secrets.giturl)
|
||||||
|
>>= fun t ->
|
||||||
Store.S.tree t >>= fun rootstore ->
|
Store.S.tree t >>= fun rootstore ->
|
||||||
(try
|
(try Store.S.Tree.get rootstore [ ".config"; "init.ml" ] with
|
||||||
Store.S.Tree.get rootstore [ ".config"; "init.ml" ]
|
|
||||||
with
|
|
||||||
| Not_found | Invalid_argument _ ->
|
| Not_found | Invalid_argument _ ->
|
||||||
Lwt.return
|
Lwt.return
|
||||||
"print_newline \"rootstore://.config/init.ml not \
|
"print_newline \"rootstore://.config/init.ml not found\";;"
|
||||||
found\";;"
|
|
||||||
| exc ->
|
| exc ->
|
||||||
Firebug.console##log_3
|
Lwt.return
|
||||||
(Js.string ".config/init.ml load exception")
|
(F.str ".config/init.ml load exception: %s"
|
||||||
(Js.string (Printexc.to_string exc))
|
(Printexc.to_string exc)))
|
||||||
exc;
|
>>= fun text ->
|
||||||
Lwt.return ";;")
|
let source_buffer =
|
||||||
>>= fun init ->
|
GSourceView3.source_buffer ~language:lang ~text
|
||||||
let execute = ref (Toplevel.run ~init ~output ()) in
|
?style_scheme:
|
||||||
let meta e =
|
((GSourceView3.source_style_scheme_manager ~default:true)
|
||||||
let b = Js.to_bool in
|
#style_scheme "solarized-dark")
|
||||||
b e##.ctrlKey || b e##.altKey || b e##.metaKey
|
~highlight_matching_brackets:true ~highlight_syntax:true ()
|
||||||
in
|
in
|
||||||
let shift e = Js.to_bool e##.shiftKey in
|
|
||||||
(* setup handlers *)
|
|
||||||
textbox##.onkeyup :=
|
|
||||||
Dom_html.handler (fun _ ->
|
|
||||||
Lwt.async (resize ~container ~textbox);
|
|
||||||
Js._true);
|
|
||||||
textbox##.onchange :=
|
|
||||||
Dom_html.handler (fun _ ->
|
|
||||||
Lwt.async (resize ~container ~textbox);
|
|
||||||
Js._true);
|
|
||||||
textbox##.onkeydown :=
|
|
||||||
Dom_html.handler
|
|
||||||
Dom_html.Keyboard_code.(
|
|
||||||
fun e ->
|
|
||||||
match of_key_code e##.keyCode with
|
|
||||||
| Enter when not (meta e || shift e) ->
|
|
||||||
Lwt.async (fun () ->
|
|
||||||
!execute
|
|
||||||
(Js.to_string textbox##.value##trim)
|
|
||||||
());
|
|
||||||
Js._false
|
|
||||||
| Enter ->
|
|
||||||
Lwt.async (resize ~container ~textbox);
|
|
||||||
Js._true
|
|
||||||
| Tab ->
|
|
||||||
Indent.textarea textbox;
|
|
||||||
Js._false
|
|
||||||
| KeyL when meta e ->
|
|
||||||
output##.innerHTML := Js.string "";
|
|
||||||
Js._true
|
|
||||||
| KeyK when meta e ->
|
|
||||||
Lwt.async
|
|
||||||
Store.S.(
|
|
||||||
fun () ->
|
|
||||||
rootrepo >>= fun (upstream, t) ->
|
|
||||||
Sync.pull_exn t upstream `Set
|
|
||||||
>>= fun _ ->
|
|
||||||
Firebug.console##log
|
|
||||||
(Js.string
|
|
||||||
"re-pulling rootstore for init.ml\n");
|
|
||||||
tree t >>= fun rs ->
|
|
||||||
(try
|
|
||||||
Store.S.Tree.get rs
|
|
||||||
[ ".config"; "init.ml" ]
|
|
||||||
with
|
|
||||||
| Not_found | Invalid_argument _ ->
|
|
||||||
Lwt.return
|
|
||||||
"print_newline \
|
|
||||||
\"rootstore://.config/init.ml \
|
|
||||||
not found\";;"
|
|
||||||
| exc ->
|
|
||||||
Firebug.console##log_3
|
|
||||||
(Js.string
|
|
||||||
".config/init.ml load \
|
|
||||||
exception")
|
|
||||||
(Js.string
|
|
||||||
(Printexc.to_string exc))
|
|
||||||
exc;
|
|
||||||
Lwt.return ";;")
|
|
||||||
>>= fun init ->
|
|
||||||
Lwt.return
|
|
||||||
(execute :=
|
|
||||||
Toplevel.run ~init ~output ()));
|
|
||||||
Js._false
|
|
||||||
(* | ArrowUp -> history_up e
|
|
||||||
| ArrowDown -> history_down e *)
|
|
||||||
| _ -> Js._true);
|
|
||||||
Lwt.return_unit);
|
|
||||||
|
|
||||||
Js._false)
|
let win = GWindow.window ~title:"oplevel main" () in
|
||||||
|
(* Quit when the window is closed. *)
|
||||||
|
ignore (win#connect#destroy ~callback:(Lwt.wakeup wakener));
|
||||||
|
(* Show the window. *)
|
||||||
|
win#show ();
|
||||||
|
|
||||||
|
let vbox =
|
||||||
|
GPack.vbox ~spacing:10 ~border_width:15 ~packing:win#add ()
|
||||||
|
in
|
||||||
|
let scroll_edit =
|
||||||
|
GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
|
||||||
|
~packing:vbox#add ()
|
||||||
|
in
|
||||||
|
let edit =
|
||||||
|
GSourceView3.source_view ~source_buffer ~auto_indent:true
|
||||||
|
~insert_spaces_instead_of_tabs:true ~tab_width:2
|
||||||
|
~show_line_numbers:true ~right_margin_position:80
|
||||||
|
~show_right_margin:true (* ~smart_home_end:true *)
|
||||||
|
~packing:scroll_edit#add ~height:500 ~width:650 ()
|
||||||
|
in
|
||||||
|
edit#misc#modify_font_by_name font_name;
|
||||||
|
edit#set_smart_home_end `AFTER;
|
||||||
|
if edit#smart_home_end <> `AFTER then failwith "regret";
|
||||||
|
ignore
|
||||||
|
(edit#connect#undo ~callback:(fun _ -> prerr_endline "undo"));
|
||||||
|
|
||||||
|
let scroll_output =
|
||||||
|
GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
|
||||||
|
~packing:vbox#add ()
|
||||||
|
in
|
||||||
|
let output_buffer = GText.buffer ~text:"loading..." () in
|
||||||
|
let _output_win =
|
||||||
|
GText.view ~buffer:output_buffer ~editable:false
|
||||||
|
~cursor_visible:true ~packing:scroll_output#add ()
|
||||||
|
in
|
||||||
|
F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
|
||||||
|
Toploop.initialize_toplevel_env ();
|
||||||
|
let out_ppf =
|
||||||
|
Format.formatter_of_out_functions
|
||||||
|
Format.
|
||||||
|
{
|
||||||
|
out_string = (fun s _ _ -> output_buffer#insert s);
|
||||||
|
out_flush = (fun () -> ());
|
||||||
|
out_indent =
|
||||||
|
(fun n ->
|
||||||
|
for _ = 0 to n do
|
||||||
|
output_buffer#insert " "
|
||||||
|
done);
|
||||||
|
out_newline = (fun () -> output_buffer#insert "\n");
|
||||||
|
out_spaces =
|
||||||
|
(fun n -> output_buffer#insert (String.make n ' '));
|
||||||
|
}
|
||||||
|
in
|
||||||
|
|
||||||
|
ignore (GtkMain.BindingSet.make "execute");
|
||||||
|
|
||||||
|
let module GToolbox = struct
|
||||||
|
include GToolbox
|
||||||
|
|
||||||
|
(* mk_keys turns keys from a key_combination into a format which can be used in
|
||||||
|
* a GTK+ RC file. *)
|
||||||
|
let mk_keys (mods, c) =
|
||||||
|
let mods =
|
||||||
|
List.map
|
||||||
|
(function
|
||||||
|
| `A -> "<alt>" | `C -> "<control>" | `S -> "<shift>")
|
||||||
|
mods
|
||||||
|
in
|
||||||
|
String.concat "" mods
|
||||||
|
^ String.make 1 (Char.lowercase_ascii c)
|
||||||
|
|
||||||
|
(* Signal creation for shortcuts unfortunately requires us to create an
|
||||||
|
* in-memory gtkrc file which this function do. *)
|
||||||
|
let make_gtkrc_string g_type shortcuts =
|
||||||
|
let sp = Printf.sprintf in
|
||||||
|
let b = Buffer.create 4000 in
|
||||||
|
Buffer.add_string b "binding \"Shortcuts\" {";
|
||||||
|
StdLabels.List.iter shortcuts ~f:(fun t ->
|
||||||
|
ListLabels.iter t.keys ~f:(fun keys ->
|
||||||
|
let keys = mk_keys keys in
|
||||||
|
Buffer.add_string b
|
||||||
|
(sp " bind \"%s\" { \"%s\" () }" keys t.name)));
|
||||||
|
Buffer.add_string b "}";
|
||||||
|
let classname = Gobject.Type.name g_type in
|
||||||
|
Buffer.add_string b
|
||||||
|
(sp "\nclass \"%s\" binding \"Shortcuts\"" classname);
|
||||||
|
Buffer.contents b
|
||||||
|
|
||||||
|
let create_shortcuts ~window:(win : #GWindow.window_skel)
|
||||||
|
~shortcuts ~callback =
|
||||||
|
let win = win#as_window in
|
||||||
|
let g_type = Gobject.get_type win in
|
||||||
|
F.pr "gtkrc_string: %s@.@."
|
||||||
|
(make_gtkrc_string g_type shortcuts);
|
||||||
|
GtkMain.Rc.parse_string (make_gtkrc_string g_type shortcuts);
|
||||||
|
ListLabels.iter shortcuts ~f:(fun t ->
|
||||||
|
let sgn =
|
||||||
|
{
|
||||||
|
GtkSignal.name = t.name;
|
||||||
|
classe = `window;
|
||||||
|
marshaller = GtkSignal.marshal_unit;
|
||||||
|
}
|
||||||
|
in
|
||||||
|
GtkSignal.signal_new t.name g_type
|
||||||
|
[ `ACTION; `RUN_FIRST ];
|
||||||
|
ignore
|
||||||
|
(GtkSignal.connect ~sgn
|
||||||
|
~callback:(fun () -> callback t.message)
|
||||||
|
win))
|
||||||
|
end in
|
||||||
|
GToolbox.create_shortcuts ~window:win
|
||||||
|
~shortcuts:
|
||||||
|
[
|
||||||
|
{
|
||||||
|
name = "Quit";
|
||||||
|
keys = [ ([ `C ], 'q') ];
|
||||||
|
message = `Quit;
|
||||||
|
};
|
||||||
|
{
|
||||||
|
name = "Execute";
|
||||||
|
keys = [ ([ `C ], 'e') ];
|
||||||
|
message = `Execute;
|
||||||
|
};
|
||||||
|
]
|
||||||
|
~callback:(function
|
||||||
|
| `Quit ->
|
||||||
|
F.pr "`Quit@.";
|
||||||
|
F.pf out_ppf "`Quit@.";
|
||||||
|
Lwt.wakeup wakener ()
|
||||||
|
| `Execute ->
|
||||||
|
F.pr "`Execute@.";
|
||||||
|
F.pf out_ppf "`Execute@.";
|
||||||
|
ignore
|
||||||
|
(Toploop.use_input out_ppf
|
||||||
|
(String (source_buffer#get_text ()))));
|
||||||
|
|
||||||
|
(* ignore
|
||||||
|
(Toploop.use_input out_ppf
|
||||||
|
(String "#use \"topfind\";;\n#list;;")); *)
|
||||||
|
output_buffer#set_text "";
|
||||||
|
ignore (Toploop.use_input out_ppf (String text));
|
||||||
|
(* Wait for it to be closed. *)
|
||||||
|
waiter)
|
||||||
|
|||||||
@ -1 +0,0 @@
|
|||||||
let init () = Ast_mapper.register "js_of_ocaml" (fun _ -> Ppx_js.mapper)
|
|
||||||
366
store.ml
366
store.ml
@ -1,345 +1,6 @@
|
|||||||
open Js_of_ocaml
|
|
||||||
open Lwt.Infix
|
open Lwt.Infix
|
||||||
module F = Fmt
|
module F = Fmt
|
||||||
module Cohttp_backend = Cohttp_lwt_jsoo
|
module S = Irmin_git_unix.FS.KV (Irmin.Contents.String)
|
||||||
|
|
||||||
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)
|
module Sync = Irmin.Sync.Make (S)
|
||||||
|
|
||||||
type t = S.tree
|
type t = S.tree
|
||||||
@ -348,6 +9,7 @@ type step = S.step
|
|||||||
type path = step list
|
type path = step list
|
||||||
|
|
||||||
let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
|
let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
|
||||||
|
let info = Irmin_git_unix.info
|
||||||
|
|
||||||
let test_populate () : t Lwt.t =
|
let test_populate () : t Lwt.t =
|
||||||
let add p s t = S.Tree.add t p s in
|
let add p s t = S.Tree.add t p s in
|
||||||
@ -355,22 +17,8 @@ let test_populate () : t Lwt.t =
|
|||||||
>>= add [ "hello"; "daddy" ] "ily"
|
>>= add [ "hello"; "daddy" ] "ily"
|
||||||
>>= add [ "beep"; "beep" ] "motherfucker"
|
>>= add [ "beep"; "beep" ] "motherfucker"
|
||||||
|
|
||||||
let test_pull () : (Irmin.remote * Sync.db) Lwt.t =
|
let init_default upstream_url : Sync.db Lwt.t =
|
||||||
(* test_populate ()*)
|
S.Repo.v (Irmin_git.Conf.init "../rootstore") >>= fun repo ->
|
||||||
Firebug.console##log (Js.string "Nav.test_pull()\n");
|
S.of_branch repo "lablgtk" >>= fun t ->
|
||||||
S.Repo.v (Config.init "") >>= fun repo ->
|
S.remote upstream_url >>= fun upstream ->
|
||||||
Firebug.console##log (Js.string "Nav.test_pull(2)\n");
|
Sync.pull_exn t upstream `Set >>= fun _ -> Lwt.return t
|
||||||
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", F.str "Basic %s" Gitkey.key) ]
|
|
||||||
"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");
|
|
||||||
Lwt.return (upstream, t)
|
|
||||||
(* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)
|
|
||||||
|
|||||||
@ -1,3 +0,0 @@
|
|||||||
let _ = print_endline "Dynlink OK"
|
|
||||||
|
|
||||||
let f () = print_endline "Test_dynlink.f Ok"
|
|
||||||
Reference in New Issue
Block a user