Dasemu
40631362b3
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>
1846 lines
63 KiB
OCaml
1846 lines
63 KiB
OCaml
type target =
|
|
| By_id of Cli_primitive.db_id
|
|
| By_ids of Cli_primitive.db_id Rrbvec.t
|
|
| By_uuid of Cli_primitive.uuid
|
|
| By_page of string
|
|
|
|
type opts = {
|
|
id_raw : string option;
|
|
uuid : Cli_primitive.uuid option;
|
|
page : string option;
|
|
page_hierarchy : bool;
|
|
linked_references : bool option;
|
|
ref_id_footer : bool option;
|
|
level : int option;
|
|
stdin_id : string option;
|
|
}
|
|
|
|
type parsed = Parsed_show of opts
|
|
|
|
type action = {
|
|
repo : Cli_primitive.repo;
|
|
graph : Cli_primitive.graph;
|
|
target : target;
|
|
multi_id : bool;
|
|
linked_references : bool;
|
|
ref_id_footer : bool;
|
|
page_hierarchy : bool;
|
|
level : int option;
|
|
}
|
|
|
|
type linked_references = { count : int; blocks : Block.t Rrbvec.t }
|
|
|
|
type tree_data = {
|
|
root : Block.t;
|
|
linked_references : linked_references option;
|
|
referenced_uuids : Cli_primitive.uuid Rrbvec.t;
|
|
uuid_to_entity : (Cli_primitive.uuid * Entity.t) Rrbvec.t;
|
|
breadcrumb_line : string option;
|
|
}
|
|
|
|
let is_integer_text value =
|
|
let value = String.trim value in
|
|
let len = String.length value in
|
|
if len = 0 then false
|
|
else
|
|
let start = if value.[0] = '-' then 1 else 0 in
|
|
start < len
|
|
&& String.for_all
|
|
(fun c -> c >= '0' && c <= '9')
|
|
(String.sub value start (len - start))
|
|
|
|
let split_lines value =
|
|
Vec.split_on_char '\n' value
|
|
|> Vec.map String.trim
|
|
|> Vec.filter (fun line -> line <> "")
|
|
|
|
let split_ws value =
|
|
Vec.split_on_char ' ' value
|
|
|> Vec.concat_map (fun value -> Vec.split_on_char '\t' value)
|
|
|> Vec.map String.trim
|
|
|> Vec.filter (fun token -> token <> "")
|
|
|
|
let bracketed_id_vector value =
|
|
let value = String.trim value in
|
|
let len = String.length value in
|
|
len >= 2
|
|
&& value.[0] = '['
|
|
&& value.[len - 1] = ']'
|
|
&&
|
|
let body = String.sub value 1 (len - 2) in
|
|
Vec.split_on_char ',' body |> Vec.concat_map split_ws
|
|
|> Vec.for_all is_integer_text
|
|
|
|
let normalize_stdin_id = function
|
|
| Some raw ->
|
|
let text = String.trim raw in
|
|
if text = "" then None
|
|
else if bracketed_id_vector text || is_integer_text text then Some text
|
|
else
|
|
let lines = split_lines text in
|
|
let last_line = Option.value (Vec.peek_back_opt lines) ~default:"" in
|
|
if bracketed_id_vector last_line then Some last_line
|
|
else
|
|
let tokens = split_ws text in
|
|
if (not (Vec.is_empty tokens)) && Vec.for_all is_integer_text tokens
|
|
then
|
|
Some
|
|
(Melange_edn_melange.to_edn_string
|
|
(Edn_util.vector_vec
|
|
(tokens
|
|
|> Vec.map (fun token ->
|
|
Edn_util.int64 (Int64.of_string token)))))
|
|
else Some text
|
|
| None -> None
|
|
|
|
let id_raw opts =
|
|
match opts.id_raw with
|
|
| Some _ as id -> id
|
|
| None -> normalize_stdin_id opts.stdin_id
|
|
|
|
let count_present values = values |> Vec.filter Option.is_some |> Vec.length
|
|
|
|
let target_count opts =
|
|
count_present
|
|
(Vec.of_array [| opts.id_raw; opts.stdin_id; opts.uuid; opts.page |])
|
|
|
|
let resolve_target opts =
|
|
match id_raw opts with
|
|
| Some s -> (
|
|
match Id_parse.parse_id_string s with
|
|
| Ok { ids; _ } when Vec.length ids = 1 -> Ok (By_id (Vec.nth ids 0))
|
|
| Ok { ids; _ } when not (Vec.is_empty ids) -> Ok (By_ids ids)
|
|
| Ok _ -> Error (Error.invalid_options "invalid id")
|
|
| Error e -> Error e)
|
|
| None -> (
|
|
match (opts.uuid, opts.page) with
|
|
| Some uuid, _ ->
|
|
let uuid = String.trim uuid in
|
|
if Cli_primitive.is_uuid_string uuid then Ok (By_uuid uuid)
|
|
else
|
|
Error
|
|
(Error.invalid_options "Option uuid must be a valid UUID string")
|
|
| None, Some page when String.trim page <> "" ->
|
|
Ok (By_page (String.trim page))
|
|
| _ -> Error (Error.missing_target "block or page is required"))
|
|
|
|
let invalid_options (opts : opts) =
|
|
if target_count opts > 1 then
|
|
Some "only one of --id, --uuid, or --page is allowed"
|
|
else
|
|
match opts.level with
|
|
| Some level when level < 1 -> Some "level must be >= 1"
|
|
| _ -> None
|
|
|
|
let command_id _ = Command_id.Show
|
|
let default_level = 10
|
|
|
|
let validate_parsed (Parsed_show opts) =
|
|
match invalid_options opts with
|
|
| Some message -> Error (Error.invalid_options message)
|
|
| None -> Ok ()
|
|
|
|
let build ?registry:_ config _globals (Parsed_show opts) =
|
|
match config.Cli_config.repo with
|
|
| None -> Error (Error.missing_repo "repo is required for show")
|
|
| Some repo ->
|
|
Error.bind (validate_parsed (Parsed_show opts)) (fun () ->
|
|
Error.bind (resolve_target opts) (fun target ->
|
|
Ok
|
|
{
|
|
repo;
|
|
graph = Cli_config.repo_to_graph repo;
|
|
target;
|
|
multi_id = (match target with By_ids _ -> true | _ -> false);
|
|
linked_references =
|
|
Option.value opts.linked_references ~default:true;
|
|
ref_id_footer = Option.value opts.ref_id_footer ~default:true;
|
|
page_hierarchy = opts.page_hierarchy;
|
|
level = Some (Option.value opts.level ~default:default_level);
|
|
}))
|
|
|
|
let kw value = Edn_util.keyword value
|
|
let sym value = Edn_util.symbol value
|
|
let vector_vec values = Edn_util.vector_vec values
|
|
let wildcard = sym "*"
|
|
|
|
let link_target_selector =
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
wildcard;
|
|
kw "db/id";
|
|
kw "db/ident";
|
|
kw "block/uuid";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "block/order";
|
|
kw "logseq.property/deleted-at";
|
|
kw "logseq.property/created-from-property";
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "logseq.property/status",
|
|
vector_vec
|
|
(Vec.of_array [| kw "db/ident"; kw "block/title" |]) );
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "block/page",
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
kw "db/id";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "block/uuid";
|
|
|]) );
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "block/parent",
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
kw "db/id";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "block/uuid";
|
|
|]) );
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "block/tags",
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
kw "db/id";
|
|
kw "db/ident";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "block/uuid";
|
|
|]) );
|
|
|]);
|
|
|])
|
|
|
|
let pull_selector =
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
wildcard;
|
|
kw "db/id";
|
|
kw "db/ident";
|
|
kw "block/uuid";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "block/order";
|
|
kw "logseq.property/deleted-at";
|
|
kw "logseq.property/created-from-property";
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "logseq.property/status",
|
|
vector_vec
|
|
(Vec.of_array [| kw "db/ident"; kw "block/title" |]) );
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "block/page",
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
kw "db/id";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "block/uuid";
|
|
|]) );
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "block/parent",
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
kw "db/id";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "block/uuid";
|
|
|]) );
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "block/tags",
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
kw "db/id";
|
|
kw "db/ident";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "block/uuid";
|
|
|]) );
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array [| (kw "block/link", link_target_selector) |]);
|
|
|])
|
|
|
|
let lookup_of_target = function
|
|
| By_id id -> Edn_util.int64 id
|
|
| By_uuid uuid ->
|
|
vector_vec (Vec.of_array [| kw "block/uuid"; Edn_util.uuid uuid |])
|
|
| By_page page ->
|
|
vector_vec (Vec.of_array [| kw "block/name"; Edn_util.string page |])
|
|
| By_ids _ -> Edn_util.nil
|
|
|
|
let strip_keyword_prefix value =
|
|
if String.length value > 0 && value.[0] = ':' then
|
|
String.sub value 1 (String.length value - 1)
|
|
else value
|
|
|
|
let value_key_matches expected key_value =
|
|
let expected = strip_keyword_prefix expected in
|
|
match (Edn_util.as_keyword key_value, Edn_util.as_string key_value) with
|
|
| Some key, _ | _, Some key -> strip_keyword_prefix key = expected
|
|
| _ -> false
|
|
|
|
let string_starts_with ~prefix value =
|
|
let prefix_len = String.length prefix in
|
|
String.length value >= prefix_len && String.sub value 0 prefix_len = prefix
|
|
|
|
let show_internal_key key_value =
|
|
match (Edn_util.as_keyword key_value, Edn_util.as_string key_value) with
|
|
| Some key, _ | _, Some key ->
|
|
string_starts_with ~prefix:"show/" (strip_keyword_prefix key)
|
|
| _ -> false
|
|
|
|
let structured_internal_key key =
|
|
value_key_matches "block/uuid" key || show_internal_key key
|
|
|
|
let rec sanitize_structured_value value =
|
|
match Edn_util.as_map value with
|
|
| Some fields ->
|
|
fields
|
|
|> Vec.filter (fun (key, _) -> not (structured_internal_key key))
|
|
|> Vec.map (fun (key, value) -> (key, sanitize_structured_value value))
|
|
|> fun fields -> Edn_util.map_vec fields
|
|
| None -> (
|
|
match Edn_util.as_list value with
|
|
| Some values ->
|
|
Edn_util.list_vec (values |> Vec.map sanitize_structured_value)
|
|
| None -> (
|
|
match Edn_util.as_vector value with
|
|
| Some values ->
|
|
Edn_util.vector_vec (values |> Vec.map sanitize_structured_value)
|
|
| None -> (
|
|
match Edn_util.as_set value with
|
|
| Some values ->
|
|
Edn_util.set_vec (values |> Vec.map sanitize_structured_value)
|
|
| None -> value)))
|
|
|
|
let linked_references_value (refs : linked_references) =
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
(kw "count", Edn_util.int refs.count);
|
|
( kw "blocks",
|
|
Edn_util.vector_vec
|
|
(Vec.map
|
|
(fun block -> sanitize_structured_value block.Block.raw)
|
|
refs.blocks) );
|
|
|])
|
|
|
|
let tree_data_value root linked_references =
|
|
let fields = Vec.singleton (kw "root", sanitize_structured_value root) in
|
|
let fields =
|
|
match linked_references with
|
|
| Some refs ->
|
|
Vec.push_back fields
|
|
(kw "linked-references", linked_references_value refs)
|
|
| None -> fields
|
|
in
|
|
Edn_util.map_vec fields
|
|
|
|
let missing_entity value =
|
|
if Edn_util.is_null value then true
|
|
else
|
|
match Edn_util.as_map value with
|
|
| Some fields -> Vec.mem_assoc (kw "db/id") fields && Vec.length fields = 1
|
|
| _ -> false
|
|
|
|
let property_value_block value =
|
|
Option.is_some (Edn_util.get value "logseq.property/created-from-property")
|
|
|
|
let recycled_page value =
|
|
Option.is_some (Edn_util.get value "block/name")
|
|
&& Option.is_some (Edn_util.get value "logseq.property/deleted-at")
|
|
|
|
let recycled_page_error () = Error.make Error.Recycled_page "page is recycled"
|
|
|
|
let ident_value value =
|
|
Option.map strip_keyword_prefix
|
|
(Option.bind (Edn_util.get value "db/ident") Edn_util.as_string_like)
|
|
|
|
let tag_ident_matches expected tag =
|
|
let expected = strip_keyword_prefix expected in
|
|
match Edn_util.as_string_like tag with
|
|
| Some ident -> strip_keyword_prefix ident = expected
|
|
| None -> (
|
|
match Edn_util.as_map tag with
|
|
| Some _ -> ident_value tag = Some expected
|
|
| None -> false)
|
|
|
|
let has_tag_ident value expected =
|
|
match Option.bind (Edn_util.get value "block/tags") Edn_util.as_seq with
|
|
| Some tags -> Vec.exists (tag_ident_matches expected) tags
|
|
| _ -> false
|
|
|
|
let page_hierarchy_display_page value =
|
|
(has_tag_ident value "logseq.class/Page"
|
|
|| has_tag_ident value "logseq.class/Journal")
|
|
&& (not (has_tag_ident value "logseq.class/Tag"))
|
|
&& not (has_tag_ident value "logseq.class/Property")
|
|
|
|
let page_hierarchy_target_page value =
|
|
page_hierarchy_display_page value
|
|
&& Option.is_none (Edn_util.get value "block/page")
|
|
|
|
let library_page value =
|
|
Edn_util.get_bool value "logseq.property/built-in?" = Some true
|
|
&& Edn_util.get_string value "block/title" = Some "Library"
|
|
|
|
let entity_error = function
|
|
| By_page _ -> Error.make Error.Page_not_found "page not found"
|
|
| _ -> Error.make Error.Entity_not_found "entity not found"
|
|
|
|
exception Show_error of Error.t
|
|
|
|
let block_link_target_not_found () =
|
|
Error.make Error.Block_link_target_not_found "block link target not found"
|
|
|
|
let block_link_cycle () =
|
|
Error.make Error.Block_link_cycle "block link cycle detected"
|
|
|
|
let page_hierarchy_parent_cycle () =
|
|
Error.make Error.Page_hierarchy_parent_cycle
|
|
"page hierarchy parent cycle detected"
|
|
|
|
let fail_show_error err = Cli_effect.error (Show_error err)
|
|
|
|
let multi_id_error_value id err =
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
(kw "id", Edn_util.int64 id);
|
|
( kw "error",
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "code",
|
|
Edn_util.string (Error.code_to_string err.Error.code) );
|
|
( kw "message",
|
|
Edn_util.string
|
|
("Entity " ^ Int64.to_string id ^ " not found") );
|
|
|]) );
|
|
|])
|
|
|
|
let multi_id_error_message id _err =
|
|
"Entity " ^ Int64.to_string id ^ " not found"
|
|
|
|
let pull_entity config repo target =
|
|
let open Cli_effect in
|
|
bind
|
|
(Transport.thread_api_pull config ~repo
|
|
~selector:(Edn_util.expect_vector_t "show pull selector" pull_selector)
|
|
~lookup:(lookup_of_target target))
|
|
(fun value -> pure value)
|
|
|
|
let tree_block_selector =
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
wildcard;
|
|
kw "db/id";
|
|
kw "db/ident";
|
|
kw "block/uuid";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "logseq.property/created-from-property";
|
|
kw "block/order";
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "logseq.property/status",
|
|
vector_vec
|
|
(Vec.of_array [| kw "db/ident"; kw "block/title" |]) );
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
(kw "block/parent", vector_vec (Vec.of_array [| kw "db/id" |]));
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "block/page",
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
kw "db/id";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "block/uuid";
|
|
|]) );
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array
|
|
[|
|
|
( kw "block/tags",
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
kw "db/id";
|
|
kw "db/ident";
|
|
kw "block/name";
|
|
kw "block/title";
|
|
kw "block/uuid";
|
|
|]) );
|
|
|]);
|
|
Edn_util.map_vec
|
|
(Vec.of_array [| (kw "block/link", link_target_selector) |]);
|
|
|])
|
|
|
|
let page_blocks_query =
|
|
Cli_primitive.make_datascript_query
|
|
~find:
|
|
(Vec.singleton
|
|
(Edn_util.list_vec
|
|
(Vec.of_array [| sym "pull"; sym "?b"; tree_block_selector |])))
|
|
~in_:
|
|
(Vec.of_array
|
|
[|
|
|
Melange_edn_melange.symbol "$"; Melange_edn_melange.symbol "?page-id";
|
|
|])
|
|
~where:
|
|
(Vec.of_array
|
|
[|
|
|
Cli_primitive.V
|
|
(Edn_util.vector_t_vec
|
|
(Vec.of_array [| sym "?b"; kw "block/page"; sym "?page-id" |]));
|
|
|])
|
|
()
|
|
|
|
let page_hierarchy_children_query =
|
|
Cli_primitive.make_datascript_query
|
|
~find:
|
|
(Vec.singleton
|
|
(Edn_util.list_vec
|
|
(Vec.of_array [| sym "pull"; sym "?child"; tree_block_selector |])))
|
|
~in_:
|
|
(Vec.of_array
|
|
[|
|
|
Melange_edn_melange.symbol "$";
|
|
Melange_edn_melange.symbol "?parent-id";
|
|
|])
|
|
~where:
|
|
(Vec.of_array
|
|
[|
|
|
Cli_primitive.V
|
|
(Edn_util.vector_t_vec
|
|
(Vec.of_array
|
|
[| sym "?child"; kw "block/parent"; sym "?parent-id" |]));
|
|
|])
|
|
()
|
|
|
|
let row_entity value =
|
|
match
|
|
(Edn_util.as_vector value, Edn_util.as_list value, Edn_util.as_map value)
|
|
with
|
|
| Some values, _, _ when Vec.length values = 1 -> Some (Vec.peek_front values)
|
|
| _, Some values, _ when Vec.length values = 1 -> Some (Vec.peek_front values)
|
|
| _, _, Some _ -> Some value
|
|
| _ -> None
|
|
|
|
let id_of value = Edn_util.get_int64 value "db/id"
|
|
|
|
let parent_id_of value =
|
|
match Edn_util.get value "block/parent" with
|
|
| Some parent -> (
|
|
match (Edn_util.as_map parent, Edn_util.as_int64 parent) with
|
|
| Some _, _ -> Edn_util.get_int64 parent "db/id"
|
|
| _, Some id -> Some id
|
|
| _ -> None)
|
|
| None -> None
|
|
|
|
let page_id_of root =
|
|
match Edn_util.get root "block/page" with
|
|
| Some page -> (
|
|
match (Edn_util.as_map page, Edn_util.as_int64 page) with
|
|
| Some _, _ -> Edn_util.get_int64 page "db/id"
|
|
| _, Some id -> Some id
|
|
| _ -> id_of root)
|
|
| None -> id_of root
|
|
|
|
let order_key value =
|
|
match Edn_util.get value "block/order" with
|
|
| Some value -> (
|
|
match (Edn_util.as_string value, Edn_util.as_int value) with
|
|
| Some s, _ -> s
|
|
| _, Some i -> string_of_int i
|
|
| _ -> "")
|
|
| _ -> ""
|
|
|
|
let assoc_children value children =
|
|
if Vec.is_empty children then value
|
|
else Edn_util.assoc "block/children" (Edn_util.vector_vec children) value
|
|
|
|
let build_children ?max_depth blocks root_id =
|
|
let rec children_of depth parent_id =
|
|
match max_depth with
|
|
| Some max_depth when depth >= max_depth -> Vec.empty
|
|
| _ ->
|
|
blocks
|
|
|> Vec.filter (fun block -> parent_id_of block = Some parent_id)
|
|
|> Vec.sort (fun a b -> String.compare (order_key a) (order_key b))
|
|
|> Vec.map (fun block ->
|
|
match id_of block with
|
|
| Some id -> assoc_children block (children_of (depth + 1) id)
|
|
| None -> block)
|
|
in
|
|
children_of 1 root_id
|
|
|
|
let fetch_page_blocks config repo page_id =
|
|
let open Cli_effect in
|
|
bind
|
|
(Transport.thread_api_q config ~repo
|
|
~query:
|
|
(Edn_util.vector_t_vec
|
|
(Vec.of_array
|
|
[|
|
|
Edn_util.any
|
|
(Cli_primitive.datascript_query_to_edn page_blocks_query);
|
|
Edn_util.int64 page_id;
|
|
|])))
|
|
(fun rows ->
|
|
let blocks =
|
|
Option.value (Edn_util.as_seq rows) ~default:Vec.empty
|
|
|> Vec.filter_map row_entity
|
|
in
|
|
pure (Vec.filter (fun block -> not (property_value_block block)) blocks))
|
|
|
|
let fetch_page_hierarchy_children config repo parent_id =
|
|
let open Cli_effect in
|
|
bind
|
|
(Transport.thread_api_q config ~repo
|
|
~query:
|
|
(Edn_util.vector_t_vec
|
|
(Vec.of_array
|
|
[|
|
|
Edn_util.any
|
|
(Cli_primitive.datascript_query_to_edn
|
|
page_hierarchy_children_query);
|
|
Edn_util.int64 parent_id;
|
|
|])))
|
|
(fun rows ->
|
|
let blocks =
|
|
Option.value (Edn_util.as_seq rows) ~default:Vec.empty
|
|
|> Vec.filter_map row_entity
|
|
in
|
|
pure
|
|
(blocks
|
|
|> Vec.filter page_hierarchy_display_page
|
|
|> Vec.sort (fun a b -> String.compare (order_key a) (order_key b))))
|
|
|
|
let linked_ref_ids value =
|
|
match Edn_util.as_seq value with
|
|
| Some refs ->
|
|
Vec.filter_map
|
|
(fun ref ->
|
|
match (Edn_util.as_map ref, Edn_util.as_int64 ref) with
|
|
| Some _, _ -> Edn_util.get_int64 ref "db/id"
|
|
| _, Some id -> Some id
|
|
| _ -> None)
|
|
refs
|
|
| _ -> Vec.empty
|
|
|
|
let fetch_linked_references config repo root_id =
|
|
let open Cli_effect in
|
|
bind (Transport.thread_api_get_block_refs config ~repo ~block_id:root_id)
|
|
(fun refs ->
|
|
let rec pull_blocks acc remaining =
|
|
match Vec.pop_front remaining with
|
|
| None -> pure acc
|
|
| Some (id, rest) ->
|
|
bind
|
|
(Transport.thread_api_pull config ~repo
|
|
~selector:
|
|
(Edn_util.expect_vector_t "show pull selector" pull_selector)
|
|
~lookup:(Edn_util.int64 id))
|
|
(fun value ->
|
|
let acc =
|
|
if missing_entity value || property_value_block value then acc
|
|
else Vec.push_back acc (Block.of_value value)
|
|
in
|
|
pull_blocks acc rest)
|
|
in
|
|
bind
|
|
(pull_blocks Vec.empty (linked_ref_ids refs))
|
|
(fun blocks -> pure { count = Vec.length blocks; blocks }))
|
|
|
|
let attach_children config repo ?max_depth root =
|
|
let open Cli_effect in
|
|
match (id_of root, page_id_of root) with
|
|
| Some root_id, Some page_id ->
|
|
bind (fetch_page_blocks config repo page_id) (fun blocks ->
|
|
pure (assoc_children root (build_children ?max_depth blocks root_id)))
|
|
| _ -> pure root
|
|
|
|
let attach_page_hierarchy config repo ?max_depth root =
|
|
let open Cli_effect in
|
|
let rec attach_node depth visited node =
|
|
match id_of node with
|
|
| Some id when Vec.mem id visited ->
|
|
fail_show_error (page_hierarchy_parent_cycle ())
|
|
| None -> pure node
|
|
| Some parent_id -> (
|
|
let visited = Vec.push_front visited parent_id in
|
|
match max_depth with
|
|
| Some max_depth when depth >= max_depth -> pure node
|
|
| _ ->
|
|
bind (fetch_page_hierarchy_children config repo parent_id)
|
|
(fun children ->
|
|
let rec attach_all acc remaining =
|
|
match Vec.pop_front remaining with
|
|
| None -> pure acc
|
|
| Some (child, rest) ->
|
|
bind
|
|
(attach_node (depth + 1) visited child)
|
|
(fun child -> attach_all (Vec.push_back acc child) rest)
|
|
in
|
|
bind (attach_all Vec.empty children) (fun children ->
|
|
pure (assoc_children node children))))
|
|
in
|
|
attach_node 1 Vec.empty root
|
|
|
|
let attach_tree config (action : action) root =
|
|
if library_page root then
|
|
attach_page_hierarchy config action.repo ?max_depth:action.level root
|
|
else if action.page_hierarchy && page_hierarchy_target_page root then
|
|
attach_page_hierarchy config action.repo ?max_depth:action.level root
|
|
else attach_children config action.repo ?max_depth:action.level root
|
|
|
|
let lookup_of_link_value link =
|
|
match Edn_util.as_map link with
|
|
| Some _ -> (
|
|
match Edn_util.get_int64 link "db/id" with
|
|
| Some id -> Some (Edn_util.int64 id)
|
|
| None -> (
|
|
match
|
|
Option.bind (Edn_util.get link "block/uuid") Edn_util.as_string_like
|
|
with
|
|
| Some uuid ->
|
|
Some
|
|
(vector_vec
|
|
(Vec.of_array [| kw "block/uuid"; Edn_util.uuid uuid |]))
|
|
| _ -> None))
|
|
| None -> (
|
|
match (Edn_util.as_int64 link, Edn_util.as_uuid link) with
|
|
| Some id, _ -> Some (Edn_util.int64 id)
|
|
| _, Some uuid ->
|
|
Some
|
|
(vector_vec
|
|
(Vec.of_array [| kw "block/uuid"; Edn_util.uuid uuid |]))
|
|
| _ -> (
|
|
let values =
|
|
match (Edn_util.as_vector link, Edn_util.as_list link) with
|
|
| Some values, _ | _, Some values -> Some values
|
|
| _ -> None
|
|
in
|
|
match values with
|
|
| Some values
|
|
when Vec.length values = 2
|
|
&& value_key_matches "db/id" (Vec.nth values 0)
|
|
&& Option.is_some (Edn_util.as_int64 (Vec.nth values 1)) ->
|
|
let id = Vec.nth values 1 in
|
|
Some
|
|
(Edn_util.int64
|
|
(Option.value (Edn_util.as_int64 id) ~default:0L))
|
|
| Some values
|
|
when Vec.length values = 2
|
|
&& value_key_matches "block/uuid" (Vec.nth values 0) -> (
|
|
let uuid_value = Vec.nth values 1 in
|
|
match Edn_util.as_string_like uuid_value with
|
|
| Some uuid ->
|
|
Some
|
|
(vector_vec
|
|
(Vec.of_array [| kw "block/uuid"; Edn_util.uuid uuid |]))
|
|
| _ -> None)
|
|
| _ -> None))
|
|
|
|
let pull_link_target config repo link =
|
|
let open Cli_effect in
|
|
match lookup_of_link_value link with
|
|
| Some lookup ->
|
|
bind
|
|
(Transport.thread_api_pull config ~repo
|
|
~selector:
|
|
(Edn_util.expect_vector_t "show pull selector" pull_selector)
|
|
~lookup)
|
|
(fun target ->
|
|
if missing_entity target then
|
|
fail_show_error (block_link_target_not_found ())
|
|
else pure target)
|
|
| None -> fail_show_error (block_link_target_not_found ())
|
|
|
|
let link_target_id link =
|
|
match (Edn_util.as_map link, Edn_util.as_int64 link) with
|
|
| Some _, _ -> Edn_util.get_int64 link "db/id"
|
|
| _, Some id -> Some id
|
|
| _ -> None
|
|
|
|
let push_value_id value ids =
|
|
match id_of value with Some id -> Vec.push_front ids id | None -> ids
|
|
|
|
let remaining_linked_depth max_depth depth =
|
|
Option.map (fun max_depth -> max 1 (1 + max_depth - depth)) max_depth
|
|
|
|
let linked_target_action action depth =
|
|
{ action with level = remaining_linked_depth action.level depth }
|
|
|
|
let rec resolve_linked_blocks ?(depth = 1) ?(visited = Vec.empty) config
|
|
(action : action) root =
|
|
let open Cli_effect in
|
|
match Edn_util.get root "block/link" with
|
|
| Some link -> (
|
|
match link_target_id link with
|
|
| Some target_id when Vec.mem target_id visited ->
|
|
fail_show_error (block_link_cycle ())
|
|
| _ ->
|
|
bind (pull_link_target config action.repo link) (fun target ->
|
|
match id_of target with
|
|
| Some target_id when Vec.mem target_id visited ->
|
|
fail_show_error (block_link_cycle ())
|
|
| _ ->
|
|
let visited =
|
|
visited |> push_value_id root |> push_value_id target
|
|
in
|
|
let target_action = linked_target_action action depth in
|
|
bind (attach_tree config target_action target) (fun target ->
|
|
bind
|
|
(resolve_linked_blocks ~depth ~visited config action
|
|
target) (fun target ->
|
|
pure
|
|
(Edn_util.assoc "show/linked-display?"
|
|
(Edn_util.bool true) target)))))
|
|
| None ->
|
|
let children =
|
|
Option.value
|
|
(Option.bind (Edn_util.get root "block/children") Edn_util.as_seq)
|
|
~default:Vec.empty
|
|
in
|
|
if Vec.is_empty children then pure root
|
|
else
|
|
let rec resolve_all acc remaining =
|
|
match Vec.pop_front remaining with
|
|
| None -> pure acc
|
|
| Some (child, rest) ->
|
|
bind
|
|
(resolve_linked_blocks ~depth:(depth + 1) ~visited config action
|
|
child)
|
|
(fun child -> resolve_all (Vec.push_back acc child) rest)
|
|
in
|
|
bind (resolve_all Vec.empty children) (fun children ->
|
|
pure
|
|
(Edn_util.assoc "block/children"
|
|
(Edn_util.vector_vec children)
|
|
root))
|
|
|
|
let nonblank_string = function
|
|
| Some text when String.trim text <> "" -> Some text
|
|
| _ -> None
|
|
|
|
let uuid_string value key =
|
|
Option.bind (Edn_util.get value key) Edn_util.as_string_like
|
|
|> nonblank_string
|
|
|
|
let tag_label tag =
|
|
match nonblank_string (Edn_util.get_string tag "block/title") with
|
|
| Some title -> Some title
|
|
| None -> (
|
|
match nonblank_string (Edn_util.get_string tag "block/name") with
|
|
| Some name -> Some name
|
|
| None -> uuid_string tag "block/uuid")
|
|
|
|
let tags_suffix value =
|
|
let tags =
|
|
Option.value
|
|
(Option.bind (Edn_util.get value "block/tags") Edn_util.as_seq)
|
|
~default:Vec.empty
|
|
in
|
|
let labels = Vec.filter_map tag_label tags in
|
|
if Vec.is_empty labels then None
|
|
else Some (Vec.string_concat " " (Vec.map (fun label -> "#" ^ label) labels))
|
|
|
|
let status_label value =
|
|
match Edn_util.get value "logseq.property/status" with
|
|
| Some status -> nonblank_string (Edn_util.get_string status "block/title")
|
|
| None -> None
|
|
|
|
let base_label_of value =
|
|
match Edn_util.get_string value "block/title" with
|
|
| Some title when String.trim title <> "" -> title
|
|
| _ -> (
|
|
match Edn_util.get_string value "block/name" with
|
|
| Some name when String.trim name <> "" -> name
|
|
| _ -> (
|
|
match Edn_util.get_string value "db/ident" with
|
|
| Some ident when String.trim ident <> "" -> ident
|
|
| _ -> "-"))
|
|
|
|
let linked_display value =
|
|
Option.bind (Edn_util.get value "show/linked-display?") Edn_util.as_bool
|
|
= Some true
|
|
|
|
let linked_arrow = Cli_platform.Symbols.linked_arrow
|
|
|
|
let label_of value =
|
|
let base =
|
|
match status_label value with
|
|
| Some status -> status ^ " " ^ base_label_of value
|
|
| None -> base_label_of value
|
|
in
|
|
let label =
|
|
match tags_suffix value with
|
|
| Some suffix -> base ^ " " ^ suffix
|
|
| None -> base
|
|
in
|
|
match linked_display value with
|
|
| true -> linked_arrow ^ label
|
|
| false -> label
|
|
|
|
let children_of value =
|
|
Option.value
|
|
(Option.bind (Edn_util.get value "block/children") Edn_util.as_seq)
|
|
~default:Vec.empty
|
|
|
|
type render_metadata = {
|
|
property_titles : (string * string) Rrbvec.t;
|
|
property_value_labels : (Cli_primitive.db_id * string) Rrbvec.t;
|
|
}
|
|
|
|
let empty_render_metadata =
|
|
{ property_titles = Vec.empty; property_value_labels = Vec.empty }
|
|
|
|
let unique_preserve_order values =
|
|
let rec loop acc remaining =
|
|
match Vec.pop_front remaining with
|
|
| None -> acc
|
|
| Some (value, rest) ->
|
|
if Vec.mem value rest then loop acc rest
|
|
else loop (Vec.push_back acc value) rest
|
|
in
|
|
loop Vec.empty values
|
|
|
|
let property_key_namespace key =
|
|
let key = strip_keyword_prefix key in
|
|
key <> "logseq.property/status"
|
|
&& (not (string_starts_with ~prefix:"logseq.property/created-" key))
|
|
&& (string_starts_with ~prefix:"user.property/" key
|
|
|| string_starts_with ~prefix:"logseq.property/" key
|
|
|| string_starts_with ~prefix:"logseq.property." key)
|
|
|
|
let property_entity_hidden value =
|
|
Edn_util.get_bool value "logseq.property/hide?" = Some true
|
|
|
|
let property_entity_block_left value =
|
|
match Edn_util.get_string value "logseq.property/ui-position" with
|
|
| Some "block-left" -> true
|
|
| _ -> false
|
|
|
|
let property_entity value =
|
|
Option.is_some (Edn_util.get value "logseq.property/type")
|
|
|
|
let visible_property_entity value =
|
|
property_entity value
|
|
&& (not (property_entity_hidden value))
|
|
&& not (property_entity_block_left value)
|
|
|
|
let display_property_key key =
|
|
match (Edn_util.as_keyword key, Edn_util.as_keyword_t key) with
|
|
| Some text, Some ident when property_key_namespace text -> Some (text, ident)
|
|
| _ -> None
|
|
|
|
let property_entries value =
|
|
match Edn_util.as_map value with
|
|
| Some fields ->
|
|
fields
|
|
|> Vec.filter_map (fun (key, value) ->
|
|
Option.map
|
|
(fun (key_text, key_ident) -> (key_text, key_ident, value))
|
|
(display_property_key key))
|
|
| None -> Vec.empty
|
|
|
|
let rec collect_tree_property_entries root =
|
|
Vec.append (property_entries root)
|
|
(children_of root |> Vec.concat_map collect_tree_property_entries)
|
|
|
|
let collect_property_entries root linked_references =
|
|
let linked_blocks =
|
|
match linked_references with
|
|
| None -> Vec.empty
|
|
| Some refs -> Vec.map (fun block -> block.Block.raw) refs.blocks
|
|
in
|
|
Vec.push_front linked_blocks root
|
|
|> Vec.concat_map collect_tree_property_entries
|
|
|
|
let lookup_id_of_value value =
|
|
match Edn_util.as_map value with
|
|
| Some _ -> Edn_util.get_int64 value "db/id"
|
|
| None -> (
|
|
let values =
|
|
match (Edn_util.as_vector value, Edn_util.as_list value) with
|
|
| Some values, _ | _, Some values -> Some values
|
|
| _ -> None
|
|
in
|
|
match values with
|
|
| Some values
|
|
when Vec.length values = 2
|
|
&& value_key_matches "db/id" (Vec.nth values 0) ->
|
|
Edn_util.as_int64 (Vec.nth values 1)
|
|
| _ -> None)
|
|
|
|
let rec property_value_ref_ids value =
|
|
match lookup_id_of_value value with
|
|
| Some id -> Vec.singleton id
|
|
| None -> (
|
|
match Edn_util.as_seq value with
|
|
| Some values -> property_value_ref_ids_seq values
|
|
| None -> Vec.empty)
|
|
|
|
and property_value_ref_ids_seq values =
|
|
match Vec.pop_front values with
|
|
| Some (key, values)
|
|
when (not (Vec.is_empty values)) && value_key_matches "db/id" key -> (
|
|
let id, rest =
|
|
match Vec.pop_front values with
|
|
| Some pair -> pair
|
|
| None -> failwith "non-empty vector must have a front value"
|
|
in
|
|
match Edn_util.as_int64 id with
|
|
| Some id -> Vec.push_front (property_value_ref_ids_seq rest) id
|
|
| None ->
|
|
Vec.append
|
|
(property_value_ref_ids key)
|
|
(Vec.append
|
|
(property_value_ref_ids id)
|
|
(property_value_ref_ids_seq rest)))
|
|
| Some (value, rest) ->
|
|
Vec.append
|
|
(property_value_ref_ids value)
|
|
(property_value_ref_ids_seq rest)
|
|
| None -> Vec.empty
|
|
|
|
let property_title_selector =
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
kw "db/id";
|
|
kw "db/ident";
|
|
kw "block/title";
|
|
kw "block/name";
|
|
kw "logseq.property/type";
|
|
kw "logseq.property/hide?";
|
|
kw "logseq.property/ui-position";
|
|
|])
|
|
|
|
let property_value_label_selector =
|
|
vector_vec
|
|
(Vec.of_array
|
|
[|
|
|
kw "db/id";
|
|
kw "db/ident";
|
|
kw "block/title";
|
|
kw "block/name";
|
|
kw "logseq.property/value";
|
|
|])
|
|
|
|
let property_lookup ident =
|
|
vector_vec (Vec.of_array [| kw "db/ident"; Edn_util.any ident |])
|
|
|
|
let fallback_property_title key =
|
|
let key =
|
|
if String.length key > 0 && key.[0] = ':' then
|
|
String.sub key 1 (String.length key - 1)
|
|
else key
|
|
in
|
|
match Vec.peek_back_opt (Vec.split_on_char '/' key) with
|
|
| Some value when value <> "" -> value
|
|
| _ -> key
|
|
|
|
let entity_label_from_value value =
|
|
match nonblank_string (Edn_util.get_string value "block/title") with
|
|
| Some title -> Some title
|
|
| None -> (
|
|
match nonblank_string (Edn_util.get_string value "block/name") with
|
|
| Some name -> Some name
|
|
| None -> (
|
|
match
|
|
nonblank_string (Edn_util.get_string value "logseq.property/value")
|
|
with
|
|
| Some value -> Some value
|
|
| None -> (
|
|
match nonblank_string (Edn_util.get_string value "db/ident") with
|
|
| Some ident -> Some ident
|
|
| None -> None)))
|
|
|
|
let fetch_property_titles invoke_config repo idents =
|
|
let open Cli_effect in
|
|
let rec pull acc remaining =
|
|
match Vec.pop_front remaining with
|
|
| None -> pure acc
|
|
| Some ((key_text, ident), rest) ->
|
|
bind
|
|
(Transport.thread_api_pull invoke_config ~repo
|
|
~selector:
|
|
(Edn_util.expect_vector_t "property title selector"
|
|
property_title_selector)
|
|
~lookup:(property_lookup ident))
|
|
(fun value ->
|
|
let acc =
|
|
if visible_property_entity value then
|
|
let title =
|
|
Option.value
|
|
(entity_label_from_value value)
|
|
~default:(fallback_property_title key_text)
|
|
in
|
|
Vec.push_back acc (key_text, title)
|
|
else acc
|
|
in
|
|
pull acc rest)
|
|
in
|
|
pull Vec.empty idents
|
|
|
|
let fetch_property_value_labels invoke_config repo ids =
|
|
let open Cli_effect in
|
|
let rec pull acc remaining =
|
|
match Vec.pop_front remaining with
|
|
| None -> pure acc
|
|
| Some (id, rest) ->
|
|
bind
|
|
(Transport.thread_api_pull invoke_config ~repo
|
|
~selector:
|
|
(Edn_util.expect_vector_t "property value selector"
|
|
property_value_label_selector)
|
|
~lookup:(Edn_util.int64 id))
|
|
(fun value ->
|
|
let acc =
|
|
match entity_label_from_value value with
|
|
| Some label -> Vec.push_back acc (id, label)
|
|
| None -> acc
|
|
in
|
|
pull acc rest)
|
|
in
|
|
pull Vec.empty ids
|
|
|
|
let replace_uuid_refs_in_property_value_labels config repo property_value_labels
|
|
=
|
|
let label_uuids =
|
|
property_value_labels |> Vec.map snd
|
|
|> Uuid_refs_types.collect_uuid_refs_from_strings
|
|
in
|
|
let open Cli_effect in
|
|
bind (Uuid_refs_types.fetch_uuid_entities config repo label_uuids)
|
|
(fun uuid_entities ->
|
|
let labels =
|
|
Vec.filter_map
|
|
(fun (entry : Uuid_refs_types.uuid_label) ->
|
|
Option.map (fun label -> (entry.uuid, label)) entry.label)
|
|
uuid_entities
|
|
in
|
|
let property_value_labels =
|
|
Vec.map
|
|
(fun (id, label) ->
|
|
(id, Uuid_refs_types.replace_uuid_refs label labels))
|
|
property_value_labels
|
|
in
|
|
pure property_value_labels)
|
|
|
|
let prepare_property_render_metadata config invoke_config action root
|
|
linked_references =
|
|
let entries = collect_property_entries root linked_references in
|
|
if Vec.is_empty entries then Cli_effect.pure empty_render_metadata
|
|
else
|
|
let property_idents =
|
|
entries
|
|
|> Vec.map (fun (key_text, key_ident, _) -> (key_text, key_ident))
|
|
|> unique_preserve_order
|
|
in
|
|
let open Cli_effect in
|
|
bind (fetch_property_titles invoke_config action.repo property_idents)
|
|
(fun property_titles ->
|
|
let property_title_key key =
|
|
Option.is_some (Vec.assoc_opt key property_titles)
|
|
in
|
|
let visible_entries =
|
|
Vec.filter
|
|
(fun (key_text, _, _) -> property_title_key key_text)
|
|
entries
|
|
in
|
|
let value_ids =
|
|
visible_entries
|
|
|> Vec.concat_map (fun (_, _, value) -> property_value_ref_ids value)
|
|
|> unique_preserve_order
|
|
in
|
|
bind (fetch_property_value_labels invoke_config action.repo value_ids)
|
|
(fun property_value_labels ->
|
|
bind
|
|
(replace_uuid_refs_in_property_value_labels config action.repo
|
|
property_value_labels) (fun property_value_labels ->
|
|
pure { property_titles; property_value_labels })))
|
|
|
|
let id_text value =
|
|
match id_of value with Some id -> Int64.to_string id | None -> "-"
|
|
|
|
let rec tree_id_width value =
|
|
children_of value
|
|
|> Vec.fold_left
|
|
(fun width child -> max width (tree_id_width child))
|
|
(String.length (id_text value))
|
|
|
|
let pad_id width id = id ^ String.make (max 0 (width - String.length id)) ' '
|
|
|
|
let rstrip_spaces value =
|
|
let rec loop idx =
|
|
if idx < 0 then ""
|
|
else
|
|
match value.[idx] with
|
|
| ' ' | '\t' -> loop (idx - 1)
|
|
| _ -> String.sub value 0 (idx + 1)
|
|
in
|
|
loop (String.length value - 1)
|
|
|
|
let append_label_lines lines ~id_width ~id ~prefix ~branch ~continuation_prefix
|
|
label =
|
|
match Vec.split_on_char '\n' label with
|
|
| values when Vec.is_empty values -> lines
|
|
| values ->
|
|
let first = Vec.peek_front values in
|
|
let rest =
|
|
match Vec.pop_front values with
|
|
| Some (_, rest) -> rest
|
|
| None -> Vec.empty
|
|
in
|
|
let id_padding = String.make (id_width + 1) ' ' in
|
|
let continuation_prefix =
|
|
if Vec.is_empty rest then continuation_prefix
|
|
else id_padding ^ continuation_prefix
|
|
in
|
|
let continuation_line line =
|
|
let line = continuation_prefix ^ line in
|
|
rstrip_spaces line
|
|
in
|
|
Vec.append
|
|
(Vec.push_back lines
|
|
(pad_id id_width id ^ " " ^ prefix ^ branch ^ first))
|
|
(Vec.map continuation_line rest)
|
|
|
|
let property_title metadata key = Vec.assoc_opt key metadata.property_titles
|
|
|
|
let property_value_label metadata id =
|
|
Vec.assoc_opt id metadata.property_value_labels
|
|
|
|
let scalar_property_value_text value =
|
|
match
|
|
( Edn_util.as_string_like value,
|
|
Edn_util.as_bool value,
|
|
Edn_util.as_int64 value,
|
|
Edn_util.as_float value )
|
|
with
|
|
| Some text, _, _, _ -> Some (strip_keyword_prefix text)
|
|
| _, Some bool, _, _ -> Some (string_of_bool bool)
|
|
| _, _, Some int, _ -> Some (Int64.to_string int)
|
|
| _, _, _, Some float -> Some (string_of_float float)
|
|
| _ -> None
|
|
|
|
let rec property_value_items metadata value =
|
|
match lookup_id_of_value value with
|
|
| Some id -> (
|
|
match property_value_label metadata id with
|
|
| Some label -> Vec.singleton label
|
|
| None -> Vec.empty)
|
|
| None -> (
|
|
match entity_label_from_value value with
|
|
| Some label -> Vec.singleton (strip_keyword_prefix label)
|
|
| None -> (
|
|
match Edn_util.as_seq value with
|
|
| Some values -> property_value_items_seq metadata values
|
|
| None -> (
|
|
match scalar_property_value_text value with
|
|
| Some text -> Vec.singleton text
|
|
| None -> Vec.empty)))
|
|
|
|
and property_value_items_seq metadata values =
|
|
match Vec.pop_front values with
|
|
| Some (key, values)
|
|
when (not (Vec.is_empty values)) && value_key_matches "db/id" key -> (
|
|
let id, rest =
|
|
match Vec.pop_front values with
|
|
| Some pair -> pair
|
|
| None -> failwith "non-empty vector must have a front value"
|
|
in
|
|
match Edn_util.as_int64 id with
|
|
| Some id ->
|
|
Vec.append
|
|
(match property_value_label metadata id with
|
|
| Some label -> Vec.singleton label
|
|
| None -> Vec.empty)
|
|
(property_value_items_seq metadata rest)
|
|
| None ->
|
|
Vec.append
|
|
(property_value_items metadata key)
|
|
(Vec.append
|
|
(property_value_items metadata id)
|
|
(property_value_items_seq metadata rest)))
|
|
| Some (value, rest) ->
|
|
Vec.append
|
|
(property_value_items metadata value)
|
|
(property_value_items_seq metadata rest)
|
|
| None -> Vec.empty
|
|
|
|
let property_line metadata (key, _, value) =
|
|
match property_title metadata key with
|
|
| None -> None
|
|
| Some title -> (
|
|
match property_value_items metadata value with
|
|
| values when Vec.is_empty values -> None
|
|
| values when Vec.length values = 1 ->
|
|
Some (title ^ ": " ^ Vec.peek_front values)
|
|
| values ->
|
|
Some
|
|
(title ^ ":\n"
|
|
^ Vec.string_concat "\n"
|
|
(Vec.map (fun value -> "- " ^ value) values)))
|
|
|
|
let property_lines metadata value =
|
|
property_entries value |> Vec.filter_map (property_line metadata)
|
|
|
|
let append_property_lines lines ~id_width ~prefix metadata value =
|
|
let line_prefix = String.make (id_width + 1) ' ' ^ prefix in
|
|
let append_line lines line =
|
|
match Vec.split_on_char '\n' line with
|
|
| values when Vec.is_empty values -> lines
|
|
| values ->
|
|
let first = Vec.peek_front values in
|
|
let rest =
|
|
match Vec.pop_front values with
|
|
| Some (_, rest) -> rest
|
|
| None -> Vec.empty
|
|
in
|
|
Vec.append
|
|
(Vec.push_back lines (rstrip_spaces (line_prefix ^ first)))
|
|
(Vec.map (fun line -> rstrip_spaces (line_prefix ^ " " ^ line)) rest)
|
|
in
|
|
Vec.fold_left append_line lines (property_lines metadata value)
|
|
|
|
let render_tree_text_value ?(metadata = empty_render_metadata) root =
|
|
let lines = ref Vec.empty in
|
|
let id_width = tree_id_width root in
|
|
let root_id = id_text root in
|
|
lines :=
|
|
append_label_lines !lines ~id_width ~id:root_id ~prefix:"" ~branch:""
|
|
~continuation_prefix:"" (label_of root);
|
|
lines := append_property_lines !lines ~id_width ~prefix:"" metadata root;
|
|
let rec walk prefix node =
|
|
let children = children_of node in
|
|
let total = Vec.length children in
|
|
Vec.iteri
|
|
(fun idx child ->
|
|
let last_child = idx = total - 1 in
|
|
let branch =
|
|
if last_child then Cli_platform.Symbols.tree_last
|
|
else Cli_platform.Symbols.tree_middle
|
|
in
|
|
let next_prefix =
|
|
prefix ^ if last_child then " " else Cli_platform.Symbols.tree_pipe
|
|
in
|
|
lines :=
|
|
append_label_lines !lines ~id_width ~id:(id_text child) ~prefix
|
|
~branch ~continuation_prefix:next_prefix (label_of child);
|
|
lines :=
|
|
append_property_lines !lines ~id_width ~prefix:next_prefix metadata
|
|
child;
|
|
walk next_prefix child)
|
|
children
|
|
in
|
|
walk "" root;
|
|
Vec.string_concat "\n" !lines
|
|
|
|
let linked_reference_context_value block =
|
|
match Edn_util.get block "block/page" with
|
|
| Some page when Option.is_some (Edn_util.as_map page) ->
|
|
Edn_util.assoc "block/children"
|
|
(Edn_util.vector_vec (Vec.of_array [| block |]))
|
|
page
|
|
| _ -> block
|
|
|
|
let render_linked_reference_text metadata block =
|
|
render_tree_text_value ~metadata (linked_reference_context_value block)
|
|
|
|
let collect_uuid_ref_strings value =
|
|
let rec collect acc value =
|
|
let acc =
|
|
match Edn_util.as_string value with
|
|
| Some text -> Vec.push_front acc text
|
|
| None -> acc
|
|
in
|
|
match Edn_util.as_map value with
|
|
| Some fields ->
|
|
Vec.fold_left (fun acc (_, value) -> collect acc value) acc fields
|
|
| None -> (
|
|
match Edn_util.as_seq value with
|
|
| Some values -> Vec.fold_left collect acc values
|
|
| None -> acc)
|
|
in
|
|
collect Vec.empty value
|
|
|
|
let linked_reference_values = function
|
|
| None -> Vec.empty
|
|
| Some refs -> Vec.map (fun block -> block.Block.raw) refs.blocks
|
|
|
|
let referenced_uuids root linked_references =
|
|
Vec.push_front (linked_reference_values linked_references) root
|
|
|> Vec.concat_map collect_uuid_ref_strings
|
|
|> Uuid_refs_types.collect_uuid_refs_from_strings
|
|
|
|
let label_pairs uuid_entities =
|
|
Vec.filter_map
|
|
(fun (entry : Uuid_refs_types.uuid_label) ->
|
|
Option.map (fun label -> (entry.uuid, label)) entry.label)
|
|
uuid_entities
|
|
|
|
let rec replace_uuid_refs_in_value labels value =
|
|
match Edn_util.as_string value with
|
|
| Some text -> Edn_util.string (Uuid_refs_types.replace_uuid_refs text labels)
|
|
| None -> (
|
|
match Edn_util.as_list value with
|
|
| Some values ->
|
|
Edn_util.list_vec
|
|
(values |> Vec.map (replace_uuid_refs_in_value labels))
|
|
| None -> (
|
|
match Edn_util.as_vector value with
|
|
| Some values ->
|
|
Edn_util.vector_vec
|
|
(values |> Vec.map (replace_uuid_refs_in_value labels))
|
|
| None -> (
|
|
match Edn_util.as_set value with
|
|
| Some values ->
|
|
Edn_util.set_vec
|
|
(values |> Vec.map (replace_uuid_refs_in_value labels))
|
|
| None -> (
|
|
match Edn_util.as_map value with
|
|
| Some fields ->
|
|
Edn_util.map_vec
|
|
(fields
|
|
|> Vec.map (fun (key, value) ->
|
|
(key, replace_uuid_refs_in_value labels value)))
|
|
| None -> value))))
|
|
|
|
let replace_linked_references labels = function
|
|
| None -> None
|
|
| Some refs ->
|
|
Some
|
|
{
|
|
refs with
|
|
blocks =
|
|
Vec.map
|
|
(fun block ->
|
|
let raw = replace_uuid_refs_in_value labels block.Block.raw in
|
|
{ (Block.of_value raw) with Block.raw })
|
|
refs.blocks;
|
|
}
|
|
|
|
let referenced_entity_line (entry : Uuid_refs_types.uuid_label) =
|
|
let id = match entry.id with Some id -> Int64.to_string id | None -> "-" in
|
|
let label = Option.value entry.label ~default:entry.uuid in
|
|
id ^ " -> " ^ label
|
|
|
|
let referenced_entities_footer (action : action) ordered_uuids uuid_entities =
|
|
if (not action.ref_id_footer) || Vec.is_empty ordered_uuids then None
|
|
else
|
|
let rows =
|
|
ordered_uuids
|
|
|> Vec.filter_map (fun uuid ->
|
|
Vec.find_opt
|
|
(fun (entry : Uuid_refs_types.uuid_label) -> entry.uuid = uuid)
|
|
uuid_entities)
|
|
|> Vec.map referenced_entity_line
|
|
in
|
|
if Vec.is_empty rows then None
|
|
else
|
|
Some
|
|
("Referenced Entities ("
|
|
^ Humanize_types.format_count (Vec.length rows)
|
|
^ ")\n"
|
|
^ Vec.string_concat "\n" rows)
|
|
|
|
let block_page_id root =
|
|
match Edn_util.get root "block/page" with
|
|
| Some page -> (
|
|
match (Edn_util.as_map page, Edn_util.as_int64 page) with
|
|
| Some _, _ -> Edn_util.get_int64 page "db/id"
|
|
| _, Some id -> Some id
|
|
| _ -> None)
|
|
| None -> None
|
|
|
|
let ordinary_block_root root =
|
|
Option.is_some (id_of root) && Option.is_some (block_page_id root)
|
|
|
|
let breadcrumb_label value = label_of value
|
|
|
|
let render_breadcrumb_line parents =
|
|
let rows =
|
|
parents
|
|
|> Vec.filter_map (fun parent ->
|
|
let label = breadcrumb_label parent in
|
|
if String.trim label = "" || label = "-" then None
|
|
else Some (parent, label))
|
|
in
|
|
if Vec.is_empty rows then None
|
|
else
|
|
let id_width =
|
|
rows
|
|
|> Vec.map (fun (parent, _) -> String.length (id_text parent))
|
|
|> Vec.fold_left max 0
|
|
in
|
|
rows
|
|
|> Vec.mapi (fun index (parent, label) ->
|
|
let id = id_text parent in
|
|
let padding = String.make (max 0 (id_width - String.length id)) ' ' in
|
|
let indent = String.make (index * 2) ' ' in
|
|
id ^ padding ^ indent ^ " > " ^ label)
|
|
|> Vec.string_concat "\n" |> Option.some
|
|
|
|
let fetch_breadcrumb_line invoke_config (action : action) root =
|
|
let open Cli_effect in
|
|
match id_of root with
|
|
| Some root_id when ordinary_block_root root ->
|
|
bind
|
|
(Transport.thread_api_get_block_parents invoke_config ~repo:action.repo
|
|
~block_id:root_id) (fun value ->
|
|
let parents =
|
|
Option.value (Edn_util.as_seq value) ~default:Vec.empty
|
|
in
|
|
pure (render_breadcrumb_line parents))
|
|
| _ -> pure None
|
|
|
|
let prepare_uuid_refs config (action : action) root linked_references =
|
|
let uuids = referenced_uuids root linked_references in
|
|
let open Cli_effect in
|
|
bind (Uuid_refs_types.fetch_uuid_entities config action.repo uuids)
|
|
(fun uuid_entities ->
|
|
let labels = label_pairs uuid_entities in
|
|
let root = replace_uuid_refs_in_value labels root in
|
|
let linked_references =
|
|
replace_linked_references labels linked_references
|
|
in
|
|
pure
|
|
( root,
|
|
linked_references,
|
|
referenced_entities_footer action uuids uuid_entities,
|
|
uuids ))
|
|
|
|
let human_output_for_mode mode = not (Output.Mode.structured mode)
|
|
|
|
let show_result mode _config _action root linked_references footer metadata =
|
|
if not (human_output_for_mode mode) then
|
|
Cli_result.ok ~command:Command_id.Show mode
|
|
(Raw (tree_data_value root linked_references))
|
|
else
|
|
let tree_message =
|
|
match linked_references with
|
|
| Some { count; blocks } when not (Vec.is_empty blocks) ->
|
|
render_tree_text_value ~metadata root
|
|
^ "\n\nLinked References (" ^ string_of_int count ^ ")\n"
|
|
^ Vec.string_concat "\n\n"
|
|
(Vec.map
|
|
(fun block ->
|
|
render_linked_reference_text metadata block.Block.raw)
|
|
blocks)
|
|
| _ -> render_tree_text_value ~metadata root
|
|
in
|
|
let message =
|
|
match footer with
|
|
| Some footer -> tree_message ^ "\n\n" ^ footer
|
|
| None -> tree_message
|
|
in
|
|
Cli_result.ok ~command:Command_id.Show mode (Message message)
|
|
|
|
let show_result_with_breadcrumb mode config action root linked_references footer
|
|
metadata breadcrumb_line =
|
|
match
|
|
show_result mode config action root linked_references footer metadata
|
|
with
|
|
| { Cli_result.data = Some (Message message); _ } ->
|
|
let message =
|
|
match breadcrumb_line with
|
|
| Some line -> line ^ "\n" ^ message
|
|
| None -> message
|
|
in
|
|
Cli_result.ok ~command:Command_id.Show mode (Message message)
|
|
| result -> result
|
|
|
|
let attach_linked_references config (action : action) root =
|
|
let open Cli_effect in
|
|
if not action.linked_references then pure None
|
|
else
|
|
match id_of root with
|
|
| Some root_id ->
|
|
bind (fetch_linked_references config action.repo root_id) (fun refs ->
|
|
pure (Some refs))
|
|
| None -> pure (Some { count = 0; blocks = Vec.empty })
|
|
|
|
let resolve_linked_references config (action : action) = function
|
|
| None -> Cli_effect.pure None
|
|
| Some refs ->
|
|
let open Cli_effect in
|
|
let rec resolve_all acc remaining =
|
|
match Vec.pop_front remaining with
|
|
| None -> pure acc
|
|
| Some (block, rest) ->
|
|
bind (resolve_linked_blocks config action block.Block.raw)
|
|
(fun raw ->
|
|
let block = Block.of_value raw in
|
|
resolve_all (Vec.push_back acc { block with Block.raw }) rest)
|
|
in
|
|
bind (resolve_all Vec.empty refs.blocks) (fun blocks ->
|
|
pure (Some { refs with blocks }))
|
|
|
|
let rec collect_tree_ids root =
|
|
let child_ids = children_of root |> Vec.concat_map collect_tree_ids in
|
|
match id_of root with
|
|
| Some id -> Vec.push_front child_ids id
|
|
| None -> child_ids
|
|
|
|
let multi_tree_value root linked_references =
|
|
tree_data_value root linked_references
|
|
|
|
let multi_tree_message mode config action root linked_references footer metadata
|
|
=
|
|
match
|
|
show_result mode config action root linked_references footer metadata
|
|
with
|
|
| { Cli_result.data = Some (Message message); _ } -> message
|
|
| _ -> render_tree_text_value ~metadata root
|
|
|
|
let execute_single mode action config target =
|
|
let open Cli_effect in
|
|
bind (Server_runtime.ensure_server config action.repo ~create_empty_db:false)
|
|
(function
|
|
| Error err -> pure (Cli_result.error ~command:Command_id.Show mode err)
|
|
| Ok invoke_config ->
|
|
bind (pull_entity invoke_config action.repo target) (fun value ->
|
|
if missing_entity value then
|
|
pure
|
|
(Cli_result.error ~command:Command_id.Show mode
|
|
(entity_error target))
|
|
else if recycled_page value then
|
|
pure
|
|
(Cli_result.error ~command:Command_id.Show mode
|
|
(recycled_page_error ()))
|
|
else
|
|
bind (attach_tree invoke_config action value) (fun value ->
|
|
bind (resolve_linked_blocks invoke_config action value)
|
|
(fun value ->
|
|
bind (attach_linked_references invoke_config action value)
|
|
(fun linked_references ->
|
|
bind
|
|
(resolve_linked_references invoke_config action
|
|
linked_references) (fun linked_references ->
|
|
bind
|
|
(prepare_uuid_refs config action value
|
|
linked_references)
|
|
(fun (value, linked_references, footer, _) ->
|
|
let metadata =
|
|
if human_output_for_mode mode then
|
|
prepare_property_render_metadata config
|
|
invoke_config action value
|
|
linked_references
|
|
else pure empty_render_metadata
|
|
in
|
|
bind metadata (fun metadata ->
|
|
let breadcrumb =
|
|
if human_output_for_mode mode then
|
|
fetch_breadcrumb_line invoke_config
|
|
action value
|
|
else pure None
|
|
in
|
|
bind breadcrumb (fun breadcrumb_line ->
|
|
pure
|
|
(show_result_with_breadcrumb mode
|
|
config action value
|
|
linked_references footer metadata
|
|
breadcrumb_line))))))))))
|
|
|
|
let execute_with_mode action config mode =
|
|
let run =
|
|
match action.target with
|
|
| By_ids ids ->
|
|
let open Cli_effect in
|
|
bind
|
|
(Server_runtime.ensure_server config action.repo
|
|
~create_empty_db:false) (function
|
|
| Error err ->
|
|
pure (Cli_result.error ~command:Command_id.Show mode err)
|
|
| Ok invoke_config ->
|
|
let rec build_entries acc remaining =
|
|
match Vec.pop_front remaining with
|
|
| None -> pure acc
|
|
| Some (id, rest) ->
|
|
bind (pull_entity invoke_config action.repo (By_id id))
|
|
(fun value ->
|
|
if missing_entity value then
|
|
build_entries
|
|
(Vec.push_back acc
|
|
(id, Error (entity_error (By_id id))))
|
|
rest
|
|
else if recycled_page value then
|
|
build_entries
|
|
(Vec.push_back acc
|
|
(id, Error (recycled_page_error ())))
|
|
rest
|
|
else
|
|
bind (attach_tree invoke_config action value)
|
|
(fun root ->
|
|
bind
|
|
(resolve_linked_blocks invoke_config action root)
|
|
(fun root ->
|
|
bind
|
|
(attach_linked_references invoke_config
|
|
action root) (fun linked_references ->
|
|
bind
|
|
(resolve_linked_references invoke_config
|
|
action linked_references)
|
|
(fun linked_references ->
|
|
bind
|
|
(prepare_uuid_refs config action
|
|
root linked_references)
|
|
(fun
|
|
( root,
|
|
linked_references,
|
|
footer,
|
|
_ )
|
|
->
|
|
let metadata =
|
|
if human_output_for_mode mode
|
|
then
|
|
prepare_property_render_metadata
|
|
config invoke_config action
|
|
root linked_references
|
|
else pure empty_render_metadata
|
|
in
|
|
bind metadata (fun metadata ->
|
|
build_entries
|
|
(Vec.push_back acc
|
|
( id,
|
|
Ok
|
|
( root,
|
|
linked_references,
|
|
footer,
|
|
metadata ) ))
|
|
rest)))))))
|
|
in
|
|
bind (build_entries Vec.empty ids) (fun entries ->
|
|
let tree_ids =
|
|
entries
|
|
|> Vec.filter_map (function
|
|
| id, Ok (root, _, _, _) ->
|
|
Some (id, collect_tree_ids root)
|
|
| _ -> None)
|
|
in
|
|
let contained id =
|
|
Vec.exists
|
|
(fun (other_id, ids) -> other_id <> id && Vec.mem id ids)
|
|
tree_ids
|
|
in
|
|
let entries =
|
|
Vec.filter
|
|
(function
|
|
| id, Ok _ -> not (contained id) | _, Error _ -> true)
|
|
entries
|
|
in
|
|
let values =
|
|
Vec.map
|
|
(function
|
|
| _, Ok (root, linked_references, _, _) ->
|
|
multi_tree_value root linked_references
|
|
| id, Error err -> multi_id_error_value id err)
|
|
entries
|
|
in
|
|
let human_messages =
|
|
Vec.map
|
|
(function
|
|
| _, Ok (root, linked_references, footer, metadata) ->
|
|
multi_tree_message mode config action root
|
|
linked_references footer metadata
|
|
| id, Error err -> multi_id_error_message id err)
|
|
entries
|
|
in
|
|
let data =
|
|
if human_output_for_mode mode then
|
|
Cli_result.Message
|
|
(Vec.string_concat
|
|
"\n\
|
|
================================================================\n"
|
|
human_messages)
|
|
else Cli_result.Raw (Edn_util.vector_vec values)
|
|
in
|
|
pure (Cli_result.ok ~command:Command_id.Show mode data)))
|
|
| target -> execute_single mode action config target
|
|
in
|
|
Cli_effect.catch run (function
|
|
| Show_error err ->
|
|
Cli_effect.pure (Cli_result.error ~command:Command_id.Show mode err)
|
|
| exn -> Cli_effect.error exn)
|
|
|
|
let meta ?(examples = Vec.empty) id doc =
|
|
{
|
|
Command_registry.id;
|
|
path = Command_id.to_path id;
|
|
doc;
|
|
long_doc = None;
|
|
examples;
|
|
options = Vec.empty;
|
|
category = Command_registry.Graph_inspect_and_edit;
|
|
requires_graph = Command_id.requires_graph id;
|
|
requires_auth = Command_id.requires_auth id;
|
|
write_command = Command_id.is_write id;
|
|
human_table_headers_order = Vec.empty;
|
|
}
|
|
|
|
let metadata () =
|
|
Vec.of_array
|
|
[|
|
|
meta
|
|
~examples:
|
|
(Vec.of_array
|
|
[|
|
|
"logseq show --graph my-graph --page Home";
|
|
"logseq show --graph my-graph --page Foo --page-hierarchy true";
|
|
"logseq show --graph my-graph --page \"Meeting Notes\" --level 2";
|
|
"logseq show --graph my-graph --id 123 --level 3";
|
|
"logseq show --graph my-graph --id '[123,456,789]'";
|
|
"logseq show --graph my-graph --uuid \
|
|
11111111-1111-1111-1111-111111111111";
|
|
|])
|
|
Command_id.Show "Show tree";
|
|
|]
|
|
|
|
let execute action config =
|
|
let (Output.Mode.Packed mode) = Output_mode.for_config config in
|
|
execute_with_mode action config mode
|