type mode = Create | Update | Page type block_opts = { id : Cli_primitive.db_id option; uuid : Cli_primitive.uuid option; target_id : Cli_primitive.db_id option; target_uuid : Cli_primitive.uuid option; target_page : string option; pos : Block.position option; content : string option; blocks_edn : string option; blocks_file : Cli_primitive.path option; update_tags_edn : string option; update_properties_edn : string option; remove_tags_edn : string option; remove_properties_edn : string option; } type page_opts = { id : Cli_primitive.db_id option; page : string option; restore : bool; update_tags_edn : string option; update_properties_edn : string option; remove_tags_edn : string option; remove_properties_edn : string option; } type task_opts = { id : Cli_primitive.db_id option; uuid : Cli_primitive.uuid option; page : string option; content : string option; target_id : Cli_primitive.db_id option; target_uuid : Cli_primitive.uuid option; target_page : string option; pos : Block.position option; status : string option; priority : string option; scheduled : Js.Date.t option; deadline : Js.Date.t option; no_status : bool; no_priority : bool; no_scheduled : bool; no_deadline : bool; } type asset_opts = { id : Cli_primitive.db_id option; uuid : Cli_primitive.uuid option; path : Cli_primitive.path option; target_id : Cli_primitive.db_id option; target_uuid : Cli_primitive.uuid option; target_page : string option; pos : Block.position option; content : string option; } type tag_opts = { id : Cli_primitive.db_id option; name : string option; add_properties_edn : string option; remove_properties_edn : string option; } type property_opts = { id : Cli_primitive.db_id option; name : string option; kind : Property.kind option; cardinality : Property.cardinality option; hide : bool option; public : bool option; } type parsed = | Parsed_block of block_opts | Parsed_page of page_opts | Parsed_task of task_opts | Parsed_asset of asset_opts | Parsed_tag of tag_opts | Parsed_property of property_opts type block_target = | Target_id of Cli_primitive.db_id | Target_uuid of Cli_primitive.uuid | Target_page of string type block_source = | Source_id of Cli_primitive.db_id | Source_uuid of Cli_primitive.uuid type block_create = { repo : Cli_primitive.repo; graph : Cli_primitive.graph; target : block_target; pos : Block.position; status : Cli_primitive.keyword option; tags : Selector.tag Rrbvec.t; properties : Property.assignment Rrbvec.t; blocks : Block.t Rrbvec.t; update_plan : Property.update_plan; } type block_update = { repo : Cli_primitive.repo; graph : Cli_primitive.graph; source : block_source; target : block_target option; pos : Block.position option; update_tags : Selector.tag Rrbvec.t; update_properties : Property.assignment Rrbvec.t; remove_tags : Selector.tag Rrbvec.t; remove_properties : Property.key Rrbvec.t; content : string option; source_label : string option; target_label : string option; } type block_action = | Block_create of block_create | Block_update of block_update type action = | Upsert_block of block_action | Upsert_page of { repo : Cli_primitive.repo; graph : Cli_primitive.graph; mode : mode; id : Cli_primitive.db_id option; page : string option; restore : bool; plan : Property.update_plan; } | Upsert_task of { repo : Cli_primitive.repo; graph : Cli_primitive.graph; mode : mode; id : Cli_primitive.db_id option; uuid : Cli_primitive.uuid option; page : string option; content : string option; update_properties : Property.assignment Rrbvec.t; clear_properties : Property.key Rrbvec.t; status_input : string option; } | Upsert_asset of { repo : Cli_primitive.repo; graph : Cli_primitive.graph; mode : mode; id : Cli_primitive.db_id option; uuid : Cli_primitive.uuid option; path : Cli_primitive.path option; content : string option; create_action : block_create option; } | Upsert_tag of { repo : Cli_primitive.repo; graph : Cli_primitive.graph; mode : mode; id : Cli_primitive.db_id option; name : string option; add_properties : Property.key Rrbvec.t; remove_properties : Property.key Rrbvec.t; } | Upsert_property of { repo : Cli_primitive.repo; graph : Cli_primitive.graph; mode : mode; id : Cli_primitive.db_id option; name : string option; schema : Property.schema; } let update_mode (opts : block_opts) = Option.is_some opts.id || Option.is_some opts.uuid let normalize_tag_name value = let value = String.trim value in let rec drop_hash idx = if idx < String.length value && value.[idx] = '#' then drop_hash (idx + 1) else idx in let start = drop_hash 0 in let value = String.sub value start (String.length value - start) |> String.trim in if value = "" then None else Some value let normalized_lookup_name value = String.lowercase_ascii (String.trim value) let strip_keyword_prefix value = if String.length value > 0 && value.[0] = ':' then String.sub value 1 (String.length value - 1) else value let nonempty_trimmed = function | Some value -> let value = String.trim value in if value = "" then None else Some value | None -> None let count_present values = Vec.fold_left (fun count -> function Some _ -> count + 1 | None -> count) 0 values let invalid_uuid_option option_name = function | Some value when not (Cli_primitive.is_uuid_string (String.trim value)) -> Some ("Option " ^ option_name ^ " must be a valid UUID string") | _ -> None let first_error values = Vec.find_map Fun.id values let invalid_uuid_options = function | Parsed_block opts -> first_error (Vec.of_array [| invalid_uuid_option "uuid" opts.uuid; invalid_uuid_option "target-uuid" opts.target_uuid; |]) | Parsed_task opts -> first_error (Vec.of_array [| invalid_uuid_option "uuid" opts.uuid; invalid_uuid_option "target-uuid" opts.target_uuid; |]) | Parsed_asset opts -> first_error (Vec.of_array [| invalid_uuid_option "uuid" opts.uuid; invalid_uuid_option "target-uuid" opts.target_uuid; |]) | _ -> None let update_opts_of_block_opts (opts : block_opts) : Update.opts = { id = opts.id; uuid = opts.uuid; target_id = opts.target_id; target_uuid = opts.target_uuid; target_page = opts.target_page; pos = opts.pos; status = None; content = opts.content; update_tags_edn = opts.update_tags_edn; update_properties_edn = opts.update_properties_edn; remove_tags_edn = opts.remove_tags_edn; remove_properties_edn = opts.remove_properties_edn; blocks_edn = opts.blocks_edn; blocks_file = opts.blocks_file; } let invalid_options = function | Parsed_block opts when update_mode opts -> Update.invalid_options (update_opts_of_block_opts opts) | Parsed_block opts when (not (update_mode opts)) && (Option.is_some opts.remove_tags_edn || Option.is_some opts.remove_properties_edn) -> Some "--remove-tags and --remove-properties are only for update mode" | Parsed_page opts when count_present (Vec.of_array [| Option.map Int64.to_string opts.id; nonempty_trimmed opts.page; |]) > 1 -> Some "only one of --id or --page is allowed" | Parsed_page { page = Some page; _ } when String.trim page = "" -> Some "page must be non-empty" | Parsed_tag { name = Some name; _ } when normalize_tag_name name = None -> Some "tag name must not be blank" | Parsed_property opts when count_present (Vec.of_array [| Option.map Int64.to_string opts.id; nonempty_trimmed opts.name; |]) > 1 -> Some "only one of --id or --name is allowed" | Parsed_property { name = Some name; _ } when String.trim name = "" -> Some "name must be non-empty" | Parsed_asset opts -> let path = nonempty_trimmed opts.path in let target_page = nonempty_trimmed opts.target_page in let target_selectors = Vec.of_array [| Option.map Int64.to_string opts.target_id; opts.target_uuid; target_page; |] in let update_mode = Option.is_some opts.id || Option.is_some opts.uuid in if Option.is_some opts.id && Option.is_some opts.uuid then Some "only one of --id or --uuid is allowed" else if update_mode && Option.is_some path then Some "--path is only valid in create mode" else if (not update_mode) && Option.is_none path then Some "--path is required in create mode" else if count_present target_selectors > 1 then Some "only one of --target-id, --target-uuid, or --target-page is allowed" else if update_mode && (count_present target_selectors > 0 || Option.is_some opts.pos) then Some "--target-* and --pos are only valid in create mode" else if Option.is_some opts.pos && count_present target_selectors = 0 then Some "--pos is only valid when a target option is provided" else if opts.pos = Some Block.Sibling && Option.is_some target_page then Some "--pos sibling is only valid for block targets" else None | Parsed_task opts -> let uuid = nonempty_trimmed opts.uuid in let page = nonempty_trimmed opts.page in let content = nonempty_trimmed opts.content in let target_page = nonempty_trimmed opts.target_page in let status = nonempty_trimmed opts.status in let priority = nonempty_trimmed opts.priority in let selectors = Vec.of_array [| Option.map Int64.to_string opts.id; uuid; page |] in let target_selectors = Vec.of_array [| Option.map Int64.to_string opts.target_id; opts.target_uuid; target_page; |] in let selector_mode = count_present selectors > 0 in if count_present selectors > 1 then Some "only one of --id, --uuid, or --page is allowed" else if Option.is_some page && Option.is_some content then Some "--content and --page are mutually exclusive" else if (Option.is_some opts.id || Option.is_some uuid) && Option.is_some content then Some "--content is only valid when creating a block task" else if count_present target_selectors > 1 then Some "only one of --target-id, --target-uuid, or --target-page is allowed" else if selector_mode && (count_present target_selectors > 0 || Option.is_some opts.pos) then Some "--target-* and --pos are only valid when creating a block task with \ --content" else if Option.is_some opts.pos && count_present target_selectors = 0 then Some "--pos is only valid when a target option is provided" else if opts.pos = Some Block.Sibling && Option.is_some target_page then Some "--pos sibling is only valid for block targets" else if Option.is_some status && opts.no_status then Some "--status and --no-status are mutually exclusive" else if Option.is_some priority && opts.no_priority then Some "--priority and --no-priority are mutually exclusive" else if Option.is_some opts.scheduled && opts.no_scheduled then Some "--scheduled and --no-scheduled are mutually exclusive" else if Option.is_some opts.deadline && opts.no_deadline then Some "--deadline and --no-deadline are mutually exclusive" else None | _ -> None let command_id = function | Parsed_block _ -> Command_id.Upsert_block | Parsed_page _ -> Upsert_page | Parsed_task _ -> Upsert_task | Parsed_asset _ -> Upsert_asset | Parsed_tag _ -> Upsert_tag | Parsed_property _ -> Upsert_property let validate_parsed parsed = match invalid_uuid_options parsed with | Some message -> Error (Error.invalid_options message) | None -> ( match invalid_options parsed with | Some message -> Error (Error.invalid_options message) | None -> Ok ()) let repo_or_error config = match config.Cli_config.repo with | Some repo -> Ok (repo, Cli_config.repo_to_graph repo) | None -> Error (Error.missing_repo "repo is required for upsert") let ordinal value = let suffix = match value mod 100 with | 11 | 12 | 13 -> "th" | _ -> ( match value mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th") in string_of_int value ^ suffix let default_journal_title () = let year, month, day = Time.local_date (Time.now ()) in let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec"; |] in months.(month - 1) ^ " " ^ ordinal day ^ ", " ^ string_of_int year let block_target_of_parts target_id target_uuid target_page = match (target_id, nonempty_trimmed target_uuid, nonempty_trimmed target_page) with | Some id, None, None -> Ok (Target_id id) | None, Some uuid, None -> Ok (Target_uuid uuid) | None, None, Some page -> Ok (Target_page page) | None, None, None -> Error (Error.make Error.Missing_target "target page or block is required") | _ -> Error (Error.invalid_options "only one of --target-id, --target-uuid, or --target-page is allowed") let optional_block_target_of_parts target_id target_uuid target_page = match (target_id, nonempty_trimmed target_uuid, nonempty_trimmed target_page) with | None, None, None -> Ok None | Some id, None, None -> Ok (Some (Target_id id)) | None, Some uuid, None -> Ok (Some (Target_uuid uuid)) | None, None, Some page -> Ok (Some (Target_page page)) | _ -> Error (Error.invalid_options "only one of --target-id, --target-uuid, or --target-page is allowed") let add_action_of_block_create (action : block_create) : Add.action = let target_id, target_uuid, target_page_name = match action.target with | Target_id id -> (Some id, None, None) | Target_uuid uuid -> (None, Some uuid, None) | Target_page page -> (None, None, Some page) in { Add.repo = action.repo; graph = action.graph; target_id; target_uuid; target_page_name; pos = action.pos; status = action.status; tags = action.tags; properties = action.properties; blocks = action.blocks; } let block_create_of_add_action ~update_plan (action : Add.action) = Error.map (fun target -> { repo = action.repo; graph = action.graph; target; pos = action.pos; status = action.status; tags = action.tags; properties = action.properties; blocks = action.blocks; update_plan; }) (block_target_of_parts action.target_id action.target_uuid action.target_page_name) let block_update_of_update_action (action : Update.action) = let source = match (action.id, action.uuid) with | Some id, None -> Ok (Source_id id) | None, Some uuid -> Ok (Source_uuid uuid) | _ -> Error (Error.make Error.Missing_source "source block is required") in Error.bind source (fun source -> Error.map (fun target -> { repo = action.repo; graph = action.graph; source; target; pos = action.pos; update_tags = action.update_tags; update_properties = action.update_properties; remove_tags = action.remove_tags; remove_properties = action.remove_properties; content = action.content; source_label = action.source_label; target_label = action.target_label; }) (optional_block_target_of_parts action.target_id action.target_uuid action.target_page)) let update_action_of_block_update (action : block_update) : Update.action = let id, uuid = match action.source with | Source_id id -> (Some id, None) | Source_uuid uuid -> (None, Some uuid) in let target_id, target_uuid, target_page = match action.target with | None -> (None, None, None) | Some (Target_id id) -> (Some id, None, None) | Some (Target_uuid uuid) -> (None, Some uuid, None) | Some (Target_page page) -> (None, None, Some page) in { Update.repo = action.repo; graph = action.graph; id; uuid; target_id; target_uuid; target_page; pos = action.pos; update_tags = action.update_tags; update_properties = action.update_properties; remove_tags = action.remove_tags; remove_properties = action.remove_properties; content = action.content; source_label = action.source_label; target_label = action.target_label; } let normalize_page_name_input value = let value = String.trim value in if value = "" then None else Some value let strip_tag_prefix value = let value = String.trim value in let rec loop idx = if idx < String.length value && value.[idx] = '#' then loop (idx + 1) else idx in let start = loop 0 in String.sub value start (String.length value - start) |> String.trim let tag_of_value value = match ( Edn_util.as_int64 value, Edn_util.as_uuid value, Edn_util.as_keyword_t value, Edn_util.as_string value ) with | Some id, _, _, _ -> Some (Selector.Tag_id id) | _, Some uuid, _, _ -> Some (Tag_uuid uuid) | _, _, Some ident, _ -> Some (Tag_ident ident) | _, _, _, Some value -> let value = strip_tag_prefix value in if value = "" then None else if Cli_primitive.is_uuid_string value then Some (Tag_uuid value) else if value.[0] = ':' then Some (Tag_ident (Edn_util.keyword_t value)) else Some (Tag_name value) | _ -> None let key_of_value = Property.parse_key let edn_value_of_string ~label text = try Ok (Melange_edn_melange.of_edn_string text) with Melange_edn_melange.Parse_error _ -> Error (Error.invalid_options ("invalid " ^ label ^ " edn")) let parse_vector_edn ~label text = Error.bind (edn_value_of_string ~label text) (fun parsed -> match Edn_util.as_vector parsed with | Some values -> Ok values | _ -> Error (Error.invalid_options (label ^ " must be a vector"))) let parse_tags_edn ~label = function | None -> Ok Vec.empty | Some text -> Error.bind (parse_vector_edn ~label text) (fun values -> let rec loop acc remaining = match Vec.pop_front remaining with | None -> Ok acc | Some (value, rest) -> ( match tag_of_value value with | Some tag -> loop (Vec.push_back acc tag) rest | None -> Error (Error.invalid_options (label ^ " must contain strings, keywords, uuids, or ids"))) in loop Vec.empty values) let parse_property_keys_edn ~label = function | None -> Ok Vec.empty | Some text -> Error.bind (parse_vector_edn ~label text) (fun values -> let rec loop acc remaining = match Vec.pop_front remaining with | None -> Ok acc | Some (value, rest) -> ( match key_of_value value with | Some key -> loop (Vec.push_back acc key) rest | None -> Error (Error.invalid_options (label ^ " must contain property keys"))) in loop Vec.empty values) let parse_tag_schema_properties opts = Error.bind (parse_property_keys_edn ~label:"add-properties" opts.add_properties_edn) (fun add_properties -> Error.map (fun remove_properties -> (add_properties, remove_properties)) (parse_property_keys_edn ~label:"remove-properties" opts.remove_properties_edn)) let build_tag repo graph (opts : tag_opts) = Error.bind (parse_tag_schema_properties opts) (fun (add_properties, remove_properties) -> match (opts.id, Option.bind opts.name normalize_tag_name) with | Some id, name -> Ok (Upsert_tag { repo; graph; mode = Update; id = Some id; name; add_properties; remove_properties; }) | None, Some name -> Ok (Upsert_tag { repo; graph; mode = Create; id = None; name = Some name; add_properties; remove_properties; }) | None, None -> Error (Error.make Error.Missing_tag_name "tag name is required")) let parse_property_assignments_edn ~label = function | None -> Ok Vec.empty | Some text -> Error.bind (edn_value_of_string ~label text) (fun parsed -> match Edn_util.as_map parsed with | Some fields -> let rec loop acc remaining = match Vec.pop_front remaining with | None -> Ok acc | Some ((key, value), rest) -> ( match key_of_value key with | Some key -> loop (Vec.push_back acc { Property.key; value }) rest | None -> Error (Error.invalid_options (label ^ " must contain property keys"))) in loop Vec.empty fields | _ -> Error (Error.invalid_options (label ^ " must be a map"))) let parse_update_plan (opts : page_opts) = Error.bind (parse_tags_edn ~label:"update-tags" opts.update_tags_edn) (fun update_tags -> Error.bind (parse_tags_edn ~label:"remove-tags" opts.remove_tags_edn) (fun remove_tags -> Error.bind (parse_property_assignments_edn ~label:"update-properties" opts.update_properties_edn) (fun update_properties -> Error.bind (parse_property_keys_edn ~label:"remove-properties" opts.remove_properties_edn) (fun remove_properties -> Ok { Property.update_tags; remove_tags; update_properties; remove_properties; })))) let build_page repo graph (opts : page_opts) = Error.bind (parse_update_plan opts) (fun plan -> match (opts.id, Option.bind opts.page normalize_page_name_input) with | Some id, page -> Ok (Upsert_page { repo; graph; mode = Update; id = Some id; page; restore = opts.restore; plan; }) | None, Some page -> Ok (Upsert_page { repo; graph; mode = Create; id = None; page = Some page; restore = opts.restore; plan; }) | None, None -> Error (Error.make Error.Missing_page_name "page name is required")) let schema_of_property_opts (opts : property_opts) = { Property.kind = opts.kind; cardinality = opts.cardinality; hidden = opts.hide; public = opts.public; } let normalize_property_name value = let value = String.trim value in if value = "" then None else Some value let build_property repo graph (opts : property_opts) = let schema = schema_of_property_opts opts in match (opts.id, Option.bind opts.name normalize_property_name) with | Some id, name -> Ok (Upsert_property { repo; graph; mode = Update; id = Some id; name; schema }) | None, Some name -> Ok (Upsert_property { repo; graph; mode = Create; id = None; name = Some name; schema }) | None, None -> Error (Error.make Error.Missing_property_name "property name is required") let normalize_content value = let value = String.trim value in if value = "" then None else Some value let normalize_priority value = match String.lowercase_ascii (String.trim value) with | "low" -> Some (Edn_util.keyword_t "logseq.property/priority.low") | "medium" -> Some (Edn_util.keyword_t "logseq.property/priority.medium") | "high" -> Some (Edn_util.keyword_t "logseq.property/priority.high") | "urgent" -> Some (Edn_util.keyword_t "logseq.property/priority.urgent") | _ -> None let invalid_priority_message value = "Invalid value for option :priority: " ^ value ^ ". Available values: low, medium, high, urgent" let build_asset repo graph (opts : asset_opts) = let content = Option.bind opts.content normalize_content in match (opts.id, opts.uuid, opts.path) with | Some id, None, _ -> Ok (Upsert_asset { repo; graph; mode = Update; id = Some id; uuid = None; path = None; content; create_action = None; }) | None, Some uuid, _ -> Ok (Upsert_asset { repo; graph; mode = Update; id = None; uuid = Some uuid; path = None; content; create_action = None; }) | None, None, Some path -> let title = match content with | Some content -> content | None -> Filename.basename path in let add_opts = { Add.target_id = opts.target_id; target_uuid = opts.target_uuid; target_page_name = opts.target_page; pos = opts.pos; status = None; tags_edn = None; properties_edn = None; content = Some title; blocks_edn = None; blocks_file = None; } in Error.bind (Add.build_add_block_action add_opts Vec.empty repo) (fun create_action -> Error.map (fun create_action -> Upsert_asset { repo; graph; mode = Create; id = None; uuid = None; path = Some path; content = Some title; create_action = Some create_action; }) (block_create_of_add_action ~update_plan:Property.empty_update_plan create_action)) | None, None, None -> Error (Error.make Error.Missing_asset_selector "asset id, uuid, or path is required") | Some _, Some _, _ -> Error (Error.invalid_options "only one of --id or --uuid is allowed") let build_task repo graph (opts : task_opts) = let priority = Option.bind opts.priority normalize_priority in match (opts.priority, priority) with | Some value, None -> Error (Error.invalid_options (invalid_priority_message value)) | _ -> ( let clear_properties = let properties = Vec.empty in let properties = if opts.no_status then Vec.push_back properties (Property.Key_ident (Edn_util.keyword_t "logseq.property/status")) else properties in let properties = if opts.no_priority then Vec.push_back properties (Property.Key_ident (Edn_util.keyword_t "logseq.property/priority")) else properties in let properties = if opts.no_scheduled then Vec.push_back properties (Property.Key_ident (Edn_util.keyword_t "logseq.property/scheduled")) else properties in let properties = if opts.no_deadline then Vec.push_back properties (Property.Key_ident (Edn_util.keyword_t "logseq.property/deadline")) else properties in properties in let update_properties = let properties = Vec.empty in let properties = match priority with | Some priority -> Vec.push_back properties { Property.key = Property.Key_ident (Edn_util.keyword_t "logseq.property/priority"); value = Edn_util.any priority; } | None -> properties in let properties = match opts.scheduled with | Some scheduled -> Vec.push_back properties { Property.key = Property.Key_ident (Edn_util.keyword_t "logseq.property/scheduled"); value = Edn_util.float (Js.Date.getTime scheduled); } | None -> properties in let properties = match opts.deadline with | Some deadline -> Vec.push_back properties { Property.key = Property.Key_ident (Edn_util.keyword_t "logseq.property/deadline"); value = Edn_util.float (Js.Date.getTime deadline); } | None -> properties in properties in match (opts.page, opts.id, opts.uuid, opts.content) with | Some page, None, None, _ when String.trim page <> "" -> Ok (Upsert_task { repo; graph; mode = Page; id = None; uuid = None; page = Some page; content = None; update_properties; clear_properties; status_input = opts.status; }) | None, Some id, None, _ -> Ok (Upsert_task { repo; graph; mode = Update; id = Some id; uuid = None; page = None; content = opts.content; update_properties; clear_properties; status_input = opts.status; }) | None, None, Some uuid, _ -> Ok (Upsert_task { repo; graph; mode = Update; id = None; uuid = Some uuid; page = None; content = opts.content; update_properties; clear_properties; status_input = opts.status; }) | None, None, None, Some content when String.trim content <> "" -> ( match (opts.target_id, opts.target_uuid, opts.target_page, opts.pos) with | Some _, _, _, _ | _, Some _, _, _ | _, _, _, Some _ -> Error (Error.make Error.Spec_blocker "upsert task create currently supports only --target-page \ because spec/l3/upsert.mli does not carry target id, \ target uuid, or pos in Upsert_task actions") | None, None, Some target_page, None when String.trim target_page <> "" -> Ok (Upsert_task { repo; graph; mode = Create; id = None; uuid = None; page = Some target_page; content = Some content; update_properties; clear_properties; status_input = opts.status; }) | None, None, None, None -> Ok (Upsert_task { repo; graph; mode = Create; id = None; uuid = None; page = Some (default_journal_title ()); content = Some content; update_properties; clear_properties; status_input = opts.status; }) | _ -> Error (Error.make Error.Missing_target "target page is required when creating a task block")) | _ -> Error (Error.make Error.Missing_target "block or page is required") ) let parse_block_update_plan (opts : block_opts) = Error.bind (parse_tags_edn ~label:"update-tags" opts.update_tags_edn) (fun update_tags -> Error.bind (parse_tags_edn ~label:"remove-tags" opts.remove_tags_edn) (fun remove_tags -> Error.bind (parse_property_assignments_edn ~label:"update-properties" opts.update_properties_edn) (fun update_properties -> Error.bind (parse_property_keys_edn ~label:"remove-properties" opts.remove_properties_edn) (fun remove_properties -> Ok { Property.update_tags; remove_tags; update_properties; remove_properties; })))) let build_block repo (opts : block_opts) = Error.bind (parse_block_update_plan opts) (fun plan -> if update_mode opts then Error.bind (Update.build_action (update_opts_of_block_opts opts) repo) (fun action -> Error.map (fun action -> Upsert_block (Block_update action)) (block_update_of_update_action action)) else let target_page = match ( opts.target_id, nonempty_trimmed opts.target_uuid, nonempty_trimmed opts.target_page ) with | None, None, None -> Some (default_journal_title ()) | _ -> opts.target_page in let add_opts = { Add.target_id = opts.target_id; target_uuid = opts.target_uuid; target_page_name = target_page; pos = opts.pos; status = None; tags_edn = None; properties_edn = None; content = opts.content; blocks_edn = opts.blocks_edn; blocks_file = opts.blocks_file; } in Error.bind (Add.build_add_block_action add_opts Vec.empty repo) (fun action -> Error.map (fun action -> Upsert_block (Block_create action)) (block_create_of_add_action ~update_plan:plan action))) let build ?registry:_ config _globals parsed = Error.bind (validate_parsed parsed) (fun () -> Error.bind (repo_or_error config) (fun (repo, graph) -> match parsed with | Parsed_block opts -> build_block repo opts | Parsed_page opts -> build_page repo graph opts | Parsed_tag opts -> build_tag repo graph opts | Parsed_property opts -> build_property repo graph opts | Parsed_asset opts -> build_asset repo graph opts | Parsed_task opts -> build_task repo graph opts)) let kw value = Edn_util.keyword value let sym value = Edn_util.symbol value let vector_vec values = Edn_util.vector_vec values let list_vec values = Edn_util.list_vec values let query_value query = Edn_util.any (Cli_primitive.datascript_query_to_edn query) let tag_selector = vector_vec (Vec.of_array [| kw "db/id"; kw "block/uuid"; kw "block/name"; kw "block/title"; Edn_util.map_vec (Vec.of_array [| (kw "block/tags", vector_vec (Vec.of_array [| kw "db/ident" |])); |]); |]) let page_selector = vector_vec (Vec.of_array [| kw "db/id"; kw "block/uuid"; kw "block/name"; kw "block/title"; kw "logseq.property/deleted-at"; |]) let property_selector = vector_vec (Vec.of_array [| kw "db/id"; kw "db/ident"; kw "block/uuid"; kw "block/name"; kw "block/title"; kw "logseq.property/type"; |]) let asset_selector = vector_vec (Vec.of_array [| kw "db/id"; kw "block/uuid"; kw "block/title"; kw "logseq.property/deleted-at"; Edn_util.map_vec (Vec.of_array [| (kw "block/tags", vector_vec (Vec.of_array [| kw "db/ident" |])); |]); |]) let task_selector = vector_vec (Vec.of_array [| kw "db/id"; kw "block/uuid"; kw "block/name"; kw "block/title" |]) let result_ids ids = Edn_util.map_vec (Vec.of_array [| ( kw "result", Edn_util.vector_vec (ids |> Vec.map (fun id -> Edn_util.int64 id)) ); |]) module Node_crypto = struct type hash external create_hash : string -> hash = "createHash" [@@mel.module "crypto"] external update_buffer : hash -> Node.Buffer.t -> hash = "update" [@@mel.send] external digest : hash -> string -> string = "digest" [@@mel.send] end let file_sha256 path = try let payload = Cli_unix.read_binary_file path in let hash = Node_crypto.create_hash "sha256" in let payload_buffer = Node.Buffer.fromStringWithEncoding payload ~encoding:`latin1 in Some (Node_crypto.digest (Node_crypto.update_buffer hash payload_buffer) "hex") with _ -> None let file_size path = (Cli_unix.stat path).Cli_unix.st_size let file_extension path = let base = Filename.basename path in match String.rindex_opt base '.' with | Some index when index + 1 < String.length base -> Some (String.sub base (index + 1) (String.length base - index - 1) |> String.lowercase_ascii) | _ -> None let rec mkdir_p path = if path = "" || path = Filename.dirname path || Cli_unix.file_exists path then () else ( mkdir_p (Filename.dirname path); Cli_unix.mkdir path 0o755) let copy_file source destination = mkdir_p (Filename.dirname destination); Cli_unix.copy_file source destination let graph_assets_dir config repo = Filename.concat (Filename.concat (Filename.concat config.Cli_config.root_dir "graphs") (Graph_dir.graph_dir_name_of_repo repo)) "assets" let class_query selector class_ident = Cli_primitive.make_datascript_query ~find: (Vec.singleton (vector_vec (Vec.of_array [| list_vec (Vec.of_array [| sym "pull"; sym "?e"; selector |]); sym "..."; |]))) ~in_: (Vec.of_array [| Melange_edn_melange.symbol "$"; Melange_edn_melange.symbol "?name"; |]) ~where: (Vec.of_array [| Cli_primitive.V (Edn_util.vector_t_vec (Vec.of_array [| sym "?e"; kw "block/name"; sym "?name" |])); Cli_primitive.V (Edn_util.vector_t_vec (Vec.of_array [| sym "?e"; kw "block/tags"; sym "?t" |])); Cli_primitive.V (Edn_util.vector_t_vec (Vec.of_array [| sym "?t"; kw "db/ident"; kw class_ident |])); |]) () let tag_query selector = class_query selector "logseq.class/Tag" let property_query selector = class_query selector "logseq.class/Property" let page_query selector = Cli_primitive.make_datascript_query ~find: (Vec.singleton (vector_vec (Vec.of_array [| list_vec (Vec.of_array [| sym "pull"; sym "?e"; selector |]); sym "..."; |]))) ~in_: (Vec.of_array [| Melange_edn_melange.symbol "$"; Melange_edn_melange.symbol "?name"; |]) ~where: (Vec.of_array [| Cli_primitive.V (Edn_util.vector_t_vec (Vec.of_array [| sym "?e"; kw "block/name"; sym "?name" |])); |]) () let pull_pages_by_name config repo name selector = Transport.thread_api_q config ~repo ~query: (Edn_util.vector_t_vec (Vec.of_array [| query_value (page_query selector); Edn_util.string (normalized_lookup_name name); |])) let pull_tag_by_name config repo name selector = Transport.thread_api_q config ~repo ~query: (Edn_util.vector_t_vec (Vec.of_array [| query_value (tag_query selector); Edn_util.string (normalized_lookup_name name); |])) let list_tags config repo = Transport.thread_api_cli_list_tags config ~repo ~options:(Edn_util.map_t_vec Vec.empty) let tag_name_matches name entity = let expected = normalized_lookup_name name in let matches value = String.equal (normalized_lookup_name value) expected in match ( Edn_util.get_string entity "block/title", Edn_util.get_string entity "block/name" ) with | Some title, _ when matches title -> true | _, Some name when matches name -> true | _ -> false let find_tag_by_name config repo name = let open Cli_effect in bind (list_tags config repo) (fun value -> match Edn_util.as_seq value with | Some tags -> pure (Vec.find_opt (tag_name_matches name) tags) | None -> pure None) let pull_property_by_name config repo name selector = Transport.thread_api_q config ~repo ~query: (Edn_util.vector_t_vec (Vec.of_array [| query_value (property_query selector); Edn_util.string (normalized_lookup_name name); |])) let pull_entity_by_id config repo selector id = Transport.thread_api_pull config ~repo ~selector:(Edn_util.expect_vector_t "upsert pull selector" selector) ~lookup:(Edn_util.int64 id) let pull_entity_by_lookup config repo selector lookup = Transport.thread_api_pull config ~repo ~selector:(Edn_util.expect_vector_t "upsert pull selector" selector) ~lookup let first_entity value = match (Edn_util.as_vector value, Edn_util.as_list value) with | Some values, _ when not (Vec.is_empty values) -> Some (Vec.peek_front values) | _, Some values when not (Vec.is_empty values) -> Some (Vec.peek_front values) | _ -> None let id_of_entity value = Edn_util.get_int64 value "db/id" let uuid_of_entity value = Option.bind (Edn_util.get value "block/uuid") Edn_util.as_string_like let name_of_entity value = Edn_util.get_string value "block/name" let tag_entity value = match Option.bind (Edn_util.get value "block/tags") Edn_util.as_seq with | Some tags -> Vec.exists (fun tag -> match Option.bind (Edn_util.get tag "db/ident") Edn_util.as_string_like with | Some ident -> strip_keyword_prefix ident = "logseq.class/Tag" | _ -> false) tags | _ -> false let property_entity value = Option.is_some (Edn_util.get value "logseq.property/type") let asset_entity value = match Option.bind (Edn_util.get value "block/tags") Edn_util.as_seq with | Some tags -> Vec.exists (fun tag -> match Option.bind (Edn_util.get tag "db/ident") Edn_util.as_string_like with | Some ident -> strip_keyword_prefix ident = "logseq.class/Asset" | _ -> false) tags | _ -> false let ident_of_entity value = Option.bind (Edn_util.get value "db/ident") Edn_util.as_keyword_t let lookup_of_tag = function | Selector.Tag_id id -> Edn_util.int64 id | Tag_name name -> Edn_util.string (normalized_lookup_name name) | Tag_ident ident -> Edn_util.any ident | Tag_uuid uuid -> Edn_util.uuid uuid let apply_outliner_ops config repo ops = Transport.thread_api_apply_outliner_ops config ~repo ~ops:(Edn_util.vector_t_vec ops) ~options:(Edn_util.map_t_vec Vec.empty) let create_tag_page config repo name = let op = Edn_util.vector_vec (Vec.of_array [| kw "create-page"; Edn_util.vector_vec (Vec.of_array [| Edn_util.string name; Edn_util.map_vec (Vec.of_array [| (kw "class?", Edn_util.bool true) |]); |]); |]) in apply_outliner_ops config repo (Vec.singleton op) let create_page config repo name = let op = Edn_util.vector_vec (Vec.of_array [| kw "create-page"; Edn_util.vector_vec (Vec.of_array [| Edn_util.string name; Edn_util.map_vec Vec.empty |]); |]) in apply_outliner_ops config repo (Vec.singleton op) let rename_page config repo uuid name = let op = Edn_util.vector_vec (Vec.of_array [| kw "rename-page"; Edn_util.vector_vec (Vec.of_array [| Edn_util.uuid uuid; Edn_util.string name |]); |]) in apply_outliner_ops config repo (Vec.singleton op) let value_of_kind kind = Edn_util.keyword (Property.string_of_kind kind) let value_of_cardinality = function | Property.One -> Edn_util.keyword "db.cardinality/one" | Many -> Edn_util.keyword "db.cardinality/many" let value_of_schema (schema : Property.schema) = let fields = Vec.empty in let fields = match schema.kind with | Some kind -> Vec.push_back fields (kw "logseq.property/type", value_of_kind kind) | None -> fields in let fields = match schema.cardinality with | Some cardinality -> Vec.push_back fields (kw "db/cardinality", value_of_cardinality cardinality) | None -> fields in let fields = match schema.hidden with | Some hidden -> Vec.push_back fields (kw "logseq.property/hide?", Edn_util.bool hidden) | None -> fields in let fields = match schema.public with | Some public -> Vec.push_back fields (kw "logseq.property/public?", Edn_util.bool public) | None -> fields in Edn_util.map_vec fields let schema_empty (schema : Property.schema) = schema.kind = None && schema.cardinality = None && schema.hidden = None && schema.public = None let upsert_property_op ?(opts = Edn_util.map_vec Vec.empty) ident schema = let ident = match ident with Some ident -> Edn_util.any ident | None -> Edn_util.nil in Edn_util.vector_vec (Vec.of_array [| kw "upsert-property"; Edn_util.vector_vec (Vec.of_array [| ident; value_of_schema schema; opts |]); |]) let upsert_property config repo ?opts ident schema = apply_outliner_ops config repo (Vec.singleton (upsert_property_op ?opts ident schema)) let ok_tag_ids mode ids = Cli_result.ok ~command:Command_id.Upsert_tag mode (Raw (result_ids ids)) let ok_page_ids mode ids = Cli_result.ok ~command:Command_id.Upsert_page mode (Raw (result_ids ids)) let ok_property_ids mode ids = Cli_result.ok ~command:Command_id.Upsert_property mode (Raw (result_ids ids)) let ok_asset_ids mode ids = Cli_result.ok ~command:Command_id.Upsert_asset mode (Raw (result_ids ids)) let tag_not_found mode = Cli_result.error ~command:Command_id.Upsert_tag mode (Error.make Error.Tag_not_found "tag not found after upsert") let upsert_id_not_found entity_type id = Error.make Error.Upsert_id_not_found (entity_type ^ " not found for id") ~context: (Edn_util.map_vec (Vec.of_array [| (kw "entity-type", Edn_util.string entity_type); (kw "id", Edn_util.int64 id); |])) let upsert_id_type_mismatch entity_type id = Error.make Error.Upsert_id_type_mismatch ("id must be a node tagged with #" ^ entity_type) ~context: (Edn_util.map_vec (Vec.of_array [| (kw "entity-type", Edn_util.string entity_type); (kw "id", Edn_util.int64 id); |])) let same_tag_name entity target_name = match name_of_entity entity with | Some current_name -> String.equal current_name (normalized_lookup_name target_name) | None -> false let rename_conflict current_entity target = match (id_of_entity target, id_of_entity current_entity) with | None, _ -> None | Some target_id, Some current_id when target_id = current_id -> None | Some _, _ when tag_entity target -> Some (Error.make Error.Tag_rename_conflict "rename target already exists as a tag") | Some _, _ -> Some (Error.make Error.Tag_name_conflict "tag already exists as a page and is not a tag") let page_entity value = Option.is_some (name_of_entity value) let recycled_entity value = Option.is_some (Edn_util.get value "logseq.property/deleted-at") let page_not_found () = Error.make Error.Page_not_found "page not found" let recycled_page_error () = Error.make Error.Recycled_page "page is recycled" let resolve_tag_id invoke_config repo tag = let open Cli_effect in match tag with | Selector.Tag_id id -> pure (Ok id) | Tag_name name -> bind (find_tag_by_name invoke_config repo name) (fun result -> match Option.bind result id_of_entity with | Some id -> pure (Ok id) | None -> pure (Error (Error.make Error.Tag_not_found "tag not found"))) | Tag_ident _ | Tag_uuid _ -> bind (pull_entity_by_lookup invoke_config repo tag_selector (lookup_of_tag tag)) (fun result -> match id_of_entity result with | Some id -> pure (Ok id) | None -> pure (Error (Error.make Error.Tag_not_found "tag not found"))) let property_key_label = function | Property.Key_ident ident -> Edn_util.keyword_to_string ident |> strip_keyword_prefix | Key_id id -> Int64.to_string id | Key_name name -> name 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 qualified_property_ident ident = String.contains (property_key_label (Property.Key_ident ident)) '/' let property_not_found_error key = let label = property_key_label key in Error.make Error.Property_not_found ("property not found: " ^ label) let resolved_property_ident key entity = match (id_of_entity entity, ident_of_entity entity) with | Some _, Some ident -> Ok ident | _ -> Error (property_not_found_error key) let resolved_property_ident_from_query key result = match first_entity result with | Some entity -> resolved_property_ident key entity | None -> Error (property_not_found_error key) let resolved_schema_property_ident key entity = if property_entity entity then resolved_property_ident key entity else Error (property_not_found_error key) let resolved_schema_property_ident_from_query key result = match first_entity result with | Some entity -> resolved_schema_property_ident key entity | None -> Error (property_not_found_error key) let resolve_property_ident invoke_config repo key = let open Cli_effect in match key with | Property.Key_ident ident when qualified_property_ident ident -> pure (Ok ident) | Property.Key_ident ident -> bind (pull_entity_by_lookup invoke_config repo (vector_vec (Vec.of_array [| kw "db/id" |])) (vector_vec (Vec.of_array [| kw "db/ident"; Edn_util.any ident |]))) (fun result -> match resolved_property_ident key result with | Ok ident -> pure (Ok ident) | Error _ when not (qualified_property_ident ident) -> bind (pull_property_by_name invoke_config repo (property_key_label key) property_selector) (fun result -> pure (resolved_property_ident_from_query key result)) | Error err -> pure (Error err)) | Key_id id -> bind (pull_entity_by_lookup invoke_config repo (vector_vec (Vec.of_array [| kw "db/ident" |])) (Edn_util.int64 id)) (fun result -> match ident_of_entity result with | Some ident -> pure (Ok ident) | None -> pure (Error (property_not_found_error key))) | Key_name name -> bind (pull_property_by_name invoke_config repo name property_selector) (fun result -> match resolved_property_ident_from_query key result with | Ok ident -> pure (Ok ident) | Error _ -> let ident = Edn_util.keyword_t name in bind (pull_entity_by_lookup invoke_config repo (vector_vec (Vec.of_array [| kw "db/id" |])) (vector_vec (Vec.of_array [| kw "db/ident"; Edn_util.any ident |]))) (fun result -> if Option.is_some (id_of_entity result) then pure (Ok ident) else pure (Error (property_not_found_error key)))) let resolve_schema_property_ident invoke_config repo key = let open Cli_effect in match key with | Property.Key_ident ident -> bind (pull_entity_by_lookup invoke_config repo property_selector (vector_vec (Vec.of_array [| kw "db/ident"; Edn_util.any ident |]))) (fun result -> match resolved_schema_property_ident key result with | Ok ident -> pure (Ok ident) | Error _ when not (qualified_property_ident ident) -> bind (pull_property_by_name invoke_config repo (property_key_label key) property_selector) (fun result -> pure (resolved_schema_property_ident_from_query key result)) | Error err -> pure (Error err)) | Key_id id -> bind (pull_entity_by_lookup invoke_config repo property_selector (Edn_util.int64 id)) (fun result -> pure (resolved_schema_property_ident key result)) | Key_name name -> bind (pull_property_by_name invoke_config repo name property_selector) (fun result -> match resolved_schema_property_ident_from_query key result with | Ok ident -> pure (Ok ident) | Error _ -> let ident = Edn_util.keyword_t name in bind (pull_entity_by_lookup invoke_config repo property_selector (vector_vec (Vec.of_array [| kw "db/ident"; Edn_util.any ident |]))) (fun result -> pure (resolved_schema_property_ident key result))) let resolve_tag_ids invoke_config repo tags = let open Cli_effect in let rec loop acc remaining = match Vec.pop_front remaining with | None -> pure (Ok acc) | Some (tag, rest) -> bind (resolve_tag_id invoke_config repo tag) (function | Error err -> pure (Error err) | Ok id -> loop (Vec.push_back acc id) rest) in loop Vec.empty tags let resolve_property_keys invoke_config repo keys = let open Cli_effect in let rec loop acc remaining = match Vec.pop_front remaining with | None -> pure (Ok acc) | Some (key, rest) -> bind (resolve_property_ident invoke_config repo key) (function | Error err -> pure (Error err) | Ok ident -> loop (Vec.push_back acc ident) rest) in loop Vec.empty keys let resolve_schema_property_keys invoke_config repo keys = let open Cli_effect in let rec loop acc remaining = match Vec.pop_front remaining with | None -> pure (Ok acc) | Some (key, rest) -> bind (resolve_schema_property_ident invoke_config repo key) (function | Error err -> pure (Error err) | Ok ident -> loop (Vec.push_back acc ident) rest) in loop Vec.empty keys let block_uuid_lookup_ref value = match (Edn_util.as_vector value, Edn_util.as_list value) with | Some values, _ when Vec.length values = 2 -> ( match ( Edn_util.as_string_like (Vec.nth values 0), Edn_util.as_string_like (Vec.nth values 1) ) with | Some "block/uuid", Some uuid -> Some uuid | _ -> None) | _, Some values when Vec.length values = 2 -> ( match ( Edn_util.as_string_like (Vec.nth values 0), Edn_util.as_string_like (Vec.nth values 1) ) with | Some "block/uuid", Some uuid -> Some uuid | _ -> None) | _ -> None let resolve_block_uuid_ref invoke_config repo uuid = let open Cli_effect in bind (pull_entity_by_lookup invoke_config repo (vector_vec (Vec.of_array [| kw "db/id"; kw "block/uuid" |])) (vector_vec (Vec.of_array [| kw "block/uuid"; Edn_util.uuid uuid |]))) (fun entity -> match id_of_entity entity with | Some id -> pure (Ok (Edn_util.int64 id)) | None -> pure (Error (Error.make Error.Block_not_found ("block not found: " ^ uuid)))) let rec resolve_property_value_refs invoke_config repo value = let open Cli_effect in match block_uuid_lookup_ref value with | Some uuid -> resolve_block_uuid_ref invoke_config repo uuid | None -> ( let resolve_values wrap values = let rec loop acc remaining = match Vec.pop_front remaining with | None -> pure (Ok (wrap acc)) | Some (value, rest) -> bind (resolve_property_value_refs invoke_config repo value) (function | Error err -> pure (Error err) | Ok value -> loop (Vec.push_back acc value) rest) in loop Vec.empty values in match value with | Melange_edn_melange.Any (Melange_edn_melange.Vector values) -> resolve_values Edn_util.vector_vec (Edn_util.vec_of_array values) | Any (List values) -> resolve_values Edn_util.list_vec (Edn_util.vec_of_array values) | Any (Set values) -> resolve_values Edn_util.set_vec (Edn_util.vec_of_array values) | Any (Map fields) -> let rec loop acc remaining = match Vec.pop_front remaining with | None -> pure (Ok (Edn_util.map_vec acc)) | Some ((key, value), rest) -> bind (resolve_property_value_refs invoke_config repo value) (function | Error err -> pure (Error err) | Ok value -> loop (Vec.push_back acc (key, value)) rest) in loop Vec.empty (Edn_util.vec_of_array fields) | _ -> pure (Ok value)) let resolve_property_assignments invoke_config repo assignments = let open Cli_effect in let rec loop acc remaining = match Vec.pop_front remaining with | None -> pure (Ok acc) | Some (assignment, rest) -> bind (resolve_property_ident invoke_config repo assignment.Property.key) (function | Error err -> pure (Error err) | Ok ident -> bind (resolve_property_value_refs invoke_config repo assignment.value) (function | Error err -> pure (Error err) | Ok value -> loop (Vec.push_back acc (ident, value)) rest)) in loop Vec.empty assignments let option_resolution_error option err = { err with Error.context = Some (Edn_util.map_vec (Vec.of_array [| (kw "option", Edn_util.string option); (kw "phase", Edn_util.string "resolve-options"); |])); } let structural_block_field key = match Edn_util.as_string_like key with | Some key -> key = "block/title" || key = "block/content" || key = "block/uuid" || key = "block/children" || key = "block/tags" || string_starts_with ~prefix:"db/" key || string_starts_with ~prefix:"build/" key | None -> false let inline_property_assignments block = match Edn_util.as_map block.Block.raw with | None -> Ok Vec.empty | Some fields -> let rec loop acc remaining = match Vec.pop_front remaining with | None -> Ok acc | Some ((key, value), rest) -> ( if structural_block_field key then loop acc rest else match Property.parse_key key with | Some key -> loop (Vec.push_back acc { Property.key; value }) rest | None -> Error (Error.invalid_options ("invalid block property key: " ^ Melange_edn_melange.to_edn_string key))) in loop Vec.empty fields let rec resolve_block_inline_properties invoke_config repo block = let open Cli_effect in match inline_property_assignments block with | Error err -> pure (Error err) | Ok assignments -> bind (resolve_property_assignments invoke_config repo assignments) (function | Error err -> pure (Error (option_resolution_error "--blocks" err)) | Ok resolved_assignments -> let resolved_properties = Vec.map (fun (ident, value) -> { Property.key = Property.Key_ident ident; value }) resolved_assignments in let rec resolve_children acc remaining = match Vec.pop_front remaining with | None -> pure (Ok acc) | Some (child, rest) -> bind (resolve_block_inline_properties invoke_config repo child) (function | Error err -> pure (Error err) | Ok child -> resolve_children (Vec.push_back acc child) rest) in bind (resolve_children Vec.empty block.Block.children) (function | Error err -> pure (Error err) | Ok children -> pure (Ok { block with Block.properties = Vec.append block.Block.properties resolved_properties; children; }))) let resolve_blocks_inline_properties invoke_config repo blocks = let open Cli_effect in let rec loop acc remaining = match Vec.pop_front remaining with | None -> pure (Ok acc) | Some (block, rest) -> bind (resolve_block_inline_properties invoke_config repo block) (function | Error err -> pure (Error err) | Ok block -> loop (Vec.push_back acc block) rest) in loop Vec.empty blocks let rec strip_block_properties block = { block with Block.properties = Vec.empty; children = Vec.map strip_block_properties block.Block.children; } let property_key_value = function | Property.Key_ident ident -> Edn_util.any ident | Key_id id -> Edn_util.int64 id | Key_name name -> Edn_util.string name let rec block_inline_property_ops block = let own_ops = match (block.Block.uuid, block.Block.properties) with | Some uuid, properties -> Vec.map (fun assignment -> Edn_util.vector_vec (Vec.of_array [| kw "batch-set-property"; Edn_util.vector_vec (Vec.of_array [| Edn_util.vector_vec (Vec.of_array [| Edn_util.uuid uuid |]); property_key_value assignment.Property.key; assignment.value; Edn_util.map_vec Vec.empty; |]); |])) properties | None, _ -> Vec.empty in Vec.append own_ops (Vec.concat_map block_inline_property_ops block.Block.children) let inline_property_ops blocks = Vec.concat_map block_inline_property_ops blocks let apply_inline_property_ops invoke_config repo blocks = let open Cli_effect in let ops = inline_property_ops blocks in if Vec.is_empty ops then pure (Ok Edn_util.nil) else bind (apply_outliner_ops invoke_config repo ops) (fun result -> pure (Ok result)) let append_tag_and_property_ops block_uuids ~update_tag_ids ~remove_tag_ids ~update_properties ~remove_properties = let uuid_values = Edn_util.vector_vec (block_uuids |> Vec.map (fun uuid -> Edn_util.uuid uuid)) in let remove_tag_ops = Vec.map (fun tag_id -> Edn_util.vector_vec (Vec.of_array [| kw "batch-delete-property-value"; Edn_util.vector_vec (Vec.of_array [| uuid_values; kw "block/tags"; Edn_util.int64 tag_id |]); |])) remove_tag_ids in let remove_property_ops = Vec.map (fun ident -> Edn_util.vector_vec (Vec.of_array [| kw "batch-remove-property"; Edn_util.vector_vec (Vec.of_array [| uuid_values; Edn_util.any ident |]); |])) remove_properties in let update_tag_ops = Vec.map (fun tag_id -> Edn_util.vector_vec (Vec.of_array [| kw "batch-set-property"; Edn_util.vector_vec (Vec.of_array [| uuid_values; kw "block/tags"; Edn_util.int64 tag_id; Edn_util.map_vec Vec.empty; |]); |])) update_tag_ids in let update_property_ops = Vec.map (fun (ident, value) -> Edn_util.vector_vec (Vec.of_array [| kw "batch-set-property"; Edn_util.vector_vec (Vec.of_array [| uuid_values; Edn_util.any ident; value; Edn_util.map_vec Vec.empty; |]); |])) update_properties in Vec.append remove_tag_ops (Vec.append remove_property_ops (Vec.append update_tag_ops update_property_ops)) let resolve_update_plan invoke_config repo plan = let open Cli_effect in bind (resolve_tag_ids invoke_config repo plan.Property.update_tags) (function | Error err -> pure (Error (option_resolution_error "--update-tags" err)) | Ok update_tag_ids -> bind (resolve_tag_ids invoke_config repo plan.remove_tags) (function | Error err -> pure (Error (option_resolution_error "--remove-tags" err)) | Ok remove_tag_ids -> bind (resolve_property_assignments invoke_config repo plan.update_properties) (function | Error err -> pure (Error (option_resolution_error "--update-properties" err)) | Ok update_properties -> bind (resolve_property_keys invoke_config repo plan.remove_properties) (function | Error err -> pure (Error (option_resolution_error "--remove-properties" err)) | Ok remove_properties -> pure (Ok ( update_tag_ids, remove_tag_ids, update_properties, remove_properties )))))) let apply_resolved_update_plan invoke_config repo block_uuids (update_tag_ids, remove_tag_ids, update_properties, remove_properties) = let open Cli_effect in let ops = append_tag_and_property_ops block_uuids ~update_tag_ids ~remove_tag_ids ~update_properties ~remove_properties in if Vec.is_empty ops then pure (Ok Edn_util.nil) else bind (apply_outliner_ops invoke_config repo ops) (fun result -> pure (Ok result)) let execute_plan_on_uuids invoke_config repo block_uuids plan = let open Cli_effect in bind (resolve_update_plan invoke_config repo plan) (function | Error err -> pure (Error err) | Ok resolved -> apply_resolved_update_plan invoke_config repo block_uuids resolved) let execute_page_plan invoke_config repo page_uuid plan = execute_plan_on_uuids invoke_config repo (Vec.singleton page_uuid) plan let restore_recycled_page invoke_config repo page_uuid = apply_outliner_ops invoke_config repo (Vec.singleton (vector_vec (Vec.of_array [| kw "restore-recycled"; vector_vec (Vec.of_array [| Edn_util.uuid page_uuid |]); |]))) let pull_created_page invoke_config repo name create_result = let uuid_value = match (Edn_util.as_vector create_result, Edn_util.as_list create_result) with | Some values, _ -> Vec.nth_opt values 1 | _, Some values -> Vec.nth_opt values 1 | _ -> None in match uuid_value with | Some uuid_value -> ( match Edn_util.as_string_like uuid_value with | Some uuid -> Transport.thread_api_pull invoke_config ~repo ~selector: (Edn_util.vector_t_vec (Vec.of_array [| kw "db/id"; kw "block/uuid" |])) ~lookup: (vector_vec (Vec.of_array [| kw "block/uuid"; Edn_util.uuid uuid |])) | _ -> Transport.thread_api_pull invoke_config ~repo ~selector: (Edn_util.vector_t_vec (Vec.of_array [| kw "db/id"; kw "block/uuid" |])) ~lookup: (vector_vec (Vec.of_array [| kw "block/name"; Edn_util.string (normalized_lookup_name name); |]))) | _ -> Transport.thread_api_pull invoke_config ~repo ~selector: (Edn_util.vector_t_vec (Vec.of_array [| kw "db/id"; kw "block/uuid" |])) ~lookup: (vector_vec (Vec.of_array [| kw "block/name"; Edn_util.string (normalized_lookup_name name); |])) let tag_schema_property_ops tag_uuid ~add_properties ~remove_properties = let add_ops = Vec.map (fun ident -> Edn_util.vector_vec (Vec.of_array [| kw "class-add-property"; Edn_util.vector_vec (Vec.of_array [| Edn_util.uuid tag_uuid; Edn_util.any ident |]); |])) add_properties in let remove_ops = Vec.map (fun ident -> Edn_util.vector_vec (Vec.of_array [| kw "class-remove-property"; Edn_util.vector_vec (Vec.of_array [| Edn_util.uuid tag_uuid; Edn_util.any ident |]); |])) remove_properties in Vec.append add_ops remove_ops let execute_tag_schema_properties invoke_config repo tag_uuid ~add_properties ~remove_properties = let open Cli_effect in bind (resolve_schema_property_keys invoke_config repo add_properties) (function | Error err -> pure (Error (option_resolution_error "--add-properties" err)) | Ok add_properties -> bind (resolve_schema_property_keys invoke_config repo remove_properties) (function | Error err -> pure (Error (option_resolution_error "--remove-properties" err)) | Ok remove_properties -> let ops = tag_schema_property_ops tag_uuid ~add_properties ~remove_properties in if Vec.is_empty ops then pure (Ok Edn_util.nil) else bind (apply_outliner_ops invoke_config repo ops) (fun result -> pure (Ok result)))) let tag_result_with_schema_properties mode invoke_config repo entity ~add_properties ~remove_properties = let open Cli_effect in match (id_of_entity entity, uuid_of_entity entity) with | Some id, Some uuid -> if tag_entity entity then bind (execute_tag_schema_properties invoke_config repo uuid ~add_properties ~remove_properties) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_tag mode err) | Ok _ -> pure (ok_tag_ids mode (Vec.singleton id))) else pure (Cli_result.error ~command:Command_id.Upsert_tag mode (Error.make Error.Tag_create_not_tag "created entity is not tagged as :logseq.class/Tag")) | Some _, None -> pure (Cli_result.error ~command:Command_id.Upsert_tag mode (Error.make Error.Upsert_id_not_found "tag uuid not found")) | None, _ -> pure (tag_not_found mode) let execute_create_tag mode invoke_config repo name ~add_properties ~remove_properties = let open Cli_effect in bind (pull_tag_by_name invoke_config repo name tag_selector) (fun existing -> match first_entity existing with | Some entity -> tag_result_with_schema_properties mode invoke_config repo entity ~add_properties ~remove_properties | None -> bind (create_tag_page invoke_config repo name) (fun _ -> bind (pull_tag_by_name invoke_config repo name tag_selector) (fun page -> match first_entity page with | Some entity -> tag_result_with_schema_properties mode invoke_config repo entity ~add_properties ~remove_properties | None -> pure (tag_not_found mode)))) let execute_update_tag mode invoke_config repo id name ~add_properties ~remove_properties = let open Cli_effect in bind (pull_entity_by_id invoke_config repo tag_selector id) (fun entity -> match id_of_entity entity with | None -> pure (Cli_result.error ~command:Command_id.Upsert_tag mode (upsert_id_not_found "tag" id)) | Some id when not (tag_entity entity) -> pure (Cli_result.error ~command:Command_id.Upsert_tag mode (upsert_id_type_mismatch "Tag" id)) | Some _ -> ( match name with | None -> tag_result_with_schema_properties mode invoke_config repo entity ~add_properties ~remove_properties | Some target_name when same_tag_name entity target_name -> tag_result_with_schema_properties mode invoke_config repo entity ~add_properties ~remove_properties | Some target_name -> bind (pull_tag_by_name invoke_config repo target_name tag_selector) (fun target -> match Option.bind (first_entity target) (rename_conflict entity) with | Some err -> pure (Cli_result.error ~command:Command_id.Upsert_tag mode err) | None -> ( match uuid_of_entity entity with | None -> pure (Cli_result.error ~command:Command_id.Upsert_tag mode (Error.make Error.Upsert_id_not_found "tag uuid not found")) | Some uuid -> bind (rename_page invoke_config repo uuid target_name) (fun _ -> tag_result_with_schema_properties mode invoke_config repo entity ~add_properties ~remove_properties))))) let execute_create_property mode invoke_config repo name schema = let open Cli_effect in bind (pull_property_by_name invoke_config repo name property_selector) (fun existing -> let ident = Option.bind (first_entity existing) ident_of_entity in let opts = match ident with | Some _ -> Edn_util.map_vec Vec.empty | None -> Edn_util.map_vec (Vec.of_array [| (kw "property-name", Edn_util.string name) |]) in bind (upsert_property invoke_config repo ~opts ident schema) (fun _ -> bind (pull_property_by_name invoke_config repo name property_selector) (fun property -> match Option.bind (first_entity property) id_of_entity with | Some id -> pure (ok_property_ids mode (Vec.singleton id)) | None -> pure (Cli_result.error ~command:Command_id.Upsert_property mode (Error.make Error.Property_not_found "property not found after upsert"))))) let execute_update_property mode invoke_config repo id schema = let open Cli_effect in bind (pull_entity_by_id invoke_config repo property_selector id) (fun entity -> match id_of_entity entity with | None -> pure (Cli_result.error ~command:Command_id.Upsert_property mode (upsert_id_not_found "property" id)) | Some id when not (property_entity entity) -> pure (Cli_result.error ~command:Command_id.Upsert_property mode (upsert_id_type_mismatch "Property" id)) | Some id -> if schema_empty schema then pure (ok_property_ids mode (Vec.singleton id)) else let ident = ident_of_entity entity in bind (upsert_property invoke_config repo ident schema) (fun _ -> pure (ok_property_ids mode (Vec.singleton id)))) let save_block_title invoke_config repo uuid content = let block = Edn_util.map_vec (Vec.of_array [| (kw "block/uuid", Edn_util.uuid uuid); (kw "block/title", Edn_util.string content); |]) in let op = Edn_util.vector_vec (Vec.of_array [| kw "save-block"; Edn_util.vector_vec (Vec.of_array [| block; Edn_util.map_vec Vec.empty |]); |]) in apply_outliner_ops invoke_config repo (Vec.singleton op) let pull_asset_by_uuid invoke_config repo uuid = pull_entity_by_lookup invoke_config repo asset_selector (vector_vec (Vec.of_array [| kw "block/uuid"; Edn_util.uuid uuid |])) let ensure_asset_file_metadata path = if not (Cli_unix.file_exists path) then Error (Error.make ~context: (Edn_util.map_vec (Vec.of_array [| (kw "path", Edn_util.string path) |])) Error.Asset_file_not_found "asset file not found") else match file_extension path with | None -> Error (Error.make ~context: (Edn_util.map_vec (Vec.of_array [| (kw "path", Edn_util.string path) |])) Error.Invalid_options "asset path must include a file extension") | Some asset_type -> ( match file_sha256 path with | None -> Error (Error.make ~context: (Edn_util.map_vec (Vec.of_array [| (kw "path", Edn_util.string path) |])) Error.Asset_checksum_failed "asset checksum failed") | Some checksum -> Ok (asset_type, file_size path, checksum)) let ensure_asset_tag_id invoke_config repo = let open Cli_effect in bind (pull_entity_by_lookup invoke_config repo (vector_vec (Vec.of_array [| kw "db/id" |])) (vector_vec (Vec.of_array [| kw "db/ident"; kw "logseq.class/Asset" |]))) (fun entity -> match id_of_entity entity with | Some id -> pure (Ok id) | None -> pure (Error (Error.make Error.Asset_tag_not_found "asset tag not found"))) let with_asset_metadata (block : Block.t) asset_tag_id asset_type asset_size asset_checksum = { block with Block.tags = Vec.push_front block.tags (Selector.Tag_id asset_tag_id); properties = Vec.prepend_array block.properties [| { Property.key = Property.Key_ident (Edn_util.keyword_t "logseq.property.asset/type"); value = Edn_util.string asset_type; }; { key = Property.Key_ident (Edn_util.keyword_t "logseq.property.asset/size"); value = Edn_util.int64 (Int64.of_int asset_size); }; { key = Property.Key_ident (Edn_util.keyword_t "logseq.property.asset/checksum"); value = Edn_util.string asset_checksum; }; |]; } let result_ids_of_create_result result = match Cli_result.data_value result with | Some value -> ( match Option.bind (Edn_util.get value "result") Edn_util.as_seq with | Some values -> let ids = Vec.filter_map Edn_util.as_int64 values in if Vec.length ids = Vec.length values then Some ids else None | _ -> None) | None -> None let execute_create_asset mode config repo path create_action = let open Cli_effect in bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode err) | Ok invoke_config -> ( match ensure_asset_file_metadata path with | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode err) | Ok (asset_type, asset_size, asset_checksum) -> bind (ensure_asset_tag_id invoke_config repo) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode err) | Ok asset_tag_id -> ( match Vec.pop_front create_action.blocks with | None -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode (Error.make Error.Asset_create_failed "created asset block missing uuid")) | Some (first, rest) -> ( match first.Block.uuid with | None -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode (Error.make Error.Asset_create_failed "created asset block missing uuid")) | Some block_uuid -> ( let first = with_asset_metadata first asset_tag_id asset_type asset_size asset_checksum in let create_action = { create_action with blocks = Vec.push_front rest first; } in let add_action = add_action_of_block_create create_action in let destination = Filename.concat (graph_assets_dir config repo) (block_uuid ^ "." ^ asset_type) in try copy_file path destination; bind (Add.execute_add_block add_action config mode) (fun result -> if Cli_result.is_error result then pure result else match result_ids_of_create_result result with | Some ids -> pure (Cli_result.ok ~command:Command_id.Upsert_asset mode (Raw (result_ids ids))) | None -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode (Error.make Error.Asset_create_failed "asset block not created"))) with exn -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode (Error.make Error.Asset_file_copy_failed (Printexc.to_string exn))))))))) let execute_update_asset mode invoke_config repo id uuid content = let open Cli_effect in let pulled = match (id, uuid) with | Some id, _ -> pull_entity_by_id invoke_config repo asset_selector id | None, Some uuid -> pull_asset_by_uuid invoke_config repo uuid | None, None -> pure Edn_util.nil in bind pulled (fun entity -> match id_of_entity entity with | None -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode (upsert_id_not_found "asset" (Option.value id ~default:0L))) | Some id when not (asset_entity entity) -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode (upsert_id_type_mismatch "Asset" id)) | Some id -> ( match (content, uuid_of_entity entity) with | Some content, Some uuid -> bind (save_block_title invoke_config repo uuid content) (fun _ -> pure (ok_asset_ids mode (Vec.singleton id))) | Some _, None -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode (Error.make Error.Upsert_id_not_found "asset uuid not found")) | None, _ -> pure (ok_asset_ids mode (Vec.singleton id)))) let ok_task_ids mode ids = Cli_result.ok ~command:Command_id.Upsert_task mode (Raw (result_ids ids)) let status_query invoke_config repo = Transport.thread_api_q invoke_config ~repo ~query: (Edn_util.vector_t_vec (Vec.of_array [| Edn_util.any Task_status.status_closed_values_query |])) let resolve_task_status invoke_config repo = function | None -> Cli_effect.pure (Ok None) | Some status_input -> let open Cli_effect in bind (status_query invoke_config repo) (fun result -> let values = Option.value (Edn_util.as_seq result) ~default:Vec.empty in let statuses = Task_status.normalize_available_statuses values in match Task_status.resolve_status_ident status_input statuses with | Some ident -> pure (Ok (Some ident)) | None -> pure (Error (Error.invalid_options (Task_status.invalid_status_message status_input statuses)))) let ensure_task_tag_id invoke_config repo = let open Cli_effect in bind (pull_entity_by_lookup invoke_config repo (vector_vec (Vec.of_array [| kw "db/id" |])) (vector_vec (Vec.of_array [| kw "db/ident"; kw "logseq.class/Task" |]))) (fun entity -> match id_of_entity entity with | Some id -> pure (Ok id) | None -> pure (Error (Error.make Error.Task_tag_not_found "task tag not found"))) let ensure_task_page invoke_config repo page = let open Cli_effect in bind (pull_pages_by_name invoke_config repo page task_selector) (fun result -> match first_entity result with | Some entity -> ( match (id_of_entity entity, uuid_of_entity entity) with | Some id, Some uuid -> pure (Ok (id, uuid)) | _ -> pure (Error (Error.make Error.Page_not_found "page not found after upsert"))) | None -> bind (create_page invoke_config repo page) (fun create_result -> bind (pull_created_page invoke_config repo page create_result) (fun entity -> match (id_of_entity entity, uuid_of_entity entity) with | Some id, Some uuid -> pure (Ok (id, uuid)) | _ -> pure (Error (Error.make Error.Page_not_found "page not found after upsert"))))) let execute_task_plan_on_uuids invoke_config repo block_uuids task_tag_id status_ident update_property_assignments clear_properties = let update_properties = match status_ident with | Some ident -> Vec.singleton (Edn_util.keyword_t "logseq.property/status", Edn_util.any ident) | None -> Vec.empty in let update_properties = Vec.append update_properties (Vec.filter_map (fun assignment -> match assignment.Property.key with | Property.Key_ident ident -> Some (ident, assignment.value) | _ -> None) update_property_assignments) in let remove_properties = Vec.filter_map (function Property.Key_ident ident -> Some ident | _ -> None) clear_properties in apply_resolved_update_plan invoke_config repo block_uuids (Vec.singleton task_tag_id, Vec.empty, update_properties, remove_properties) let execute_task_plan_on_uuid invoke_config repo block_uuid task_tag_id status_ident update_property_assignments clear_properties = execute_task_plan_on_uuids invoke_config repo (Vec.singleton block_uuid) task_tag_id status_ident update_property_assignments clear_properties let execute_task_page mode invoke_config repo page status_input update_properties clear_properties = let open Cli_effect in bind (resolve_task_status invoke_config repo status_input) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok status_ident -> bind (ensure_task_tag_id invoke_config repo) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok task_tag_id -> bind (ensure_task_page invoke_config repo page) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok (page_id, page_uuid) -> bind (execute_task_plan_on_uuid invoke_config repo page_uuid task_tag_id status_ident update_properties clear_properties) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok _ -> pure (ok_task_ids mode (Vec.singleton page_id)))))) let pull_task_by_uuid invoke_config repo uuid = pull_entity_by_lookup invoke_config repo task_selector (vector_vec (Vec.of_array [| kw "block/uuid"; Edn_util.uuid uuid |])) let execute_task_update mode invoke_config repo id uuid status_input update_properties clear_properties = let open Cli_effect in bind (resolve_task_status invoke_config repo status_input) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok status_ident -> bind (ensure_task_tag_id invoke_config repo) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok task_tag_id -> let pulled = match (id, uuid) with | Some id, _ -> pull_entity_by_id invoke_config repo task_selector id | None, Some uuid -> pull_task_by_uuid invoke_config repo uuid | None, None -> pure Edn_util.nil in bind pulled (fun entity -> match (id_of_entity entity, uuid_of_entity entity) with | Some node_id, Some node_uuid -> bind (execute_task_plan_on_uuid invoke_config repo node_uuid task_tag_id status_ident update_properties clear_properties) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok _ -> pure (ok_task_ids mode (Vec.singleton node_id))) | Some _, None -> pure (Cli_result.error ~command:Command_id.Upsert_task mode (Error.make Error.Upsert_id_not_found "task uuid not found")) | None, _ -> pure (Cli_result.error ~command:Command_id.Upsert_task mode (upsert_id_not_found "task" (Option.value id ~default:0L)))))) let page_result_with_plan ?(restore = false) mode invoke_config repo page_id page_uuid plan = let open Cli_effect in let restore_effect = if restore then restore_recycled_page invoke_config repo page_uuid else pure Edn_util.nil in bind restore_effect (fun _ -> bind (execute_page_plan invoke_config repo page_uuid plan) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_page mode err) | Ok _ -> pure (ok_page_ids mode (Vec.singleton page_id)))) let execute_create_page mode invoke_config repo name restore plan = let open Cli_effect in bind (pull_pages_by_name invoke_config repo name page_selector) (fun existing -> match first_entity existing with | Some page -> ( let recycled = recycled_entity page in if recycled && not restore then pure (Cli_result.error ~command:Command_id.Upsert_page mode (recycled_page_error ())) else match (id_of_entity page, uuid_of_entity page) with | Some id, Some uuid -> page_result_with_plan ~restore:recycled mode invoke_config repo id uuid plan | Some _, None when recycled -> pure (Cli_result.error ~command:Command_id.Upsert_page mode (recycled_page_error ())) | Some id, None -> pure (ok_page_ids mode (Vec.singleton id)) | _ -> pure (Cli_result.error ~command:Command_id.Upsert_page mode (page_not_found ()))) | None -> bind (create_page invoke_config repo name) (fun create_result -> bind (pull_created_page invoke_config repo name create_result) (fun page -> match (id_of_entity page, uuid_of_entity page) with | Some id, Some uuid -> page_result_with_plan mode invoke_config repo id uuid plan | Some id, None -> pure (ok_page_ids mode (Vec.singleton id)) | _ -> pure (Cli_result.error ~command:Command_id.Upsert_page mode (page_not_found ()))))) let execute_update_page mode invoke_config repo id restore plan = let open Cli_effect in bind (pull_entity_by_id invoke_config repo page_selector id) (fun entity -> match id_of_entity entity with | None -> pure (Cli_result.error ~command:Command_id.Upsert_page mode (upsert_id_not_found "page" id)) | Some id when not (page_entity entity) -> pure (Cli_result.error ~command:Command_id.Upsert_page mode (upsert_id_type_mismatch "Page" id)) | Some _ when recycled_entity entity && not restore -> pure (Cli_result.error ~command:Command_id.Upsert_page mode (recycled_page_error ())) | Some id -> ( let recycled = recycled_entity entity in match uuid_of_entity entity with | Some uuid -> page_result_with_plan ~restore:recycled mode invoke_config repo id uuid plan | None when recycled -> pure (Cli_result.error ~command:Command_id.Upsert_page mode (recycled_page_error ())) | None -> pure (ok_page_ids mode (Vec.singleton id)))) let update_plan_empty (plan : Property.update_plan) = Vec.is_empty plan.update_tags && Vec.is_empty plan.remove_tags && Vec.is_empty plan.update_properties && Vec.is_empty plan.remove_properties let result_ids_of_cli_result result = match Cli_result.data_value result with | Some value -> ( match Option.bind (Edn_util.get value "result") Edn_util.as_seq with | Some values -> let ids = Vec.filter_map Edn_util.as_int64 values in if Vec.length ids = Vec.length values then Some ids else None | _ -> None) | _ -> None let resolve_block_uuids_by_id invoke_config repo ids = let open Cli_effect in let rec loop acc remaining = match Vec.pop_front remaining with | None -> pure (Ok acc) | Some (id, rest) -> bind (pull_entity_by_id invoke_config repo (vector_vec (Vec.of_array [| kw "db/id"; kw "block/uuid" |])) id) (fun entity -> match uuid_of_entity entity with | None -> pure (Error (upsert_id_not_found "block" id)) | Some uuid -> loop (Vec.push_back acc uuid) rest) in loop Vec.empty ids let block_uuids_of_add_action action = Vec.filter_map (fun block -> block.Block.uuid) action.Add.blocks let execute_task_create mode config invoke_config repo target_page content status_input update_properties clear_properties = let open Cli_effect in bind (resolve_task_status invoke_config repo status_input) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok status_ident -> bind (ensure_task_tag_id invoke_config repo) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok task_tag_id -> ( let add_opts = { Add.target_id = None; target_uuid = None; target_page_name = Some target_page; pos = None; status = None; tags_edn = None; properties_edn = None; content = Some content; blocks_edn = None; blocks_file = None; } in match Add.build_add_block_action add_opts Vec.empty repo with | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok create_action -> bind (Add.execute_add_block create_action config mode) (fun result -> if Cli_result.is_error result then pure (Cli_result.with_command Command_id.Upsert_task result) else match result_ids_of_cli_result result with | None -> pure (Cli_result.error ~command:Command_id.Upsert_task mode (Error.make Error.Add_id_resolution_failed "unable to resolve created ids")) | Some ids -> let block_uuids = block_uuids_of_add_action create_action in let resolved_uuids = if Vec.is_empty block_uuids then resolve_block_uuids_by_id invoke_config repo ids else pure (Ok block_uuids) in bind resolved_uuids (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok block_uuids -> bind (execute_task_plan_on_uuids invoke_config repo block_uuids task_tag_id status_ident update_properties clear_properties) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok _ -> pure (ok_task_ids mode ids))))))) let execute_create_block mode (action : block_create) config = 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.Upsert_block mode err) | Ok invoke_config -> bind (resolve_blocks_inline_properties invoke_config action.repo action.blocks) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_block mode err) | Ok blocks -> let action = { action with blocks } in let resolved_plan_effect = if update_plan_empty action.update_plan then pure (Ok None) else map (function | Ok plan -> Ok (Some plan) | Error err -> Error err) (resolve_update_plan invoke_config action.repo action.update_plan) in bind resolved_plan_effect (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_block mode err) | Ok resolved_plan -> let add_action = add_action_of_block_create { action with blocks = Vec.map strip_block_properties action.blocks; } in bind (Add.execute_add_block add_action config mode) (fun result -> if Cli_result.is_error result then pure result else bind (apply_inline_property_ops invoke_config action.repo action.blocks) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_block mode err) | Ok _ -> ( match resolved_plan with | None -> pure result | Some resolved_plan -> ( match result_ids_of_cli_result result with | None -> pure (Cli_result.error ~command:Command_id.Upsert_block mode (Error.make Error.Add_id_resolution_failed "unable to resolve created ids")) | Some ids -> bind (resolve_block_uuids_by_id invoke_config action.repo ids) (function | Error err -> pure (Cli_result.error ~command: Command_id.Upsert_block mode err) | Ok block_uuids -> bind (apply_resolved_update_plan invoke_config action.repo block_uuids resolved_plan) (function | Error err -> pure (Cli_result.error ~command: Command_id .Upsert_block mode err) | Ok _ -> pure result))))))))) let execute_with_mode action config mode = let open Cli_effect in match action with | Upsert_block (Block_create action) -> execute_create_block mode action config | Upsert_block (Block_update action) -> map (Cli_result.with_command Command_id.Upsert_block) (Update.execute (update_action_of_block_update action) config mode) | Upsert_tag { repo; mode = Create; name = Some name; add_properties; remove_properties; _; } -> bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_tag mode err) | Ok invoke_config -> execute_create_tag mode invoke_config repo name ~add_properties ~remove_properties) | Upsert_tag { repo; mode = Update; id = Some id; name; add_properties; remove_properties; _; } -> bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_tag mode err) | Ok invoke_config -> execute_update_tag mode invoke_config repo id name ~add_properties ~remove_properties) | Upsert_tag _ -> pure (Cli_result.error ~command:Command_id.Upsert_tag mode (Error.make Error.Not_implemented "upsert tag is not implemented")) | Upsert_page { repo; mode = Create; page = Some page; restore; plan; _ } -> bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_page mode err) | Ok invoke_config -> execute_create_page mode invoke_config repo page restore plan) | Upsert_page { repo; mode = Update; id = Some id; restore; plan; _ } -> bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_page mode err) | Ok invoke_config -> execute_update_page mode invoke_config repo id restore plan) | Upsert_page _ -> pure (Cli_result.error ~command:Command_id.Upsert_page mode (Error.make Error.Not_implemented "upsert page is not implemented")) | Upsert_property { repo; mode = Create; name = Some name; schema; _ } -> bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_property mode err) | Ok invoke_config -> execute_create_property mode invoke_config repo name schema) | Upsert_property { repo; mode = Update; id = Some id; schema; _ } -> bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_property mode err) | Ok invoke_config -> execute_update_property mode invoke_config repo id schema) | Upsert_property _ -> pure (Cli_result.error ~command:Command_id.Upsert_property mode (Error.make Error.Not_implemented "upsert property is not implemented")) | Upsert_asset { repo; mode = Update; id; uuid; content; _ } -> bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode err) | Ok invoke_config -> execute_update_asset mode invoke_config repo id uuid content) | Upsert_asset { repo; mode = Create; path = Some path; create_action = Some create_action; _; } -> execute_create_asset mode config repo path create_action | Upsert_asset _ -> pure (Cli_result.error ~command:Command_id.Upsert_asset mode (Error.make Error.Not_implemented "upsert asset is not implemented")) | Upsert_task { repo; mode = Page; page = Some page; status_input; update_properties; clear_properties; _; } -> bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok invoke_config -> execute_task_page mode invoke_config repo page status_input update_properties clear_properties) | Upsert_task { repo; mode = Create; page = Some target_page; content = Some content; status_input; update_properties; clear_properties; _; } -> bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok invoke_config -> execute_task_create mode config invoke_config repo target_page content status_input update_properties clear_properties) | Upsert_task { repo; mode = Update; id; uuid; status_input; update_properties; clear_properties; _; } -> bind (Server_runtime.ensure_server config repo ~create_empty_db:false) (function | Error err -> pure (Cli_result.error ~command:Command_id.Upsert_task mode err) | Ok invoke_config -> execute_task_update mode invoke_config repo id uuid status_input update_properties clear_properties) | Upsert_task _ -> pure (Cli_result.error ~command:Command_id.Upsert_task mode (Error.make Error.Not_implemented "upsert task is not implemented")) 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 upsert block --graph my-graph --target-page Home \ --content \"New block\""; "logseq upsert block --graph my-graph --id 123 --content \ \"Updated content\""; "logseq upsert block --graph my-graph --id 123 --target-page \ Home"; "logseq upsert block --graph my-graph --target-page Meeting \ Notes --content \"AI summary of the discussion\" --update-tags \ '[\"AI-GENERATED\"]'"; "logseq upsert block --graph my-graph --blocks '[{:block/title \ \"A\"} {:block/title \"B\"}]'"; |]) Command_id.Upsert_block "Upsert block"; meta ~examples: (Vec.of_array [| "logseq upsert page --graph my-graph --page Home --update-tags \ '[\"project\"]'"; "logseq upsert page --graph my-graph --id 999 \ --update-properties '{:logseq.property/description \ \"Example\"}'"; |]) Upsert_page "Upsert page"; meta ~examples: (Vec.of_array [| "logseq upsert task --graph my-graph --content \"Ship release\" \ --target-page Home --status todo --priority high --scheduled \ \"2026-02-10T08:00:00.000Z\" --deadline \ \"2026-02-12T18:00:00.000Z\""; "logseq upsert task --graph my-graph --page Weekly Plan \ --status doing"; "logseq upsert task --graph my-graph --id 123 --no-status \ --no-priority"; |]) Upsert_task "Upsert task"; meta ~examples: (Vec.of_array [| "logseq upsert asset --graph my-graph --path ./assets/logo.png \ --target-page Home"; "logseq upsert asset --graph my-graph --id 123 --content \ \"Updated asset title\""; |]) Upsert_asset "Upsert asset"; meta ~examples: (Vec.of_array [| "logseq upsert tag --graph my-graph --name project"; "logseq upsert tag --graph my-graph --id 200 --name Project \ Renamed"; "logseq upsert tag --graph my-graph --name project \ --add-properties '[\"status\" \"owner\"]'"; |]) Upsert_tag "Upsert tag"; meta ~examples: (Vec.of_array [| "logseq upsert property --graph my-graph --name status --type \ default --cardinality one"; "logseq upsert property --graph my-graph --id 321 --hide true"; |]) Upsert_property "Upsert property"; |] let repo = function | Upsert_block (Block_create a) -> a.repo | Upsert_block (Block_update a) -> a.repo | Upsert_page { repo; _ } | Upsert_task { repo; _ } | Upsert_asset { repo; _ } | Upsert_tag { repo; _ } | Upsert_property { repo; _ } -> repo let graph = function | Upsert_block (Block_create a) -> a.graph | Upsert_block (Block_update a) -> a.graph | Upsert_page { graph; _ } | Upsert_task { graph; _ } | Upsert_asset { graph; _ } | Upsert_tag { graph; _ } | Upsert_property { graph; _ } -> graph let execute action config = let (Output.Mode.Packed mode) = Output_mode.for_config config in execute_with_mode action config mode