The following commit has been merged in the master branch: commit c558195600c4cb91793dc10dcdfe8f321b92482c Author: Sylvain Le Gall <gil...@debian.org> Date: Thu Aug 4 09:19:00 2011 +0000
Add debian/watch parser and a prototype for oasis-db diff --git a/.gitignore b/.gitignore index d928205..976b27d 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,5 @@ _build setup.data setup.log test.byte +proto_oasis.native +tmp diff --git a/_oasis b/_oasis index f461aa0..433111b 100644 --- a/_oasis +++ b/_oasis @@ -5,6 +5,7 @@ Synopsis: Parse debian files Authors: Sylvain Le Gall License: LGPL-2.1 with OCaml linking exception Plugins: DevFiles (0.2), META (0.2), StdFiles (0.2) +BuildTools: ocamlbuild Library "debian-formats" Path: src @@ -14,12 +15,19 @@ Library "debian-formats" DF822_parser, DF822, DFUtils, - DFChangelog + DFChangelog, + DFWatch BuildDepends: extlib, str, mikmatch_pcre +Document "api-debian-formats" + Title: API reference for DebianFormats + InstallDir: $htmldir/debian-formats + XOCamlbuildPath: src/ + XOCamlbuildLibraries: debian-formats + BuildTools+: ocamldoc + Executable test Path: test - BuildTools: ocamlbuild MainIs: test.ml Install: false BuildDepends: debian-formats, oUnit @@ -29,3 +37,20 @@ Test main TestTools: test WorkingDirectory: test/data +Flag "examples" + Description: Build and test examples + Default: false + +Executable "proto_oasis" + Path: examples/proto_oasis + MainIs: proto_oasis.ml + BuildDepends: debian-formats, curl, pcre, fileutils, archive.lwt, oasis, bz2, lwt.preemptive, threads + Install: false + Build$: flag(examples) + CompiledObject: best + +Test "proto_oasis" + Command: $proto_oasis + TestTools: proto_oasis +# Run$: flag(examples) + Run: false diff --git a/_tags b/_tags index 5d64689..6d0c1a0 100644 --- a/_tags +++ b/_tags @@ -19,3 +19,4 @@ # OASIS_STOP "src/DFChangelog.ml": syntax_camlp4o +"src/DFWatch.ml": syntax_camlp4o diff --git a/examples/proto_oasis/proto_oasis.ml b/examples/proto_oasis/proto_oasis.ml new file mode 100644 index 0000000..0539fce --- /dev/null +++ b/examples/proto_oasis/proto_oasis.ml @@ -0,0 +1,493 @@ + +open Curl +open Lwt + +let with_fn_out fn f = + let chn = open_out fn in + try + let res = f chn in + close_out chn; + res + with e -> + close_out chn; + raise e + +let with_fn_in fn f = + let chn = open_in fn in + try + let res = f chn in + close_in chn; + res + with e -> + close_in chn; + raise e + +let with_curl f = + let c = Curl.init () in + try + let res = f c in + Curl.cleanup c; + res + with e -> + Curl.cleanup c; + raise e + + +module ODBMessage = +struct + let info ~ctxt fmt = + Printf.ksprintf + (fun str -> return (prerr_endline ("I: "^str))) + fmt + + let debug ~ctxt fmt = + Printf.ksprintf + (fun str -> return (prerr_endline ("D: "^str))) + fmt + + let warning ~ctxt fmt = + Printf.ksprintf + (fun str -> return (prerr_endline ("W: "^str))) + fmt +end + +module S = +struct + let use sqle f = + f () + + let execute () fmt = + Printf.ksprintf + (fun str -> + Printf.eprintf "SQL: %s\n" str; + return ()) + fmt + + let transaction () f = + f () +end + +module ODBOASIS = +struct + + let from_string ~ctxt ?fn str = + let ctxt = + {!OASISContext.default with + OASISContext. + ignore_plugins = true; + ignore_unknown_fields = true} + in + OASISParse.from_string ~ctxt ?fn str +end + +module Context = +struct + type t = + { + sqle : unit; + } + + let default = + { + sqle = (); + } +end + +module ODBCurl = +struct + let download_if_new url fn = + + let fn_etag = fn^".etag" in + + let cur_etag = + if Sys.file_exists fn then + begin + try + let chn = + open_in fn_etag + in + let res = + String.make (in_channel_length chn) '\000' + in + really_input chn res 0 (String.length res); + close_in chn; + Some res + with _ -> + None + end + else + None + in + + let etag_regex = + ignore "(*"; + Pcre.regexp "ETag: \"(.*)\"" + in + + let write_fun chn str = + output_string chn str; + String.length str + in + + let header_fun str = + let () = + try + let substr = + Pcre.exec ~rex:etag_regex str + in + let etag = + Pcre.get_substring substr 1 + in + with_fn_out fn_etag + (fun chn -> + output_string chn etag) + + with Not_found -> + () + in + String.length str + in + + let fn_tmp = + fn^".tmp" + in + catch + (fun () -> + with_fn_out fn_tmp + (fun chn -> + with_curl + (fun c -> + Curl.set_url c url; + Curl.set_followlocation c true; + begin + match cur_etag with + | Some etag -> + Curl.set_httpheader c + [Printf.sprintf + "If-None-Match: \"%s\"" + etag] + | None -> + () + end; + Curl.set_headerfunction c header_fun; + Curl.set_writefunction c (write_fun chn); + Curl.perform c; + match Curl.get_httpcode c with + | 200 -> + return true + | 304 -> + return false + | n -> + fail + (Failure + (Printf.sprintf "Unexpected HTTP code %d" n)))) + >|= fun is_new -> + begin + if is_new then + begin + (* TODO: lwt version of this *) + FileUtil.rm [fn]; + FileUtil.mv fn_tmp fn; + end + else + begin + FileUtil.rm [fn_tmp] + end; + is_new + end) + + (fun e -> + FileUtil.rm [fn; fn_tmp; fn_etag]; + fail e) +end + +open ExtLib +open DebianFormats + +type uri = string +type filename = string + +type t = + { + deb_force: bool; + deb_mirror: uri; + deb_dist: string; + deb_distro: string; + deb_tmpdir: filename; + } + +module SetString = Set.Make(String) + +let download_uri ~ctxt uri fn = + ODBMessage.info ~ctxt "Start downloading '%s'" uri + >>= fun () -> + ODBCurl.download_if_new uri fn + >>= fun res -> + ODBMessage.info ~ctxt "End downloading '%s'" uri + >|= fun () -> + res + +let download_uri_exists ~ctxt uri fn = + if Sys.file_exists fn then + return () + else + begin + download_uri ~ctxt uri fn + >>= fun (is_new : bool) -> + return () + end + +let find_fn bn fn = + ArchiveLwt.Read.create (`Filename fn) + >>= fun arch -> + begin + let rec find lst = + try + List.find + (fun fn -> + not (ArchiveLwt.Read.is_directory arch fn) && + FilePath.basename fn = bn) + lst + with + | Not_found when lst <> [] -> + let lst = + List.fold_left + (fun acc fn -> + if ArchiveLwt.Read.is_directory arch fn then + begin + let lst' = + List.rev_map + (FilePath.concat fn) + (Array.to_list (ArchiveLwt.Read.readdir arch fn)) + in + List.rev_append lst' acc + end + else + acc) + [] + lst + in + find lst + | e -> + raise e + in + try + begin + let fn = + find (Array.to_list (ArchiveLwt.Read.readdir arch "")) + in + ArchiveLwt.Read.content arch fn + >|= fun ctnt -> + Some ctnt + end + + with Not_found -> + begin + return None + end + end + +(* Update available package list *) +let update_packages ~ctxt t pkg_lst = + Lwt_list.fold_left_s + (fun acc e -> + try + let fn, _, _ = + Source.filename e `Tarball + in + let uri = URI.pool t.deb_mirror e fn in + let tarball_fn = + FilePath.make_filename + [t.deb_tmpdir; + "pool"; + FilePath.add_extension + (e.Source.name ^"-"^ (Version.upstream e.Source.version) ^ ".tar") + (FilePath.get_extension fn)] + in + download_uri_exists ~ctxt uri tarball_fn + >>= fun () -> + find_fn "_oasis" tarball_fn + >|= + function + | Some oasis_ctnt -> + let oasis = + ODBOASIS.from_string ~ctxt oasis_ctnt + in + (`Sure (oasis, e)) :: acc + | None -> + (`Unsure e) :: acc + + with Not_found -> + ODBMessage.warning ~ctxt + "No tarball found for %s" + e.Source.name + >|= fun () -> + acc) + [] + pkg_lst + >>= fun inject_pkg -> + (* TODO: fix unsure packages when they have already been dealt with *) + S.use ctxt.Context.sqle + (fun db -> + S.transaction db + (fun () -> + S.execute db + "DELETE FROM distro_pkg WHERE distro = %s" t.deb_distro + >>= fun () -> + S.execute db + "DELETE FROM distro_pkg_unsure WHERE distro = %s" t.deb_distro + >>= fun () -> + Lwt_list.iter_s + (function + | `Sure (oasis, e) -> + Lwt_list.iter_s + (fun (bin, _) -> + S.execute db + "INSERT INTO distro_pkg(distro, distro_src, distro_bin, pkg, ver) \ + VALUES (%s, %s, %s, %s, %s)" + t.deb_distro + e.Source.name + bin + (oasis.OASISTypes.name) + (OASISVersion.string_of_version + oasis.OASISTypes.version)) + e.Source.binary + | `Unsure e -> + Lwt_list.iter_s + (fun (bin, _) -> + S.execute db + "INSERT INTO distro_pkg_unsure(distro, distro_src, distro_bin, ver) \ + VALUES (%s, %s, %s, %s)" + t.deb_distro + e.Source.name + bin + (Version.upstream e.Source.version)) + e.Source.binary) + inject_pkg)) + +(** Update watch files *) +let update_watches ~ctxt t pkg_lst = + Lwt_list.iter_s + (fun e -> + try + let fn, _, _ = + Source.filename e `Diff + in + if String.ends_with fn ".debian.tar.gz" then + begin + let uri = URI.pool t.deb_mirror e fn in + let diff_fn = + FilePath.make_filename + [t.deb_tmpdir; + "pool"; + e.Source.name ^"-"^ (Version.noepoch e.Source.version) ^ ".debian.tar.gz"] + in + download_uri_exists ~ctxt uri diff_fn + >>= fun () -> + find_fn "watch" diff_fn + >|= + function + | Some watch_ctnt -> + (* TODO: inject *) + prerr_endline watch_ctnt + | None -> + () + end + else + return () + + with Not_found -> + ODBMessage.debug ~ctxt "No diff found for %s" e.Source.name) + pkg_lst + +let update ~ctxt t = + let fn = + Filename.concat t.deb_tmpdir (t.deb_distro^"-sources") + in + let fn_bz2 = + fn^".bz2" + in + + download_uri ~ctxt (URI.sources t.deb_mirror t.deb_dist `Main) fn_bz2 + >>= fun is_new -> + (* TODO: build a list of extra packages *) + return SetString.empty + >>= fun extra_set -> + (* TODO: build a package of ignored packages *) + return SetString.empty + >>= fun ignore_set -> + begin + if is_new || t.deb_force then + begin + ODBMessage.info ~ctxt "File '%s' is new" fn_bz2 + >>= fun () -> + (* Decompress Source.bz2 *) + Lwt_preemptive.detach + (fun () -> + with_fn_in fn_bz2 + (fun chn_bz2 -> + with_fn_out fn + (fun chn_out -> + let chn_bz2' = Bz2.open_in chn_bz2 in + try + let len = 4096 in + let buf = String.make len '\000' in + let read () = Bz2.read chn_bz2' buf 0 len in + let byte_read = ref (read ()) in + while !byte_read = len do + output_string chn_out buf; + byte_read := read () + done; + output chn_out buf 0 !byte_read; + Bz2.close_in chn_bz2' + with e -> + Bz2.close_in chn_bz2'; + raise e))) + () + >>= fun () -> + (* Extract ocaml packages from Sources *) + Lwt_preemptive.detach + (fun () -> + with_fn_in + fn + (fun chn -> + let rlst = + ref [] + in + let _i: unit list = + Source.parse + (fun e -> + if (e.Source.section = "ocaml" || + SetString.mem e.Source.name extra_set) && + not (SetString.mem e.Source.name ignore_set) then + rlst := e :: !rlst) + (IO.input_channel chn) + in + !rlst)) + () + >>= fun lst -> + update_packages ~ctxt t lst + >>= fun () -> + update_watches ~ctxt t lst + end + else + ODBMessage.info ~ctxt "File '%s' has not changed" fn_bz2 + end + +let () = + let () = + Curl.global_init CURLINIT_GLOBALNOTHING + in + + let default = + { + deb_force = true; + deb_mirror = "http://ftp.debian.org/debian"; + deb_dist = "unstable"; + deb_distro = "debian-unstable"; + deb_tmpdir = "tmp/"; + } + in + Lwt_main.run + (update ~ctxt:Context.default default); + Curl.global_cleanup () diff --git a/src/DFWatch.ml b/src/DFWatch.ml new file mode 100644 index 0000000..850089f --- /dev/null +++ b/src/DFWatch.ml @@ -0,0 +1,37 @@ + +open DFUtils +open ExtLib + +let parse ch = + let rec parse () = + try + match IO.read_line ch with + | RE bol space* "#" -> + parse () + | RE bol space* "$" -> + parse () + | RE bol space* (_* as str) -> + begin + let rec cont_line str = + if String.ends_with str "\\" then + begin + (String.rchop str) ^ + (try + cont_line (IO.read_line ch) + with IO.No_more_input -> + "") + end + else + str + in + let full_line = + cont_line str + in + full_line :: parse () + end + | _ -> + assert false + with IO.No_more_input -> + [] + in + parse () diff --git a/src/DebianFormats.ml b/src/DebianFormats.ml index 547f70c..fe0e9cf 100644 --- a/src/DebianFormats.ml +++ b/src/DebianFormats.ml @@ -19,6 +19,11 @@ type version = string type vpkg = (string * (string * string) option) type veqpkg = (string * (string * string) option) type architecture = string +type md5sum = Digest.t +type sha1 = string +type sha256 = string +type file_size = int64 +type filename = string (**/**) let default dflt f1 f2 fld = @@ -29,6 +34,26 @@ let default dflt f1 f2 fld = (**/**) +module Version = +struct + + let noepoch ver = + try + snd (String.split ver ":") + with Invalid_string -> + ver + + let upstream ver = + try + fst (String.split (noepoch ver) "-") + with Invalid_string -> + ver + + let is_native ver = + String.contains ver '-' + +end + module Release = struct type t = @@ -42,9 +67,9 @@ struct architecture: string; component : string; description: string; - md5sums: (string * string * string) list; - sha1: (string * string * string) list; - sha256: (string * string * string) list + md5sums: (md5sum * file_size * string) list; + sha1: (sha1 * file_size * string) list; + sha256: (sha256 * file_size * string) list; } let parse ch = @@ -80,22 +105,40 @@ struct type t = { name : name; - version : version; - binary : vpkg list; - build_depends : (vpkg * (bool * architecture) list) list list; - build_depends_indep : (vpkg * (bool * architecture) list) list list; - build_conflicts : (vpkg * (bool * architecture) list) list; + version : version; + binary : vpkg list; + build_depends : (vpkg * (bool * architecture) list) list list; + build_depends_indep : (vpkg * (bool * architecture) list) list list; + build_conflicts : (vpkg * (bool * architecture) list) list; build_conflicts_indep : (vpkg * (bool * architecture) list) list; - architecture : architecture list + architecture : architecture list; + md5sums: (md5sum * file_size * filename) list; + sha1: (sha1 * file_size * filename) list; + sha256: (sha256 * file_size * filename) list; + directory: filename; + section: string; } let parse_name = parse_package - let parse_arch s = Str.split (Str.regexp " ") s + let parse_arch s = List.filter (( <> ) "") (String.nsplit s " ") let parse_version s = parse_version s let parse_binary s = parse_vpkglist parse_constr s let parse_cnf s = parse_vpkgformula parse_builddeps s let parse_conj s = parse_vpkglist parse_builddeps s + let parse_cksum lst = + List.fold_left + (fun acc line -> + match List.filter ((<>) "") (String.nsplit line " ") with + | cksum :: sz :: tl -> + (cksum, Int64.of_string sz, (String.concat " " tl)) + :: acc + | _ -> + acc) + [] + (List.rev lst) + + (* Relationships between source and binary packages * http://www.debian.org/doc/debian-policy/ch-relationships.html * Build-Depends, Build-Depends-Indep, Build-Conflicts, Build-Conflicts-Indep @@ -103,6 +146,7 @@ struct let parse_sources_fields par = let parse_s f field = f (single_line field (List.assoc field par)) in let parse_m f field = f (String.concat " " (List.assoc field par)) in + let parse_l f field = f (List.assoc field par) in let exec () = { name = parse_s parse_name "package"; @@ -113,6 +157,11 @@ struct build_depends_indep = default [] parse_m parse_cnf "build-depends-indep"; build_conflicts = default [] parse_m parse_conj "build-conflicts"; build_conflicts_indep = default [] parse_m parse_conj "build-conflicts-indep"; + md5sums = default [] parse_l parse_cksum "files"; + sha1 = default [] parse_l parse_cksum "checksums-sha1"; + sha256 = default [] parse_l parse_cksum "checksums-sha256"; + directory = parse_s String.strip "directory"; + section = parse_s String.strip "section"; } in try @@ -121,13 +170,56 @@ struct None (* this package doesn't either have version, arch or name *) (** parse a debian Sources file from channel *) - let parse ch = + let parse f ch = let parse_packages = parse_822_iter parse_sources_fields in parse_packages - (fun i -> i) + f (start_from_channel ch) + + let filename t ft = + let test = + match ft with + | `Dsc -> + fun s -> + String.ends_with s ".dsc" + + | `Tarball -> + fun s -> + (not + (String.ends_with s ".debian.tar.gz" || + String.ends_with s ".debian.tar.bz2")) + && + (String.ends_with s ".tar.gz" || + String.ends_with s ".tar.bz2") + + | `Diff -> + fun s -> + String.ends_with s ".diff.gz" || + String.ends_with s ".debian.tar.gz" || + String.ends_with s ".debian.tar.bz2" + + | `Other fn -> + ( = ) fn + in + let md5sum, sz, fn = + List.find (fun (_, _, fn) -> test fn) t.md5sums + in + let find acc f fld = + try + let digest, _, _ = + List.find (fun (_, _, fn') -> fn = fn') fld + in + (f digest) :: acc + with Not_found -> + acc + in + let digests = [`MD5Sum md5sum] in + let digests = find digests (fun d -> `Sha1 d) t.sha1 in + let digests = find digests (fun d -> `Sha256 d) t.sha256 in + fn, sz, digests + end module Binary = @@ -364,3 +456,60 @@ end module Changelog = DFChangelog +module Watch = DFWatch + +module URI = +struct + type uri = string + type mirror = uri + type dist = string + type section = [`Main | `Contrib | `NonFree] + + (**/**) + let concat uri1 uri2 = + match String.ends_with uri1 "/", String.starts_with uri2 "/" with + | true, true -> + uri1 ^ (String.lchop uri2) + | false, true + | true, false -> + uri1 ^ uri2 + | false, false -> + uri1 ^ "/" ^ uri2 + + let rec concat_lst = + function + | uri1 :: uri2 :: tl -> + concat_lst ((concat uri1 uri2) :: tl) + | [uri] -> + uri + | [] -> + "" + + let string_of_section = + function + | `Main -> "main" + | `Contrib -> "contrib" + | `NonFree -> "non-free" + (**/**) + + + let sources mirror dist section = + concat_lst + [ + mirror; + "dists"; + dist; + string_of_section section; + "source/Sources.bz2" + ] + + let pool mirror src fn = + concat_lst + [ + mirror; + src.Source.directory; + fn; + ] + + +end diff --git a/test/data/watch.oasis b/test/data/watch.oasis new file mode 100644 index 0000000..5943512 --- /dev/null +++ b/test/data/watch.oasis @@ -0,0 +1,5 @@ +version=3 +http://forge.ocamlcore.org/frs/?group_id=54 .*/oasis-(\d.*)\.tar\.gz +# Upstream darcs repository: +# http://forge.ocamlcore.org/anonscm/darcs/oasis/oasis +# http://forge.ocamlcore.org/scm/browser.php?group_id=54&repo_name=oasis diff --git a/test/data/watch.obus b/test/data/watch.obus new file mode 100644 index 0000000..a1a952c --- /dev/null +++ b/test/data/watch.obus @@ -0,0 +1,6 @@ +version=3 +opts="uversionmangle=s/rc/~rc/" \ +http://forge.ocamlcore.org/frs/?group_id=26 .*/obus-(.*)\.tar\.gz +# Upstream darcs repository: +# http://darcs.ocamlcore.org/repos/obus +# http://darcs.ocamlcore.org/cgi-bin/darcsweb.cgi?r=obus diff --git a/test/test.ml b/test/test.ml index a7b4228..4708284 100644 --- a/test/test.ml +++ b/test/test.ml @@ -50,6 +50,22 @@ let tests = "0.0.3-1" e.Changelog.version); ]); + + "Watch">::: + (List.map + (fun (fn, f) -> + fn >:: + with_fn fn + (fun ch -> + f (Watch.parse ch))) + [ + "watch.oasis", + (fun lst -> + List.iter prerr_endline lst); + "watch.obus", + (fun lst -> + List.iter prerr_endline lst); + ]); ] -- ocaml-debian-formats packaging _______________________________________________ Pkg-ocaml-maint-commits mailing list Pkg-ocaml-maint-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-ocaml-maint-commits