let mk_origin () =
let projectb = new Postgresql.connection ~conninfo:"service=projectb" () in
let mk_wrapper_maps transform sql =
let r = projectb#exec sql in
assert (r#status = Postgresql.Tuples_ok);
Array.fold_left (fun (a, b) row ->
match row with
| [| key_id; key |] ->
let key = transform key
and key_id = int_of_string key_id in (
IntMap.add key_id key a,
StringMap.add key key_id b
)
| _ -> assert false
) (IntMap.empty, StringMap.empty) r#get_all
in
let string_identity x = x in
let mk_wrappers name (key_of_id_map, id_of_key_map) =
((fun x ->
try IntMap.find x key_of_id_map
with Not_found -> ksprintf invalid_arg "%s_of_id(%d)" name x),
(fun x ->
try StringMap.find x id_of_key_map
with Not_found -> ksprintf invalid_arg "id_of_%s(%s)" name x))
in
let key_of_id, id_of_key = mk_wrappers "key"
(mk_wrapper_maps String.lowercase "select key_id, key from metadata_keys")
in
let suite_of_id, id_of_suite = mk_wrappers "suite"
(mk_wrapper_maps string_identity "select id, suite_name from suite")
in
let arch_of_id, id_of_arch = mk_wrappers "arch"
(mk_wrapper_maps string_identity "select id, arch_string from architecture")
in
let relevant_binary_key_ids = List.map id_of_key relevant_binary_keys in
let get_binaries accu arch =
Benl_clflags.progress "Querying projectb for %s binaries in unstable..." arch;
let sql = sprintf
"select b.bin_id, b.key_id, b.value from bin_associations as a join (select * from binaries_metadata where key_id in (%s)) as b on b.bin_id = a.bin join (select * from binaries) as c on c.id = a.bin where a.suite = %d and c.architecture in (%d,%d)"
(String.concat "," (List.map string_of_int relevant_binary_key_ids))
(id_of_suite "unstable") (id_of_arch "all") (id_of_arch arch)
in
let r = projectb#exec sql in
assert (r#status = Postgresql.Tuples_ok);
let id_indexed_map = Array.fold_left (fun a row ->
match row with
| [| src_id; key_id; value |] ->
let src_id = int_of_string src_id
and key_id = int_of_string key_id in
let old = try IntMap.find src_id a with Not_found -> [] in
IntMap.add src_id ((key_of_id key_id, value)::old) a
| _ -> assert false
) IntMap.empty r#get_all in
let result = IntMap.fold (fun _ assoc accu ->
let pkg = Package.of_assoc `binary assoc in
let name = Package.Name.of_string (Package.get "package" pkg) in
let ver = Package.get "version" pkg in
try
let old_pkg = PAMap.find (name, arch) accu in
let old_ver = Package.get "version" old_pkg in
if Benl_base.Version.compare old_ver ver < 0
then PAMap.add (name, arch) pkg accu
else accu
with Not_found ->
PAMap.add (name, arch) pkg accu
) id_indexed_map accu in
Benl_clflags.progress "\n";
result
in
let sources_in_testing =
Benl_clflags.progress "Querying projectb for sources in testing...";
let sql = sprintf
"select (select value from source_metadata as b where key_id = %d and b.src_id = a.source) from src_associations as a where a.suite = %d"
(id_of_key "source") (id_of_suite "testing")
in
let r = projectb#exec sql in
assert (r#status = Postgresql.Tuples_ok);
let result = Array.fold_left (fun a row ->
match row with
| [| source |] -> StringSet.add source a
| _ -> assert false
) StringSet.empty r#get_all in
Benl_clflags.progress "\n";
result
in
let relevant_source_key_ids =
List.map id_of_key
(List.filter (fun x -> x <> "directory") relevant_source_keys)
in
let get_sources accu =
Benl_clflags.progress "Querying projectb for sources in unstable...";
let sql = sprintf
"select b.src_id, b.key_id, b.value from src_associations as a join (select * from source_metadata where key_id in (%s)) as b on b.src_id = a.source where a.suite = %d"
(String.concat "," (List.map string_of_int relevant_source_key_ids))
(id_of_suite "unstable")
in
let r = projectb#exec sql in
assert (r#status = Postgresql.Tuples_ok);
let id_indexed_map = Array.fold_left (fun a row ->
match row with
| [| src_id; key_id; value |] ->
let src_id = int_of_string src_id
and key_id = int_of_string key_id in
let old = try IntMap.find src_id a with Not_found -> [] in
let key = key_of_id key_id in
let key = if key = "source" then "package" else key in
IntMap.add src_id ((key, value)::old) a
| _ -> assert false
) IntMap.empty r#get_all in
let sql = sprintf
"select a.source, c.filename from src_associations as a join (select * from dsc_files) as b on b.source = a.source, files as c where a.suite = %d and b.file = c.id and c.filename like '%%dsc'"
(id_of_suite "unstable")
in
let r = projectb#exec sql in
assert (r#status = Postgresql.Tuples_ok);
let id_indexed_dscs = Array.fold_left (fun a row ->
match row with
| [| src_id; filename |] ->
let src_id = int_of_string src_id in
IntMap.add src_id filename a
| _ -> assert false
) IntMap.empty r#get_all in
let id_indexed_map = IntMap.mapi (fun src_id pkg ->
let directory = Filename.concat "pool"
(Filename.dirname (IntMap.find src_id id_indexed_dscs))
in
("directory", directory) :: pkg
) id_indexed_map in
let result = IntMap.fold (fun _ assoc accu ->
let pkg = Package.of_assoc `source assoc in
let sname = Package.get "package" pkg in
let is_in_testing =
if StringSet.mem sname sources_in_testing
then "yes" else "no"
in
let pkg = Package.add "is-in-testing" is_in_testing pkg in
let name = Package.Name.of_string sname in
let ver = Package.get "version" pkg in
try
let old_pkg = M.find name accu in
let old_ver = Package.get "version" old_pkg in
if Benl_base.Version.compare old_ver ver < 0
then M.add name pkg accu
else accu
with Not_found ->
M.add name pkg accu
) id_indexed_map accu in
Benl_clflags.progress "\n";
result
in
{ get_binaries = get_binaries; get_sources = get_sources }