Initial import of LogDarioSeq baseline
Establishes version control for the personal Logseq DB fork before starting the server-client architecture migration and domain features described in docs/agent-guide and the approved implementation plan. Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
This commit is contained in:
134
cli/lib/platform/node/cli_effect.ml
Normal file
134
cli/lib/platform/node/cli_effect.ml
Normal file
@@ -0,0 +1,134 @@
|
||||
type 'a state = Pending | Resolved of 'a | Rejected of exn
|
||||
|
||||
type 'a t = {
|
||||
mutable state : 'a state;
|
||||
mutable callbacks : ('a state -> unit) Rrbvec.t;
|
||||
}
|
||||
|
||||
type 'a resolver = 'a t
|
||||
|
||||
let pure value = { state = Resolved value; callbacks = Rrbvec.empty }
|
||||
let error exn = { state = Rejected exn; callbacks = Rrbvec.empty }
|
||||
|
||||
let is_pending task =
|
||||
match task.state with Pending -> true | Resolved _ | Rejected _ -> false
|
||||
|
||||
let wait () =
|
||||
let task = { state = Pending; callbacks = Rrbvec.empty } in
|
||||
(task, task)
|
||||
|
||||
let notify task state =
|
||||
if is_pending task then (
|
||||
task.state <- state;
|
||||
let callbacks = Rrbvec.rev task.callbacks in
|
||||
task.callbacks <- Rrbvec.empty;
|
||||
Rrbvec.iter (fun callback -> callback state) callbacks)
|
||||
|
||||
let wakeup resolver value = notify resolver (Resolved value)
|
||||
let reject resolver exn = notify resolver (Rejected exn)
|
||||
|
||||
let on_state task callback =
|
||||
match task.state with
|
||||
| Pending -> task.callbacks <- Rrbvec.push_front task.callbacks callback
|
||||
| state -> callback state
|
||||
|
||||
let bind task f =
|
||||
let result, resolver = wait () in
|
||||
on_state task (function
|
||||
| Pending -> ()
|
||||
| Resolved value -> (
|
||||
try
|
||||
let next = f value in
|
||||
on_state next (function
|
||||
| Pending -> ()
|
||||
| Resolved value -> wakeup resolver value
|
||||
| Rejected exn -> reject resolver exn)
|
||||
with exn -> reject resolver exn)
|
||||
| Rejected exn -> reject resolver exn);
|
||||
result
|
||||
|
||||
module Infix = struct
|
||||
let ( >>= ) = bind
|
||||
end
|
||||
|
||||
let map f task = bind task (fun value -> pure (f value))
|
||||
|
||||
let rec map_s f values =
|
||||
match Rrbvec.pop_front values with
|
||||
| None -> pure Rrbvec.empty
|
||||
| Some (value, rest) ->
|
||||
bind (f value) (fun mapped ->
|
||||
map
|
||||
(fun mapped_rest -> Rrbvec.push_front mapped_rest mapped)
|
||||
(map_s f rest))
|
||||
|
||||
let both left right =
|
||||
bind left (fun left_value ->
|
||||
map (fun right_value -> (left_value, right_value)) right)
|
||||
|
||||
let all tasks =
|
||||
let result, resolver = wait () in
|
||||
let pending = ref (Rrbvec.length tasks) in
|
||||
let values = Array.make (Rrbvec.length tasks) None in
|
||||
let finish_if_ready () =
|
||||
if !pending = 0 && is_pending result then
|
||||
wakeup resolver (values |> Array.map Option.get |> Rrbvec.of_array)
|
||||
in
|
||||
Rrbvec.iteri
|
||||
(fun index task ->
|
||||
on_state task (function
|
||||
| Pending -> ()
|
||||
| Resolved value ->
|
||||
values.(index) <- Some value;
|
||||
decr pending;
|
||||
finish_if_ready ()
|
||||
| Rejected exn -> if is_pending result then reject resolver exn))
|
||||
tasks;
|
||||
finish_if_ready ();
|
||||
result
|
||||
|
||||
let catch value handler =
|
||||
let result, resolver = wait () in
|
||||
on_state value (function
|
||||
| Pending -> ()
|
||||
| Resolved value -> wakeup resolver value
|
||||
| Rejected exn -> (
|
||||
try
|
||||
let next = handler exn in
|
||||
on_state next (function
|
||||
| Pending -> ()
|
||||
| Resolved value -> wakeup resolver value
|
||||
| Rejected exn -> reject resolver exn)
|
||||
with exn -> reject resolver exn));
|
||||
result
|
||||
|
||||
let finally value f =
|
||||
let result, resolver = wait () in
|
||||
let finish state =
|
||||
let cleanup = try f () with exn -> error exn in
|
||||
on_state cleanup (function
|
||||
| Pending -> ()
|
||||
| Resolved () -> (
|
||||
match state with
|
||||
| Pending -> ()
|
||||
| Resolved value -> wakeup resolver value
|
||||
| Rejected exn -> reject resolver exn)
|
||||
| Rejected exn -> reject resolver exn)
|
||||
in
|
||||
on_state value finish;
|
||||
result
|
||||
|
||||
let async f = ignore (catch (f ()) (fun _ -> pure ()) : unit t)
|
||||
|
||||
let on_any task on_ok on_error =
|
||||
on_state task (function
|
||||
| Pending -> ()
|
||||
| Resolved value -> on_ok value
|
||||
| Rejected exn -> on_error exn)
|
||||
|
||||
let sleep span =
|
||||
let task, resolver = wait () in
|
||||
ignore
|
||||
(Js.Global.setTimeout ~f:(fun () -> wakeup resolver ()) (int_of_float span)
|
||||
: Js.Global.timeoutId);
|
||||
task
|
||||
378
cli/lib/platform/node/cli_platform.ml
Normal file
378
cli/lib/platform/node/cli_platform.ml
Normal file
@@ -0,0 +1,378 @@
|
||||
open Cli_effect.Infix
|
||||
|
||||
let hostname = Cli_unix.gethostname
|
||||
|
||||
module Stdout = struct
|
||||
type writable
|
||||
|
||||
external stdout : writable = "stdout" [@@mel.module "process"]
|
||||
|
||||
external on_error :
|
||||
writable -> (_[@mel.as "error"]) -> ((Js.Exn.t -> unit)[@u]) -> unit = "on"
|
||||
[@@mel.send]
|
||||
|
||||
external error_code : Js.Exn.t -> string option = "code"
|
||||
[@@mel.get] [@@mel.return { undefined_to_opt }]
|
||||
end
|
||||
|
||||
let stdout_error_handler_installed = ref false
|
||||
|
||||
let install_stdout_error_handler () =
|
||||
if not !stdout_error_handler_installed then (
|
||||
stdout_error_handler_installed := true;
|
||||
Stdout.on_error Stdout.stdout (fun[@u] error ->
|
||||
match Stdout.error_code error with
|
||||
| Some "EPIPE" -> exit 0
|
||||
| _ ->
|
||||
Js.Exn.raiseError
|
||||
(Option.value (Js.Exn.message error) ~default:"JavaScript error")))
|
||||
|
||||
let argv () =
|
||||
install_stdout_error_handler ();
|
||||
Node.Process.argv
|
||||
|
||||
type login_callback_request = { target : string option }
|
||||
type login_callback_response = { status : int; body : string }
|
||||
|
||||
type login_callback_server_error =
|
||||
| Login_callback_timeout
|
||||
| Login_callback_server_start_failed of string
|
||||
| Login_callback_server_aborted of string
|
||||
|
||||
let timeout_ms span = if Float.compare span 0. > 0 then int_of_float span else 0
|
||||
|
||||
module Timer = struct
|
||||
let set_timeout f ms = Js.Global.setTimeout ~f ms
|
||||
let clear_timeout = Js.Global.clearTimeout
|
||||
end
|
||||
|
||||
module Http_server = struct
|
||||
type server
|
||||
type request
|
||||
type response
|
||||
|
||||
external create_server : ((request -> response -> unit)[@u]) -> server
|
||||
= "createServer"
|
||||
[@@mel.module "http"]
|
||||
|
||||
external listen : server -> int -> string -> ((unit -> unit)[@u]) -> unit
|
||||
= "listen"
|
||||
[@@mel.send]
|
||||
|
||||
external on_error :
|
||||
server -> (_[@mel.as "error"]) -> ((Js.Exn.t -> unit)[@u]) -> unit = "on"
|
||||
[@@mel.send]
|
||||
|
||||
external close : server -> ((unit -> unit)[@u]) -> unit = "close" [@@mel.send]
|
||||
|
||||
external target : request -> string option = "url"
|
||||
[@@mel.get] [@@mel.return { undefined_to_opt }]
|
||||
|
||||
external write_head : response -> int -> string Js.Dict.t -> unit
|
||||
= "writeHead"
|
||||
[@@mel.send]
|
||||
|
||||
external end_ : response -> string -> ((unit -> unit)[@u]) -> unit = "end"
|
||||
[@@mel.send]
|
||||
|
||||
let text_headers () =
|
||||
let headers = Js.Dict.empty () in
|
||||
Js.Dict.set headers "Content-Type" "text/plain; charset=utf-8";
|
||||
Js.Dict.set headers "Connection" "close";
|
||||
headers
|
||||
|
||||
let close_ignore server = try close server (fun[@u] () -> ()) with _ -> ()
|
||||
end
|
||||
|
||||
let js_error_message exn =
|
||||
match Js.Exn.message exn with
|
||||
| Some message when String.trim message <> "" -> message
|
||||
| _ -> "JavaScript error"
|
||||
|
||||
let login_callback_server ~host ~port ~timeout_span ~on_listen ~handle_request =
|
||||
let task, resolver = Cli_effect.wait () in
|
||||
let settled = ref false in
|
||||
let server_ref = ref None in
|
||||
let timeout_ref = ref None in
|
||||
let clear_timer () =
|
||||
match !timeout_ref with
|
||||
| None -> ()
|
||||
| Some timeout_handle ->
|
||||
timeout_ref := None;
|
||||
Timer.clear_timeout timeout_handle
|
||||
in
|
||||
let close_server () =
|
||||
match !server_ref with
|
||||
| None -> ()
|
||||
| Some server ->
|
||||
server_ref := None;
|
||||
Http_server.close_ignore server
|
||||
in
|
||||
let finish result =
|
||||
if not !settled then (
|
||||
settled := true;
|
||||
clear_timer ();
|
||||
close_server ();
|
||||
Cli_effect.wakeup resolver result)
|
||||
in
|
||||
let on_request request response =
|
||||
if !settled then (
|
||||
Http_server.write_head response 410 (Http_server.text_headers ());
|
||||
Http_server.end_ response "Login callback already handled" (fun[@u] () ->
|
||||
()))
|
||||
else
|
||||
let response_body, result =
|
||||
handle_request { target = Http_server.target request }
|
||||
in
|
||||
finish (Ok result);
|
||||
Http_server.write_head response response_body.status
|
||||
(Http_server.text_headers ());
|
||||
Http_server.end_ response response_body.body (fun[@u] () ->
|
||||
match !server_ref with
|
||||
| None -> ()
|
||||
| Some server -> Http_server.close_ignore server)
|
||||
in
|
||||
let on_listening () =
|
||||
let timeout = timeout_ms timeout_span in
|
||||
if timeout > 0 then
|
||||
timeout_ref :=
|
||||
Some
|
||||
(Timer.set_timeout
|
||||
(fun () -> finish (Error Login_callback_timeout))
|
||||
timeout);
|
||||
Cli_effect.on_any (on_listen ())
|
||||
(function
|
||||
| Ok () -> ()
|
||||
| Error message ->
|
||||
finish (Error (Login_callback_server_aborted message)))
|
||||
(fun exn ->
|
||||
finish (Error (Login_callback_server_aborted (Printexc.to_string exn))))
|
||||
in
|
||||
try
|
||||
let server =
|
||||
Http_server.create_server (fun[@u] request response ->
|
||||
on_request request response)
|
||||
in
|
||||
server_ref := Some server;
|
||||
Http_server.on_error server (fun[@u] error ->
|
||||
finish
|
||||
(Error (Login_callback_server_start_failed (js_error_message error))));
|
||||
Http_server.listen server port host (fun[@u] () -> on_listening ());
|
||||
task
|
||||
with exn ->
|
||||
finish (Error (Login_callback_server_start_failed (Printexc.to_string exn)));
|
||||
task
|
||||
|
||||
module Symbols = struct
|
||||
let ellipsis = Js.String.fromCodePoint 0x2026
|
||||
let linked_arrow = Js.String.fromCodePoint 0x2192 ^ " "
|
||||
let tree_line = Js.String.fromCodePoint 0x2500
|
||||
let tree_last = Js.String.fromCodePoint 0x2514 ^ tree_line ^ tree_line ^ " "
|
||||
let tree_middle = Js.String.fromCodePoint 0x251c ^ tree_line ^ tree_line ^ " "
|
||||
let tree_pipe = Js.String.fromCodePoint 0x2502 ^ " "
|
||||
end
|
||||
|
||||
module HTTP = struct
|
||||
external promise_error_name : Js.Promise.error -> string option = "name"
|
||||
[@@mel.get] [@@mel.return { undefined_to_opt }]
|
||||
|
||||
external promise_error_message : Js.Promise.error -> string option = "message"
|
||||
[@@mel.get] [@@mel.return { undefined_to_opt }]
|
||||
|
||||
let promise_to_effect ?(on_settle = fun () -> ()) promise =
|
||||
let task, resolver = Cli_effect.wait () in
|
||||
let finish result =
|
||||
if Cli_effect.is_pending task then Cli_effect.wakeup resolver result
|
||||
in
|
||||
let on_ok value =
|
||||
on_settle ();
|
||||
finish (Ok value);
|
||||
Js.Promise.resolve ()
|
||||
in
|
||||
let on_error error =
|
||||
let message =
|
||||
match promise_error_name error with
|
||||
| Some "AbortError" -> "request timeout"
|
||||
| _ ->
|
||||
Option.value
|
||||
(promise_error_message error)
|
||||
~default:"JavaScript promise rejected"
|
||||
in
|
||||
on_settle ();
|
||||
finish (Error message);
|
||||
Js.Promise.resolve ()
|
||||
in
|
||||
ignore
|
||||
(promise |> Js.Promise.then_ on_ok |> Js.Promise.catch on_error
|
||||
: unit Js.Promise.t);
|
||||
task >>= function
|
||||
| Ok value -> Cli_effect.pure value
|
||||
| Error message -> Cli_effect.error (Failure message)
|
||||
|
||||
let timeout_ms = function
|
||||
| Some timeout_span when Float.compare timeout_span 0. > 0 ->
|
||||
int_of_float timeout_span
|
||||
| _ -> 0
|
||||
|
||||
let is_body_forbidden = function Fetch.Get | Fetch.Head -> true | _ -> false
|
||||
|
||||
let request_body method_ body =
|
||||
if is_body_forbidden method_ && body <> "" then
|
||||
invalid_arg "GET and HEAD requests must not include a body"
|
||||
else if body = "" then None
|
||||
else Some (Fetch.BodyInit.make body)
|
||||
|
||||
let timeout controller timeout_span =
|
||||
match timeout_ms timeout_span with
|
||||
| 0 -> None
|
||||
| ms ->
|
||||
Some
|
||||
(Timer.set_timeout
|
||||
(fun () -> Fetch.AbortController.abort controller)
|
||||
ms)
|
||||
|
||||
let clear_timeout_opt = function
|
||||
| None -> ()
|
||||
| Some timeout_handle -> Timer.clear_timeout timeout_handle
|
||||
|
||||
let response_text response =
|
||||
Fetch.Response.text response
|
||||
|> Js.Promise.then_ (fun body -> Js.Promise.resolve (response, body))
|
||||
|
||||
let request ?timeout_span method_ url ~headers ~body =
|
||||
let controller = Fetch.AbortController.make () in
|
||||
let timeout_handle = timeout controller timeout_span in
|
||||
let body = request_body method_ body in
|
||||
let init =
|
||||
Fetch.RequestInit.make ~method_
|
||||
~headers:(Fetch.HeadersInit.makeWithArray (Rrbvec.to_array headers))
|
||||
?body
|
||||
~signal:(Fetch.AbortController.signal controller)
|
||||
()
|
||||
in
|
||||
promise_to_effect
|
||||
~on_settle:(fun () -> clear_timeout_opt timeout_handle)
|
||||
(Fetch.fetchWithInit url init |> Js.Promise.then_ response_text)
|
||||
end
|
||||
|
||||
module Crypto = struct
|
||||
module Node_crypto = struct
|
||||
type hash
|
||||
|
||||
external create_hash : string -> hash = "createHash" [@@mel.module "crypto"]
|
||||
external update : hash -> string -> string -> hash = "update" [@@mel.send]
|
||||
external digest : hash -> string -> string = "digest" [@@mel.send]
|
||||
|
||||
external random_bytes : int -> Node.Buffer.t = "randomBytes"
|
||||
[@@mel.module "crypto"]
|
||||
end
|
||||
|
||||
let sha256_digest output_encoding text =
|
||||
let hash = Node_crypto.create_hash "sha256" in
|
||||
let hash = Node_crypto.update hash text "latin1" in
|
||||
Node_crypto.digest hash output_encoding
|
||||
|
||||
let sha256_hex text = sha256_digest "hex" text
|
||||
let sha256_base64url text = sha256_digest "base64url" text
|
||||
|
||||
let random_base64url size =
|
||||
let text =
|
||||
Node_crypto.random_bytes size |> Node.Buffer.toString ~encoding:`base64url
|
||||
in
|
||||
if String.length text <= size then text else String.sub text 0 size
|
||||
|
||||
let base64url_decode text =
|
||||
Node.Buffer.fromStringWithEncoding text ~encoding:`base64url
|
||||
|> Node.Buffer.toString ~encoding:`utf8
|
||||
end
|
||||
|
||||
module Events = struct
|
||||
type subscription = { close : unit -> unit Cli_effect.t }
|
||||
type readable_stream
|
||||
type reader
|
||||
type read_result
|
||||
type text_decoder
|
||||
type uint8_array
|
||||
|
||||
external response_body : Fetch.Response.t -> readable_stream option = "body"
|
||||
[@@mel.get] [@@mel.return { null_to_opt }]
|
||||
|
||||
external get_reader : readable_stream -> reader = "getReader" [@@mel.send]
|
||||
external read : reader -> read_result Js.Promise.t = "read" [@@mel.send]
|
||||
external cancel : reader -> unit Js.Promise.t = "cancel" [@@mel.send]
|
||||
external read_done : read_result -> bool = "done" [@@mel.get]
|
||||
|
||||
external read_value : read_result -> uint8_array option = "value"
|
||||
[@@mel.get] [@@mel.return { undefined_to_opt }]
|
||||
|
||||
external make_decoder : unit -> text_decoder = "TextDecoder" [@@mel.new]
|
||||
|
||||
external decode :
|
||||
text_decoder -> uint8_array -> < stream : bool > Js.t -> string = "decode"
|
||||
[@@mel.send]
|
||||
|
||||
let stream_options =
|
||||
let options = Js.Obj.empty () in
|
||||
Js.Obj.assign options [%obj { stream = true }]
|
||||
|
||||
let rec read_loop closed decoder reader on_chunk =
|
||||
if !closed then Js.Promise.resolve ()
|
||||
else
|
||||
read reader
|
||||
|> Js.Promise.then_ (fun result ->
|
||||
if !closed || read_done result then Js.Promise.resolve ()
|
||||
else (
|
||||
result |> read_value
|
||||
|> Option.iter (fun value ->
|
||||
on_chunk (decode decoder value stream_options));
|
||||
read_loop closed decoder reader on_chunk))
|
||||
|
||||
let connect ~url ~on_chunk =
|
||||
let closed = ref false in
|
||||
let reader_ref = ref None in
|
||||
let controller = Fetch.AbortController.make () in
|
||||
let init =
|
||||
Fetch.RequestInit.make ~method_:Fetch.Get
|
||||
~headers:
|
||||
(Fetch.HeadersInit.makeWithArray
|
||||
[| ("Accept", "text/event-stream") |])
|
||||
~signal:(Fetch.AbortController.signal controller)
|
||||
()
|
||||
in
|
||||
Cli_effect.bind
|
||||
(HTTP.promise_to_effect (Fetch.fetchWithInit url init))
|
||||
(fun response ->
|
||||
if not (Fetch.Response.ok response) then
|
||||
Cli_effect.error
|
||||
(Js.Exn.raiseError
|
||||
("events request failed ("
|
||||
^ string_of_int (Fetch.Response.status response)
|
||||
^ ")"))
|
||||
else
|
||||
let request =
|
||||
(match response_body response with
|
||||
| None ->
|
||||
Fetch.Response.text response
|
||||
|> Js.Promise.then_ (fun text ->
|
||||
if not !closed then on_chunk text;
|
||||
Js.Promise.resolve ())
|
||||
| Some body ->
|
||||
let reader = get_reader body in
|
||||
reader_ref := Some reader;
|
||||
read_loop closed (make_decoder ()) reader on_chunk)
|
||||
|> Js.Promise.catch (fun _ -> Js.Promise.resolve ())
|
||||
in
|
||||
let close () =
|
||||
Fetch.AbortController.abort controller;
|
||||
(match !reader_ref with
|
||||
| None -> ()
|
||||
| Some reader ->
|
||||
ignore
|
||||
(cancel reader
|
||||
|> Js.Promise.catch (fun _ -> Js.Promise.resolve ())
|
||||
: unit Js.Promise.t));
|
||||
Cli_effect.catch (HTTP.promise_to_effect request) (fun _ ->
|
||||
Cli_effect.pure ())
|
||||
in
|
||||
Cli_effect.pure { close })
|
||||
end
|
||||
463
cli/lib/platform/node/cli_unix.ml
Normal file
463
cli/lib/platform/node/cli_unix.ml
Normal file
@@ -0,0 +1,463 @@
|
||||
type error = EAGAIN | EWOULDBLOCK | ETIMEDOUT | ESRCH | EPERM
|
||||
type access_permission = R_OK | W_OK
|
||||
type open_flag = O_RDWR
|
||||
type file_descr = int
|
||||
type stats = { st_size : int; st_mtime : float }
|
||||
type process_result = { status : int; stdout : string; stderr : string }
|
||||
type mkdir_result = Created | Already_exists
|
||||
|
||||
exception Cli_unix_error of error * string * string
|
||||
|
||||
module Fs = struct
|
||||
type mkdir_options
|
||||
type rm_options
|
||||
type stat
|
||||
|
||||
external mkdir_options : mode:int -> unit -> mkdir_options = "" [@@mel.obj]
|
||||
|
||||
external rm_options : recursive:bool -> force:bool -> unit -> rm_options = ""
|
||||
[@@mel.obj]
|
||||
|
||||
external mkdir_sync : string -> mkdir_options -> unit = "mkdirSync"
|
||||
[@@mel.module "fs"]
|
||||
|
||||
external stat_sync : string -> stat = "statSync" [@@mel.module "fs"]
|
||||
|
||||
external read_fd_utf8_sync : int -> (_[@mel.as "utf8"]) -> string
|
||||
= "readFileSync"
|
||||
[@@mel.module "fs"]
|
||||
|
||||
external copy_file_sync : string -> string -> unit = "copyFileSync"
|
||||
[@@mel.module "fs"]
|
||||
|
||||
external rm_sync : string -> rm_options -> unit = "rmSync" [@@mel.module "fs"]
|
||||
external chmod_sync : string -> int -> unit = "chmodSync" [@@mel.module "fs"]
|
||||
|
||||
external access_sync : string -> int -> unit = "accessSync"
|
||||
[@@mel.module "fs"]
|
||||
|
||||
external open_sync : string -> string -> int = "openSync" [@@mel.module "fs"]
|
||||
external close_sync : int -> unit = "closeSync" [@@mel.module "fs"]
|
||||
external mkdtemp_sync : string -> string = "mkdtempSync" [@@mel.module "fs"]
|
||||
external size : stat -> int = "size" [@@mel.get]
|
||||
external mtime_ms : stat -> float = "mtimeMs" [@@mel.get]
|
||||
external is_directory : stat -> bool = "isDirectory" [@@mel.send]
|
||||
end
|
||||
|
||||
module Os = struct
|
||||
external hostname : unit -> string = "hostname" [@@mel.module "os"]
|
||||
external tmpdir : unit -> string = "tmpdir" [@@mel.module "os"]
|
||||
end
|
||||
|
||||
module Process = struct
|
||||
type writable
|
||||
|
||||
external pid : int = "pid" [@@mel.module "process"]
|
||||
external stdout : writable = "stdout" [@@mel.module "process"]
|
||||
external kill : int -> int -> unit = "kill" [@@mel.module "process"]
|
||||
external write : writable -> string -> bool = "write" [@@mel.send]
|
||||
end
|
||||
|
||||
module Child_process = struct
|
||||
type spawn_options
|
||||
type spawn_sync_options
|
||||
type child
|
||||
type spawn_result
|
||||
|
||||
external spawn_options :
|
||||
?detached:bool ->
|
||||
?stdio:Js.Json.t array ->
|
||||
?env:string Js.Dict.t ->
|
||||
?shell:bool ->
|
||||
unit ->
|
||||
spawn_options = ""
|
||||
[@@mel.obj]
|
||||
|
||||
external spawn_sync_options :
|
||||
?encoding:string ->
|
||||
?env:string Js.Dict.t ->
|
||||
?shell:bool ->
|
||||
unit ->
|
||||
spawn_sync_options = ""
|
||||
[@@mel.obj]
|
||||
|
||||
external spawn : string -> string array -> spawn_options -> child = "spawn"
|
||||
[@@mel.module "child_process"]
|
||||
|
||||
external spawn_sync :
|
||||
string -> string array -> spawn_sync_options -> spawn_result = "spawnSync"
|
||||
[@@mel.module "child_process"]
|
||||
|
||||
external pid : child -> int Js.nullable = "pid" [@@mel.get]
|
||||
external unref : child -> unit = "unref" [@@mel.send]
|
||||
external status : spawn_result -> int Js.nullable = "status" [@@mel.get]
|
||||
external stdout : spawn_result -> string Js.nullable = "stdout" [@@mel.get]
|
||||
external stderr : spawn_result -> string Js.nullable = "stderr" [@@mel.get]
|
||||
external error : spawn_result -> Js.Exn.t Js.nullable = "error" [@@mel.get]
|
||||
end
|
||||
|
||||
module Atomics_sleep = struct
|
||||
type shared_array_buffer
|
||||
type int32_array
|
||||
|
||||
external make_shared_array_buffer : int -> shared_array_buffer
|
||||
= "SharedArrayBuffer"
|
||||
[@@mel.new]
|
||||
|
||||
external make_int32_array : shared_array_buffer -> int32_array = "Int32Array"
|
||||
[@@mel.new]
|
||||
|
||||
external wait : int32_array -> int -> int -> int -> string = "wait"
|
||||
[@@mel.scope "Atomics"]
|
||||
|
||||
let buffer = make_int32_array (make_shared_array_buffer 4)
|
||||
let sleep_ms ms = ignore (wait buffer 0 0 ms : string)
|
||||
end
|
||||
|
||||
external error_code : Js.Exn.t -> string option = "code" [@@mel.get]
|
||||
|
||||
let js_error_message exn =
|
||||
match Js.Exn.asJsExn exn with
|
||||
| Some error ->
|
||||
Option.value (Js.Exn.message error) ~default:(Printexc.to_string exn)
|
||||
| None -> Printexc.to_string exn
|
||||
|
||||
let js_error_code exn =
|
||||
match Js.Exn.asJsExn exn with Some error -> error_code error | None -> None
|
||||
|
||||
let unix_error_of_code = function
|
||||
| Some "EAGAIN" -> EAGAIN
|
||||
| Some "EWOULDBLOCK" -> EWOULDBLOCK
|
||||
| Some "ETIMEDOUT" -> ETIMEDOUT
|
||||
| Some ("ENOENT" | "ESRCH") -> ESRCH
|
||||
| Some ("EACCES" | "EPERM") -> EPERM
|
||||
| _ -> EPERM
|
||||
|
||||
let raise_error ?error op detail exn =
|
||||
let detail =
|
||||
let message = js_error_message exn in
|
||||
if String.trim message = "" then detail else message
|
||||
in
|
||||
let error =
|
||||
Option.value error ~default:(unix_error_of_code (js_error_code exn))
|
||||
in
|
||||
raise (Cli_unix_error (error, op, detail))
|
||||
|
||||
let run_unit op detail fn = try fn () with exn -> raise_error op detail exn
|
||||
|
||||
let mkdir path perm =
|
||||
run_unit "mkdir" path (fun () ->
|
||||
Fs.mkdir_sync path (Fs.mkdir_options ~mode:perm ()))
|
||||
|
||||
let rmdir path = run_unit "rmdir" path (fun () -> Node.Fs.rmdirSync path)
|
||||
|
||||
let mkdir_exclusive path perm =
|
||||
try
|
||||
Fs.mkdir_sync path (Fs.mkdir_options ~mode:perm ());
|
||||
Created
|
||||
with exn -> (
|
||||
match js_error_code exn with
|
||||
| Some "EEXIST" -> Already_exists
|
||||
| _ -> raise_error "mkdir" path exn)
|
||||
|
||||
let file_exists = Node.Fs.existsSync
|
||||
|
||||
let is_directory path =
|
||||
try Fs.is_directory (Fs.stat_sync path) with _ -> false
|
||||
|
||||
let readdir path =
|
||||
try Node.Fs.readdirSync path with exn -> raise_error "readdir" path exn
|
||||
|
||||
let rec mkdir_p path =
|
||||
if path = "" || path = Filename.dirname path || file_exists path then ()
|
||||
else (
|
||||
mkdir_p (Filename.dirname path);
|
||||
match mkdir_exclusive path 0o755 with Created | Already_exists -> ())
|
||||
|
||||
let write_text_file path content =
|
||||
run_unit "write" path (fun () -> Node.Fs.writeFileAsUtf8Sync path content)
|
||||
|
||||
let read_text_file path =
|
||||
try Node.Fs.readFileAsUtf8Sync path with exn -> raise_error "read" path exn
|
||||
|
||||
let read_stdin_all () =
|
||||
try Fs.read_fd_utf8_sync 0 with exn -> raise_error "read" "stdin" exn
|
||||
|
||||
let write_binary_file path content =
|
||||
run_unit "write" path (fun () -> Node.Fs.writeFileSync path content `latin1)
|
||||
|
||||
let read_binary_file path =
|
||||
try Node.Fs.readFileSync path `latin1
|
||||
with exn -> raise_error "read" path exn
|
||||
|
||||
let copy_file source destination =
|
||||
run_unit "copy" source (fun () -> Fs.copy_file_sync source destination)
|
||||
|
||||
let remove_tree path =
|
||||
run_unit "rm" path (fun () ->
|
||||
Fs.rm_sync path (Fs.rm_options ~recursive:true ~force:true ()))
|
||||
|
||||
let rename source destination =
|
||||
run_unit "rename" source (fun () -> Node.Fs.renameSync source destination)
|
||||
|
||||
let getpid () = Process.pid
|
||||
|
||||
let process_running pid =
|
||||
pid > 0
|
||||
&&
|
||||
try
|
||||
Process.kill pid 0;
|
||||
true
|
||||
with exn -> (
|
||||
match js_error_code exn with Some "ESRCH" -> false | _ -> true)
|
||||
|
||||
let chmod path perm = run_unit "chmod" path (fun () -> Fs.chmod_sync path perm)
|
||||
|
||||
let access path permissions =
|
||||
let flag =
|
||||
Rrbvec.fold_left
|
||||
(fun acc -> function R_OK -> acc lor 4 | W_OK -> acc lor 2)
|
||||
0 permissions
|
||||
in
|
||||
try Fs.access_sync path flag
|
||||
with _ ->
|
||||
if file_exists path then raise (Cli_unix_error (EPERM, "access", path))
|
||||
else raise (Cli_unix_error (ESRCH, "access", path))
|
||||
|
||||
let stat path =
|
||||
try
|
||||
let stat = Fs.stat_sync path in
|
||||
{ st_size = Fs.size stat; st_mtime = Fs.mtime_ms stat /. 1000. }
|
||||
with exn -> raise_error "stat" path exn
|
||||
|
||||
let environment () =
|
||||
Node.Process.process##env |> Js.Dict.entries
|
||||
|> Array.map (fun (key, value) -> key ^ "=" ^ value)
|
||||
|
||||
let gethostname () = try Os.hostname () with _ -> ""
|
||||
let openfile _path _flags _perm = 0
|
||||
let close _fd = ()
|
||||
|
||||
let command_args argv =
|
||||
let argv = Rrbvec.of_array argv in
|
||||
match Rrbvec.pop_front argv with
|
||||
| Some ("env", rest) -> (
|
||||
match Rrbvec.pop_front rest with
|
||||
| Some (command, args) -> (command, args)
|
||||
| None ->
|
||||
raise
|
||||
(Cli_unix_error (EPERM, "create_process_env", "missing command")))
|
||||
| Some (command, args) -> (command, args)
|
||||
| None ->
|
||||
raise (Cli_unix_error (EPERM, "create_process_env", "missing command"))
|
||||
|
||||
let copy_env env =
|
||||
let result = Js.Dict.empty () in
|
||||
Node.Process.process##env |> Js.Dict.entries
|
||||
|> Array.iter (fun (key, value) -> Js.Dict.set result key value);
|
||||
Array.iter
|
||||
(fun entry ->
|
||||
match String.index_opt entry '=' with
|
||||
| None -> ()
|
||||
| Some index ->
|
||||
Js.Dict.set result (String.sub entry 0 index)
|
||||
(String.sub entry (index + 1) (String.length entry - index - 1)))
|
||||
env;
|
||||
result
|
||||
|
||||
let stdio_ignore =
|
||||
[|
|
||||
Js.Json.string "ignore"; Js.Json.string "ignore"; Js.Json.string "ignore";
|
||||
|]
|
||||
|
||||
let spawn_detached command args env =
|
||||
let child =
|
||||
Child_process.spawn command (Rrbvec.to_array args)
|
||||
(Child_process.spawn_options ~detached:true ~stdio:stdio_ignore
|
||||
~env:(copy_env env) ~shell:false ())
|
||||
in
|
||||
Child_process.unref child;
|
||||
Child_process.pid child |> Js.Nullable.toOption |> Option.value ~default:0
|
||||
|
||||
let windows_verbatim_spawn_options env : Child_process.spawn_options =
|
||||
let make : string Js.Dict.t -> Js.Json.t array -> Child_process.spawn_options
|
||||
=
|
||||
[%mel.raw
|
||||
{|
|
||||
function (env, stdio) {
|
||||
return {
|
||||
detached: true,
|
||||
stdio: stdio,
|
||||
env: env,
|
||||
shell: false,
|
||||
windowsVerbatimArguments: true
|
||||
};
|
||||
}
|
||||
|}]
|
||||
in
|
||||
make (copy_env env) stdio_ignore
|
||||
|
||||
let spawn_detached_windows_verbatim command args env =
|
||||
let child =
|
||||
Child_process.spawn command (Rrbvec.to_array args)
|
||||
(windows_verbatim_spawn_options env)
|
||||
in
|
||||
Child_process.unref child;
|
||||
Child_process.pid child |> Js.Nullable.toOption |> Option.value ~default:0
|
||||
|
||||
let create_process_env _prog argv env _stdin _stdout _stderr =
|
||||
let command, args = command_args argv in
|
||||
try spawn_detached command args env
|
||||
with exn -> raise_error "create_process_env" command exn
|
||||
|
||||
let nullable_string_default value =
|
||||
value |> Js.Nullable.toOption |> Option.value ~default:""
|
||||
|
||||
let run_process_capture command args env =
|
||||
let result =
|
||||
Child_process.spawn_sync command (Rrbvec.to_array args)
|
||||
(Child_process.spawn_sync_options ~encoding:"utf8" ~env:(copy_env env)
|
||||
~shell:false ())
|
||||
in
|
||||
let status =
|
||||
result |> Child_process.status |> Js.Nullable.toOption
|
||||
|> Option.value ~default:1
|
||||
in
|
||||
let stderr =
|
||||
match result |> Child_process.error |> Js.Nullable.toOption with
|
||||
| Some error ->
|
||||
Option.value (Js.Exn.message error)
|
||||
~default:(nullable_string_default (Child_process.stderr result))
|
||||
| None -> nullable_string_default (Child_process.stderr result)
|
||||
in
|
||||
{
|
||||
status;
|
||||
stdout = nullable_string_default (Child_process.stdout result);
|
||||
stderr;
|
||||
}
|
||||
|
||||
let read_text_file_default path =
|
||||
try Node.Fs.readFileAsUtf8Sync path with _ -> ""
|
||||
|
||||
let contains_substring ~needle haystack =
|
||||
let needle_len = String.length needle in
|
||||
let haystack_len = String.length haystack in
|
||||
let rec loop index =
|
||||
if needle_len = 0 then true
|
||||
else if index + needle_len > haystack_len then false
|
||||
else if String.sub haystack index needle_len = needle then true
|
||||
else loop (index + 1)
|
||||
in
|
||||
loop 0
|
||||
|
||||
let split_lines text =
|
||||
let len = String.length text in
|
||||
let rec loop start index acc =
|
||||
if index = len then
|
||||
Rrbvec.push_back acc (String.sub text start (index - start))
|
||||
else if text.[index] = '\n' then
|
||||
let acc = Rrbvec.push_back acc (String.sub text start (index - start)) in
|
||||
loop (index + 1) (index + 1) acc
|
||||
else loop start (index + 1) acc
|
||||
in
|
||||
loop 0 0 Rrbvec.empty
|
||||
|
||||
let find_session_line text =
|
||||
text |> split_lines
|
||||
|> Rrbvec.find_opt (fun line ->
|
||||
let lower = String.lowercase_ascii line in
|
||||
contains_substring ~needle:"session" lower
|
||||
|| contains_substring ~needle:"thread" lower)
|
||||
|
||||
let start_process_capture_session_line command args env =
|
||||
let tmp_dir =
|
||||
Fs.mkdtemp_sync (Node.Path.join [| Os.tmpdir (); "logseq-cli-session-" |])
|
||||
in
|
||||
let stdout_path = Node.Path.join [| tmp_dir; "stdout.log" |] in
|
||||
let stderr_path = Node.Path.join [| tmp_dir; "stderr.log" |] in
|
||||
let stdout_fd = Fs.open_sync stdout_path "a" in
|
||||
let stderr_fd = Fs.open_sync stderr_path "a" in
|
||||
let child =
|
||||
try
|
||||
Child_process.spawn command (Rrbvec.to_array args)
|
||||
(Child_process.spawn_options ~detached:true
|
||||
~stdio:
|
||||
[|
|
||||
Js.Json.string "ignore";
|
||||
Js.Json.number (float_of_int stdout_fd);
|
||||
Js.Json.number (float_of_int stderr_fd);
|
||||
|]
|
||||
~env:(copy_env env) ~shell:false ())
|
||||
with exn ->
|
||||
(try Fs.close_sync stdout_fd with _ -> ());
|
||||
(try Fs.close_sync stderr_fd with _ -> ());
|
||||
raise_error "spawn" command exn
|
||||
in
|
||||
(try Fs.close_sync stdout_fd with _ -> ());
|
||||
(try Fs.close_sync stderr_fd with _ -> ());
|
||||
let pid =
|
||||
Child_process.pid child |> Js.Nullable.toOption |> Option.value ~default:0
|
||||
in
|
||||
let deadline = Js.Date.now () +. 30_000. in
|
||||
let rec loop last_stdout =
|
||||
let stdout = read_text_file_default stdout_path in
|
||||
match find_session_line stdout with
|
||||
| Some line ->
|
||||
Child_process.unref child;
|
||||
{
|
||||
status = 0;
|
||||
stdout = line;
|
||||
stderr = read_text_file_default stderr_path;
|
||||
}
|
||||
| None when Js.Date.now () >= deadline ->
|
||||
Child_process.unref child;
|
||||
{
|
||||
status = 124;
|
||||
stdout = (if stdout = "" then last_stdout else stdout);
|
||||
stderr =
|
||||
(let stderr = read_text_file_default stderr_path in
|
||||
if String.trim stderr = "" then "timed out waiting for session id"
|
||||
else stderr);
|
||||
}
|
||||
| None when pid <= 0 || not (process_running pid) ->
|
||||
{ status = 1; stdout; stderr = read_text_file_default stderr_path }
|
||||
| None ->
|
||||
Atomics_sleep.sleep_ms 50;
|
||||
loop stdout
|
||||
in
|
||||
loop ""
|
||||
|
||||
let kill pid signal =
|
||||
try Process.kill pid signal
|
||||
with _ -> raise (Cli_unix_error (ESRCH, "kill", string_of_int pid))
|
||||
|
||||
let unquote_double_quoted value =
|
||||
let len = String.length value in
|
||||
if len > 1 && value.[0] = '"' && value.[len - 1] = '"' then
|
||||
String.sub value 1 (len - 2)
|
||||
else value
|
||||
|
||||
let windows_start_url_command url =
|
||||
"start \"\" \"" ^ unquote_double_quoted url ^ "\""
|
||||
|
||||
let open_url url =
|
||||
try
|
||||
let platform = Node.Process.process##platform in
|
||||
let command, args =
|
||||
match platform with
|
||||
| "darwin" -> ("open", Rrbvec.of_array [| url |])
|
||||
| "linux" -> ("xdg-open", Rrbvec.of_array [| url |])
|
||||
| "win32" ->
|
||||
( "cmd.exe",
|
||||
Rrbvec.of_array [| "/d"; "/c"; windows_start_url_command url |] )
|
||||
| _ -> raise (Cli_unix_error (EPERM, "open", url))
|
||||
in
|
||||
ignore
|
||||
((if platform = "win32" then spawn_detached_windows_verbatim
|
||||
else spawn_detached)
|
||||
command args (environment ())
|
||||
: int);
|
||||
true
|
||||
with _ -> false
|
||||
|
||||
let write_stdout text = ignore (Process.write Process.stdout text : bool)
|
||||
7
cli/lib/platform/node/dune
Normal file
7
cli/lib/platform/node/dune
Normal file
@@ -0,0 +1,7 @@
|
||||
(library
|
||||
(name logseq_cli_platform_node)
|
||||
(implements logseq_cli_platform_spec)
|
||||
(modes melange)
|
||||
(preprocess
|
||||
(pps melange.ppx))
|
||||
(libraries melange-fetch melange.js melange.node rrbvec))
|
||||
Reference in New Issue
Block a user