Something went wrong. Try again.
My own corner of monopam
Something went wrong. Try again.
12 kB · 343 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344(*--------------------------------------------------------------------------- Copyright (c) 2026 Thomas Gazagnaire. All rights reserved. SPDX-License-Identifier: ISC ---------------------------------------------------------------------------*)
(* Schema types *)
type column = { name : string; affinity : string; is_rowid_alias : bool; not_null : Sql.Ast.insert_conflict option; primary_key : Sql.Ast.insert_conflict option; collation : string option; generated : Sql.Ast.generated_kind option;}
type schema = { tbl_name : string; columns : column list; sql : string; parsed : Sql.Ast.create_table option; defaults : Sql.Ast.value array Lazy.t; names : string list Lazy.t; strict : (column * Sql.Strict.t option) list Lazy.t; real_cols : Bytes.t option Lazy.t; row_catalog : Sql.Query.catalog Lazy.t; generated : (string * Sql.Ast.expr) list Lazy.t; checks : (string * Sql.Ast.expr) list Lazy.t;}
let is_virtual (c : column) = c.generated = Some Sql.Ast.Virtual
module Kv_cache = struct type ready = { keys : (string, int64) Hashtbl.t; mutable dup : bool } type t = { mutable ready : ready option } type lookup = Unloaded | Missing | Rowid of int64
let unloaded () = { ready = None } let empty () = { ready = Some { keys = Hashtbl.create 64; dup = false } }
let lookup t key = match t.ready with | None -> Unloaded | Some r -> ( match Hashtbl.find_opt r.keys key with | None -> Missing | Some rowid -> Rowid rowid)
let stored t ~key ~rowid = match t.ready with | None -> () | Some r -> ( match Hashtbl.find_opt r.keys key with | Some held when held <> rowid -> r.dup <- true; if rowid > held then Hashtbl.replace r.keys key rowid | _ -> Hashtbl.replace r.keys key rowid)
let invalidate t = t.ready <- None
let dropped t ~key = match t.ready with | None -> () | Some r -> if r.dup then invalidate t else Hashtbl.remove r.keys keyend
type kv_table = { btree : Btree.Table.t; mutable cache : Kv_cache.t }
exception Not_null_violation of string
let fail_not_null_violation fmt = Fmt.kstr (fun s -> raise (Not_null_violation s)) fmt
exception Unique_violation of string
let fail_unique_violation fmt = Fmt.kstr (fun s -> raise (Unique_violation s)) fmt
exception Check_violation of string
let fail_check_violation fmt = Fmt.kstr (fun s -> raise (Check_violation s)) fmt
exception Foreign_key_violation of string
let fail_fk () = raise (Foreign_key_violation "FOREIGN KEY constraint failed")
exception Datatype_violation of string
let fail_datatype_violation fmt = Fmt.kstr (fun s -> raise (Datatype_violation s)) fmt
exception Unsupported_storage of string
let fail_unsupported_storage fmt = Fmt.kstr (fun s -> raise (Unsupported_storage s)) fmt
exception Busy of stringexception Not_a_database of stringexception Readonly_rollback of stringexception Readonly_dbmoved of string
type Eio.Exn.err += Is_a_directory
let () = Eio.Exn.register_pp (fun ppf -> function | Is_a_directory -> Fmt.string ppf "Is_a_directory"; true | _ -> false)
let fail_is_a_directory path = raise (Eio.Exn.add_context (Eio.Exn.create Is_a_directory) "opening %a" Eio.Path.pp path)
let fail_busy fmt = Fmt.kstr (fun s -> raise (Busy s)) fmt
let fail_readonly_rollback fmt = Fmt.kstr (fun s -> raise (Readonly_rollback s)) fmt
let fail_readonly_dbmoved fmt = Fmt.kstr (fun s -> raise (Readonly_dbmoved s)) fmt
type index_origin = | Created (** an explicit CREATE INDEX: "c" *) | Unique_constraint (** a UNIQUE constraint's autoindex: "u" *) | Primary_key (** a PRIMARY KEY's autoindex: "pk" *)
let origin_name = function | Created -> "c" | Unique_constraint -> "u" | Primary_key -> "pk"
type index_column = { cid : int; order : Catalog.Order.t; coll : string }
let xn_rowid = -1let xn_expr = -2
type index_key_source = Column of int | Expression of Sql.Ast.expr
let key_column_position = function Column i -> Some i | Expression _ -> Nonelet key_cid = function Column i -> i | Expression _ -> xn_expr
type index_decl = { name : string; unique : bool; origin : index_origin; partial : bool; key_columns : index_column list option; (** the key columns in key order, or [None] where a key names a collating sequence this build cannot resolve: the index is still the schema's, and still listed, but nothing true can be said about the order its entries sit in *) trailing_columns : index_column list option; (** what the record carries past its key, or [None] where unknown *)}
type index_key = { keys : index_key_source list; orders : Catalog.Order.t list; colls : string list; (** each key's collating sequence as the schema spells it, for the pragmas that print it *) origin : index_origin; on_conflict : Sql.Ast.insert_conflict;}
type stat = { rows : int; per_prefix : int list }
let string_of_stat s = String.concat " " (List.map string_of_int (s.rows :: s.per_prefix))
let stat_of_string str = let rec ints acc = function | [] -> List.rev acc | w :: rest -> ( match int_of_string_opt w with | Some n -> ints (n :: acc) rest | None -> List.rev acc) in match ints [] (String.split_on_char ' ' (String.trim str)) with | [] -> None | rows :: per_prefix -> Some { rows; per_prefix }
let stat_per_prefix ~rows ~distinct = let distinct = max 1 distinct in let v = (rows + distinct - 1) / distinct in (* a ratio only just above one is one, not two *) if v = 2 && rows * 10 <= distinct * 11 then 1 else v
type trailing = | Rowid_ref (** the rowid of the row in the table b-tree *) | Pk_ref of index_column list (** the PRIMARY KEY columns of a table whose rows are index-b-tree keys *)
let entry_orders ~orders = function | Rowid_ref -> orders @ [ Catalog.Order.default ] | Pk_ref cols -> orders @ List.map (fun (c : index_column) -> c.order) cols
type index = { keys : index_key_source list; (* what each key position reads, in key order *) orders : Catalog.Order.t list; (* one per key, positionally *) trailing : trailing; (* what its entries carry past the key to name the row. Part of the record the tree compares, so [entry_orders] reads it to build the order the tree is created with and reopened under. *) name : string; (* sqlite_master name, e.g. "sqlite_autoindex_t_1" *) tbl_name : string; (* owning table name *) unique : bool; (* enforce distinct keys *) origin : index_origin; (* what put it in the schema *) on_conflict : Sql.Ast.insert_conflict; (* the ON CONFLICT the constraint that built it declared, sqlite3's pIdx->onError; Unspecified for an explicit CREATE INDEX, which has no such clause, and for a constraint naming no action *) sql : string option; (* explicit CREATE INDEX text; None for autoindexes *) where : Sql.Ast.expr option; (* CREATE INDEX ... WHERE p: the rows it holds *) btree : Btree.Index.t; (* persistent B-tree index *) mutable stat : stat option; (* what the last ANALYZE measured; None until something has. Mutable because it is not part of the schema: no statement declares it, and the rows it describes go on moving underneath it. *)}
type pk_rows = { index : Btree.Index.t; layout : int array; key : (index_column list * int) option;}
type row_store = Rowid_rows of Btree.Table.t | Pk_index_rows of pk_rows
type unusable_index = { name : string; root_page : int; sql : Sql.Ast.value; (* stored CREATE INDEX text; Null for an autoindex *) reason : string;}
type generic_table = { store : row_store; schema : schema; indexes : index list; unusable : unusable_index list; explicit : string list; (** the names of the CREATE INDEX indexes, in the order the schema declares them. Reconnected and kept ones are otherwise in two lists, and PRAGMA index_list numbers them by that one order. *)}
type raw_master_entry = { type_ : string; name : string; tbl_name : string; root_page : int; sql : Sql.Ast.value;}
let rows_root = function | Rowid_rows b -> Btree.Table.root_page b | Pk_index_rows p -> Btree.Index.root_page p.index
let row_count store ~upto = match store with | Rowid_rows b -> Btree.Table.row_count b ~upto | Pk_index_rows p -> Btree.Index.fold_from p.index (Btree.Record.encode []) ~init:0 ~f:(fun n _ -> let n = n + 1 in if n >= upto then `Stop n else `Continue n)
(* The rows a rowid table holds, estimated off the leftmost path from its root to a leaf: the fan-out of each page on the path, multiplied down the levels, is the leaves, and the cells of the leaf it reaches are the rows of each. The root's fan-out is exact, its last child is taken to be half full, as the last of a run of appended pages is on average, and the levels below are taken to be filled as their first page is, which a table its rows were appended to is; the answer is exact up to the rows of that first leaf. Those are the pages a scan of the table reads first, so a scan that follows the plan reads them out of the cache, and the estimate costs a scan nothing. [None] for a table whose root is a leaf, which a count reads in one page, and for a store that is not a rowid b-tree. *)let estimate_rows pager store ~upto = match store with | Pk_index_rows _ -> None | Rowid_rows b -> let hdr p = if p = 1 then 100 else 0 in let page p = Btree.Pager.checked pager p ~hdr:(hdr p) in (* down the levels, at most twenty as a sound file has, multiplying the fan-outs on the way, in halves of a leaf: the root's last child counts one half *) let rec down depth halves p = let buf = page p and off = hdr p in let h = Btree.Page.Unchecked.header buf off in match Btree.Page.Unchecked.kind buf off with | Btree.Page.Leaf_table when depth > 0 -> Some (halves, h.Btree.Page.cell_count) | Btree.Page.Interior_table when depth <= 20 && h.cell_count > 0 -> let first = Btree.Page.u32_be buf (Btree.Page.cell_pointer buf off h 0) land 0xffff_ffff in let fanout = h.cell_count + 1 in let halves = if depth = 0 then (2 * fanout) - 1 else halves * fanout in down (depth + 1) (min (2 * upto) halves) first | _ -> None in Option.map (fun (halves, per_leaf) -> min upto (max 1 per_leaf * halves / 2)) (down 0 2 (Btree.Table.root_page b))
let unsupported_storage gt what = fail_unsupported_storage "%s %S: it is a WITHOUT ROWID table, whose rows are the keys of an index \ b-tree" what gt.schema.tbl_name
let rowid_stored gt = match gt.store with Rowid_rows _ -> true | Pk_index_rows _ -> false
let rowid_btree gt = match gt.store with | Rowid_rows b -> b | Pk_index_rows _ -> unsupported_storage gt "cannot address by rowid a row of"
let maintainable gt = match gt.unusable with | [] -> gt | (u : unusable_index) :: _ -> fail_unsupported_storage "cannot write %S: cannot maintain index %s: %s" gt.schema.tbl_name u.name u.reason
let pk_key gt (p : pk_rows) = match p.key with | Some k -> k | None -> fail_unsupported_storage "cannot modify %S: its PRIMARY KEY orders the rows by a collating \ sequence this build does not have" gt.schema.tbl_name