diff -Nru zeroinstall-injector-2.6.1/debian/changelog zeroinstall-injector-2.7/debian/changelog --- zeroinstall-injector-2.6.1/debian/changelog 2014-02-08 14:10:32.000000000 +0000 +++ zeroinstall-injector-2.7/debian/changelog 2014-05-27 12:59:12.000000000 +0000 @@ -1,3 +1,9 @@ +zeroinstall-injector (2.7-1) unstable; urgency=medium + + * New upstream release. + + -- Thomas Leonard Tue, 27 May 2014 10:53:31 +0000 + zeroinstall-injector (2.6.1-1) unstable; urgency=medium * New upstream release. The Python dependency is now gone. diff -Nru zeroinstall-injector-2.6.1/debian/control zeroinstall-injector-2.7/debian/control --- zeroinstall-injector-2.6.1/debian/control 2014-02-08 14:10:32.000000000 +0000 +++ zeroinstall-injector-2.7/debian/control 2014-05-27 12:59:12.000000000 +0000 @@ -2,7 +2,7 @@ Section: admin Priority: extra Maintainer: Thomas Leonard -Build-Depends: debhelper (>= 9), ocaml-nox, dh-ocaml, ocaml-findlib, libyojson-ocaml-dev, libxmlm-ocaml-dev, camlp4-extra, gettext, liblwt-ocaml-dev, libounit-ocaml-dev, libextlib-ocaml-dev, libcurl-ocaml-dev, libssl-ocaml-dev, libobus-ocaml-dev, liblablgtk2-ocaml-dev, liblwt-glib-ocaml-dev, unzip, python-gobject +Build-Depends: debhelper (>= 9), ocaml-nox, dh-ocaml, ocaml-findlib, libyojson-ocaml-dev, libxmlm-ocaml-dev, camlp4-extra, gettext, liblwt-ocaml-dev, libounit-ocaml-dev, libextlib-ocaml-dev, libcurl-ocaml-dev, libssl-ocaml-dev, libobus-ocaml-dev, liblablgtk2-ocaml-dev, liblwt-glib-ocaml-dev, unzip Standards-Version: 3.9.5 Homepage: http://0install.net/ Vcs-Browser: https://github.com/0install/0install-debian @@ -26,8 +26,8 @@ Package: 0install-core Architecture: any -Depends: ${misc:Depends}, gnupg, bzip2, binutils, adduser, xdg-utils, ${shlibs:Depends} -Recommends: unzip, lzma, packagekit | python3-aptdaemon.pkcompat, ca-certificates +Depends: ${misc:Depends}, gnupg, bzip2, binutils, adduser, xdg-utils, ca-certificates, ${shlibs:Depends} +Recommends: unzip, lzma, packagekit | python3-aptdaemon.pkcompat Suggests: cabextract, rpm2cpio, 0install Provides: zeroinstall-injector Replaces: zeroinstall-injector (<< 2.3.3-2) diff -Nru zeroinstall-injector-2.6.1/debian/copyright zeroinstall-injector-2.7/debian/copyright --- zeroinstall-injector-2.6.1/debian/copyright 2014-02-08 14:10:32.000000000 +0000 +++ zeroinstall-injector-2.7/debian/copyright 2014-05-27 12:59:12.000000000 +0000 @@ -28,4 +28,4 @@ The Debian packaging is (C) Copyright 2014, Thomas Leonard -and is licensed under the GPL, see `/usr/share/common-licenses/GPL-2'. +and is also licensed under the LGPL 2.1 or later. diff -Nru zeroinstall-injector-2.6.1/debian/rules zeroinstall-injector-2.7/debian/rules --- zeroinstall-injector-2.6.1/debian/rules 2014-02-08 14:10:32.000000000 +0000 +++ zeroinstall-injector-2.7/debian/rules 2014-05-27 12:59:12.000000000 +0000 @@ -30,6 +30,8 @@ $(CURDIR)/dist/install.sh $(CURDIR)/debian/0install-core/usr mkdir -p $(CURDIR)/debian/0install/usr/lib/0install.net mv $(CURDIR)/debian/0install-core/usr/lib/0install.net/gui_gtk.* $(CURDIR)/debian/0install/usr/lib/0install.net/ + rmdir $(CURDIR)/debian/0install-core/usr/lib/0install.net + rmdir $(CURDIR)/debian/0install-core/usr/lib mv $(CURDIR)/debian/0install-core/usr/share/zsh/site-functions $(CURDIR)/debian/0install-core/usr/share/zsh/vendor-completions rm -r $(CURDIR)/debian/0install-core/usr/share/doc/0install if [ -x /usr/bin/ocamlopt ]; then \ diff -Nru zeroinstall-injector-2.6.1/debian/source/include-binaries zeroinstall-injector-2.7/debian/source/include-binaries --- zeroinstall-injector-2.6.1/debian/source/include-binaries 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/debian/source/include-binaries 2014-05-27 12:59:12.000000000 +0000 @@ -0,0 +1 @@ +debian/upstream/signing-key.pgp Binary files /tmp/ZG7s6fjvkl/zeroinstall-injector-2.6.1/debian/upstream/signing-key.pgp and /tmp/1Da6taMpqA/zeroinstall-injector-2.7/debian/upstream/signing-key.pgp differ diff -Nru zeroinstall-injector-2.6.1/debian/watch zeroinstall-injector-2.7/debian/watch --- zeroinstall-injector-2.6.1/debian/watch 2014-02-08 14:10:32.000000000 +0000 +++ zeroinstall-injector-2.7/debian/watch 2014-05-27 12:59:12.000000000 +0000 @@ -1,2 +1,2 @@ version=3 -http://sf.net/zero-install/0install-(\d.+)\.tar\.bz2 +opts="pgpsigurlmangle=s/$/.sig/" http://sf.net/zero-install/0install-(\d.+)\.tar\.bz2 diff -Nru zeroinstall-injector-2.6.1/install.sh.src zeroinstall-injector-2.7/install.sh.src --- zeroinstall-injector-2.6.1/install.sh.src 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/install.sh.src 2014-05-25 09:29:17.000000000 +0000 @@ -25,7 +25,7 @@ DOCS="../README.md ../COPYING" MANPAGES="0launch.1 0store-secure-add.1 0store.1 0desktop.1 0install.1" -PLUGIN=`echo gui_gtk.c*[sa]` +PLUGINS=`find . -name 'gui_gtk.c*[sa]' -print` # Use "share/zsh/vendor-completions" on Debian ZSHFUNCTIONS="share/zsh/site-functions" @@ -71,6 +71,7 @@ install -d "$DESTDIR${PREFIX_MAN}/man1/" install -d "$DESTDIR${PREFIX_SHARE}/0install.net/" install -d "$DESTDIR${PREFIX_SHARE}/applications/" +install -d "$DESTDIR${PREFIX_SHARE}/appdata/" install -d "$DESTDIR${PREFIX_SHARE}/bash-completion/completions/" install -d "$DESTDIR${PREFIX_SHARE}/fish/completions" install -d "$DESTDIR${PREFIX_SHARE}/doc/0install" @@ -80,6 +81,7 @@ install -m 0644 ${DOCS} "$DESTDIR${PREFIX_SHARE}/doc/0install/" install -m 0644 ${MANPAGES} "$DESTDIR${PREFIX_MAN}/man1/" install -m 0644 share/applications/0install.desktop "$DESTDIR${PREFIX_SHARE}/applications/" +install -m 0644 share/appdata/0install.appdata.xml "$DESTDIR${PREFIX_SHARE}/appdata/" install -m 0644 share/bash-completion/completions/0install "$DESTDIR${PREFIX_SHARE}/bash-completion/completions/" install -m 0644 share/bash-completion/completions/0launch "$DESTDIR${PREFIX_SHARE}/bash-completion/completions/" @@ -90,8 +92,8 @@ install -m 0755 share/0install.net/unlzma "$DESTDIR${PREFIX_SHARE}/0install.net/" install -m 0755 share/0install.net/unxz "$DESTDIR${PREFIX_SHARE}/0install.net/" -if [ -f "$PLUGIN" ]; then - install -m 0644 "$PLUGIN" "$DESTDIR${PREFIX}/lib/0install.net/" +if [ -n "$PLUGINS" ]; then + install -m 0644 $PLUGINS "$DESTDIR${PREFIX}/lib/0install.net/" fi for size in 24x24 48x48 128x128 scalable; do \ diff -Nru zeroinstall-injector-2.6.1/Makefile zeroinstall-injector-2.7/Makefile --- zeroinstall-injector-2.6.1/Makefile 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/Makefile 2014-05-25 09:29:17.000000000 +0000 @@ -42,6 +42,9 @@ %.ui.h: %.ui intltool-extract --type=gettext/glade --update "$<" +%.html: %.md + redcarpet $< > $@ || (rm -f $@; false) + # Make needs to run from the build directory, but people always want to run it from # the source directory. This rule matches all targets not defined here (i.e. those # which operate on the build directory) and runs make again from the build directory, diff -Nru zeroinstall-injector-2.6.1/Makefile.build zeroinstall-injector-2.7/Makefile.build --- zeroinstall-injector-2.6.1/Makefile.build 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/Makefile.build 2014-05-25 09:29:17.000000000 +0000 @@ -29,7 +29,7 @@ (cd "${SRCDIR}" && cp ${MANPAGES} "${DISTDIR}/files") install "${SRCDIR}/install.sh.src" "${DISTDIR}/install.sh" (cp -r share "${DISTDIR}/files/") - (cd "${SRCDIR}" && cp -r share/0install.net share/applications share/bash-completion share/fish share/icons share/zsh "${DISTDIR}/files/share/") + (cd "${SRCDIR}" && cp -r share/0install.net share/applications share/appdata share/bash-completion share/fish share/icons share/zsh "${DISTDIR}/files/share/") translations: $(MO) diff -Nru zeroinstall-injector-2.6.1/ocaml/0install.exe.rc zeroinstall-injector-2.7/ocaml/0install.exe.rc --- zeroinstall-injector-2.6.1/ocaml/0install.exe.rc 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/0install.exe.rc 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1 @@ +1 24 "0install.exe.manifest" diff -Nru zeroinstall-injector-2.6.1/ocaml/add_feed.ml zeroinstall-injector-2.7/ocaml/add_feed.ml --- zeroinstall-injector-2.6.1/ocaml/add_feed.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/add_feed.ml 2014-05-25 09:29:17.000000000 +0000 @@ -89,7 +89,7 @@ | [new_feed] -> let print fmt = Support.Utils.print config.system fmt in print "Feed '%s':" new_feed; - let new_feed = G.canonical_iface_uri config.system new_feed |> Zeroinstall.Feed_url.master_feed_of_iface in + let new_feed = G.canonical_feed_url config.system new_feed in (* If the feed is remote and missing, download it. *) let feed = @@ -111,17 +111,20 @@ log_warning "Update failed: %s" msg ); feed - | `local_feed _ as feed -> feed in + | `local_feed path as feed -> + if not (config.system#file_exists path) then + raise_safe "Local feed file '%s' does not exist" path; + feed in edit_feeds_interactive config `add feed | [iface; feed_src] -> let iface = G.canonical_iface_uri config.system iface in - let feed_src = G.canonical_iface_uri config.system feed_src in - let new_import = Zeroinstall.Feed_url.parse_non_distro feed_src |> F.make_user_import in + let feed_src = G.canonical_feed_url config.system feed_src in + let new_import = F.make_user_import feed_src in let iface_config = FC.load_iface_config config iface in if List.mem new_import iface_config.FC.extra_feeds then ( - raise_safe "Interface %s already has a feed %s" iface feed_src + raise_safe "Interface %s already has a feed %s" iface (Zeroinstall.Feed_url.format_url feed_src) ); let extra_feeds = new_import :: iface_config.FC.extra_feeds in diff -Nru zeroinstall-injector-2.6.1/ocaml/cli.ml zeroinstall-injector-2.7/ocaml/cli.ml --- zeroinstall-injector-2.6.1/ocaml/cli.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/cli.ml 2014-05-25 09:29:17.000000000 +0000 @@ -276,11 +276,12 @@ let make_tools config = let gui = ref Maybe in - let ui = lazy (Zeroinstall.Helpers.make_ui config !gui) in + let pool = ref None in + let ui = lazy (Zeroinstall.Default_ui.make_ui config !gui) in let distro = lazy (Zeroinstall.Distro_impls.get_host_distribution config) in let trust_db = lazy (new Zeroinstall.Trust.trust_db config) in - let download_pool = lazy (Zeroinstall.Downloader.make_pool ~max_downloads_per_site:2) in - let make_fetcher = lazy (new Zeroinstall.Fetch.fetcher config (Lazy.force trust_db) (Lazy.force distro) (Lazy.force download_pool)) in + let download_pool = lazy (let p = Zeroinstall.Downloader.make_pool ~max_downloads_per_site:2 in pool := Some p; p) in + let make_fetcher = lazy (Zeroinstall.Fetch.make config (Lazy.force trust_db) (Lazy.force distro) (Lazy.force download_pool)) in object (_ : Options.tools) method config = config method ui = Lazy.force ui @@ -290,6 +291,7 @@ method make_fetcher watcher = (Lazy.force make_fetcher) watcher method trust_db = Lazy.force trust_db method use_gui = !gui + method release = !pool |> if_some (fun pool -> pool#release) end let get_default_options config = @@ -300,6 +302,9 @@ } in options +let release_options options = + options.tools#release + let rec lookup_subcommand config name args (group:subgroup) : (string list * subcommand * string list) = let subcommand = try List.assoc name group @@ -319,11 +324,14 @@ let (raw_options, args, complete) = read_args spec raw_args in assert (complete = CompleteNothing); - let options = get_default_options config in - let command_path, subcommand, command_args = - match args with - | [] -> ([], no_command, []) - | ["run"] when List.mem ("-V", []) raw_options -> (["run"], no_command, []) (* Hack for 0launch -V *) - | command :: command_args -> lookup_subcommand config command command_args subcommands in - try subcommand#handle options raw_options command_path command_args - with ShowVersion -> Common_options.show_version config.system + Support.Utils.finally_do release_options + (get_default_options config) + (fun options -> + let command_path, subcommand, command_args = + match args with + | [] -> ([], no_command, []) + | ["run"] when List.mem ("-V", []) raw_options -> (["run"], no_command, []) (* Hack for 0launch -V *) + | command :: command_args -> lookup_subcommand config command command_args subcommands in + try subcommand#handle options raw_options command_path command_args + with ShowVersion -> Common_options.show_version config.system + ) diff -Nru zeroinstall-injector-2.6.1/ocaml/generic_select.ml zeroinstall-injector-2.7/ocaml/generic_select.ml --- zeroinstall-injector-2.6.1/ocaml/generic_select.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/generic_select.ml 2014-05-25 09:29:17.000000000 +0000 @@ -12,10 +12,9 @@ module Apps = Zeroinstall.Apps module Requirements = Zeroinstall.Requirements module U = Support.Utils -module H = Zeroinstall.Helpers type target = - | App of (filepath * Requirements.requirements) + | App of (filepath * Requirements.t) | Interface | Selections of Zeroinstall.Selections.t @@ -79,6 +78,30 @@ raise_safe "Bad interface name '%s'.\n(doesn't start with 'http:', and doesn't exist as a local file '%s' either)" arg path ) +(** Convert a feed URL from the user to canonical form. + * If it's a path, this calls [realpath] on it. + * It's not an error if the path doesn't exist (the user may be trying to unregister a feed). *) +let canonical_feed_url (system:system) arg = + let starts = U.starts_with arg in + let url = + if starts "http://" || starts "https://" then ( + if not (String.contains_from arg (String.index arg '/' + 2) '/') then + raise_safe "Missing / after hostname in URL '%s'" arg; + arg + ) else ( + if starts "file:///" then ( + U.string_tail arg 7 + ) else if starts "file:" then ( + if arg.[5] = '/' then + raise_safe "Use file:///path for absolute paths, not %s" arg; + U.string_tail arg 5 + ) else ( + arg + ) + |> U.realpath system + ) in + Zeroinstall.Feed_url.master_feed_of_iface url + type output_style = Output_none | Output_XML | Output_human type select_options = { diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/add_box.ml zeroinstall-injector-2.7/ocaml/gui_gtk/add_box.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/add_box.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/add_box.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** The dialog for adding a new app (used by "0desktop") *) open Support.Common +open Gtk_common open Zeroinstall.General module F = Zeroinstall.Feed @@ -61,10 +62,11 @@ ~xalign:0.0 ~line_wrap:true ~markup:"Enter the URI of the application you want to install, \ - or drag its link from a web-browser into this window." () |> ignore; + or drag its link from a web-browser into this window." + () |> ignore_widget; let hbox = GPack.hbox ~packing:vbox#pack ~spacing:4 () in - GMisc.label ~packing:hbox#pack ~text:"URI:" () |> ignore; + GMisc.label ~packing:hbox#pack ~text:"URI:" () |> ignore_widget; let entry = GEdit.entry ~packing:(hbox#pack ~expand:true) ~activates_default:true ~text:initial_uri () in (* Buttons *) @@ -74,7 +76,7 @@ let set_uri_ok () = dialog#set_response_sensitive `ADD (entry#text <> "") in - entry#connect#changed ~callback:set_uri_ok |> ignore; + entry#connect#changed ==> set_uri_ok; set_uri_ok (); let add () = @@ -103,12 +105,12 @@ entry#set_text iface; Gtk_utils.async ~parent:dialog add; true - ) |> ignore; + ); - dialog#connect#response ~callback:(function + dialog#connect#response ==> (function | `DELETE_EVENT | `CANCEL -> dialog#destroy (); Lwt.wakeup set_finished () | `ADD -> Gtk_utils.async ~parent:dialog add; - ) |> ignore; + ); dialog#show (); diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/alert_box.ml zeroinstall-injector-2.7/ocaml/gui_gtk/alert_box.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/alert_box.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/alert_box.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** A simple error report box *) open Support.Common +open Gtk_common let () = ignore on_windows @@ -16,7 +17,7 @@ ~message ~buttons:GWindow.Buttons.ok () in - box#connect#response ~callback:(fun _ -> box#destroy ()) |> ignore; + box#connect#response ==> (fun _ -> box#destroy ()); box#show () let last_error = ref None @@ -31,5 +32,5 @@ ~message:(Printexc.to_string ex) ~buttons:GWindow.Buttons.ok () in - error_box#connect#response ~callback:(fun _ -> error_box#destroy ()) |> ignore; + error_box#connect#response ==> (fun _ -> error_box#destroy ()); error_box#show () diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/app_list_box.ml zeroinstall-injector-2.7/ocaml/gui_gtk/app_list_box.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/app_list_box.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/app_list_box.ml 2014-05-25 09:29:17.000000000 +0000 @@ -6,6 +6,7 @@ open Zeroinstall.General open Support.Common +open Gtk_common module F = Zeroinstall.Feed module Q = Support.Qdom @@ -121,19 +122,19 @@ ~title:"Confirm" () in let markup = Printf.sprintf "Remove %s from the applications list?" (Gtk_utils.pango_escape name) in - GMisc.label ~packing:box#vbox#pack ~xpad:20 ~ypad:20 ~markup () |> ignore; + GMisc.label ~packing:box#vbox#pack ~xpad:20 ~ypad:20 ~markup () |> ignore_widget; box#add_button_stock `CANCEL `CANCEL; box#add_button_stock `DELETE `DELETE; let result, set_result = Lwt.wait () in box#set_default_response `DELETE; - box#connect#response ~callback:(fun response -> + box#connect#response ==> (fun response -> box#destroy (); Lwt.wakeup set_result ( match response with | `DELETE -> `delete | `CANCEL | `DELETE_EVENT -> `cancel ) - ) |> ignore; + ); box#show (); result @@ -228,25 +229,25 @@ let edit_item = GMenu.menu_item ~packing:menu#add ~label:"Choose versions" () in let delete_item = GMenu.menu_item ~packing:menu#add ~label:"Delete" () in - run_item#connect#activate ~callback:(fun () -> + run_item#connect#activate ==> (fun () -> run config dialog tools gui (!menu_iface |? lazy (raise_safe "BUG: no selected item!")) - ) |> ignore; + ); - help_item#connect#activate ~callback:(fun () -> + help_item#connect#activate ==> (fun () -> let uri = !menu_iface |? lazy (raise_safe "BUG: no selected item!") in Gtk_utils.async ~parent:dialog (fun () -> show_help_for_iface tools ~gui uri) - ) |> ignore; + ); - edit_item#connect#activate ~callback:(fun () -> + edit_item#connect#activate ==> (fun () -> let uri = !menu_iface |? lazy (raise_safe "BUG: no selected item!") in let reqs = Zeroinstall.Requirements.default_requirements uri in Gtk_utils.async ~parent:dialog (fun () -> lwt _ = gui#run_solver tools `Download_only reqs ~refresh:false in Lwt.return () ) - ) |> ignore; + ); - delete_item#connect#activate ~callback:(fun () -> + delete_item#connect#activate ==> (fun () -> match view#get_selected_items with | [path] -> let row = model#get_iter path in @@ -267,9 +268,9 @@ Lwt.return () ) | _ -> log_warning "Invalid selection!" - ) |> ignore; + ); - view#event#connect#button_press ~callback:(fun bev -> + view#event#connect#button_press ==> (fun bev -> let module B = GdkEvent.Button in let path_unsafe = view#get_path_at_pos (B.x bev |> truncate) (B.y bev |> truncate) in (* (a bug in lablgtk means the "option" part is missing) *) @@ -287,7 +288,7 @@ true | _ -> false - ) |> ignore; + ); let default_icon = view#misc#render_icon ~size:`DIALOG `EXECUTE in @@ -328,14 +329,18 @@ Gtk_utils.sanity_check_iface iface; add_and_repopulate iface; true - ) |> ignore; + ); - dialog#connect#response ~callback:(function + dialog#connect#response ==> (function | `DELETE_EVENT | `CLOSE -> dialog#destroy (); Lwt.wakeup set_finished () | `SHOW_CACHE -> Gtk_utils.async (fun () -> Cache_explorer_box.open_cache_explorer config) | `ADD -> add_and_repopulate "" - ) |> ignore; - dialog#show (); + ); + dialog#set_default_size + ~width:(Gdk.Screen.width () / 3) + ~height:(Gdk.Screen.width () / 3); + + dialog#show (); finished diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/bug_report_box.ml zeroinstall-injector-2.7/ocaml/gui_gtk/bug_report_box.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/bug_report_box.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/bug_report_box.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** Displays a form to the user to collect extra information for the bug report. *) open Support.Common +open Gtk_common module U = Support.Utils @@ -71,7 +72,7 @@ begin match run_test with | Some run_test -> - get_errors#connect#clicked ~callback:(fun () -> + get_errors#connect#clicked ==> (fun () -> get_errors#misc#set_sensitive false; Gtk_utils.async ~parent:box (fun () -> try_lwt @@ -82,7 +83,7 @@ get_errors#misc#set_sensitive true; Lwt.return () ) - ) |> ignore; + ); | None -> get_errors#misc#set_sensitive false end; buffer in @@ -94,7 +95,7 @@ box#add_button_stock `OK `OK; box#set_default_response `OK; - box#connect#response ~callback:(function + box#connect#response ==> (function | `CANCEL | `DELETE_EVENT -> box#destroy () | `OK -> let message = spf "\ @@ -122,7 +123,7 @@ Alert_box.report_error ~parent:box ex; Lwt.return () ) - ) |> ignore; + ); box#set_default_size ~width:(Gdk.Screen.width () / 2) diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/cache_explorer_box.ml zeroinstall-injector-2.7/ocaml/gui_gtk/cache_explorer_box.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/cache_explorer_box.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/cache_explorer_box.ml 2014-05-25 09:29:17.000000000 +0000 @@ -6,6 +6,7 @@ open Zeroinstall.General open Support.Common +open Gtk_common module F = Zeroinstall.Feed module U = Support.Utils @@ -111,10 +112,10 @@ report_text#buffer#insert msg in let cancelled = ref false in - box#connect#response ~callback:(fun _ -> + box#connect#response ==> (fun _ -> cancelled := true; box#destroy () - ) |> ignore; + ); let n_items = List.length paths in let n = ref 0 in @@ -166,19 +167,19 @@ ~parent ~title:"Confirm" () in - GMisc.label ~packing:box#vbox#pack ~xpad:20 ~ypad:20 ~text:message () |> ignore; + GMisc.label ~packing:box#vbox#pack ~xpad:20 ~ypad:20 ~text:message () |> ignore_widget; box#add_button_stock `CANCEL `CANCEL; box#add_button_stock `DELETE `DELETE; let result, set_result = Lwt.wait () in box#set_default_response `DELETE; - box#connect#response ~callback:(fun response -> + box#connect#response ==> (fun response -> box#destroy (); Lwt.wakeup set_result ( match response with | `DELETE -> `delete | `CANCEL | `DELETE_EVENT -> `cancel ) - ) |> ignore; + ); box#show (); result @@ -221,9 +222,9 @@ owner_vc#set_sort_column_id owner_col.GTree.index; size_vc#set_sort_column_id size_col.GTree.index; - view#append_column owner_vc |> ignore; - view#append_column version_vc |> ignore; - view#append_column size_vc |> ignore; + append_column view owner_vc; + append_column view version_vc; + append_column view size_vc; let selection = view#selection in @@ -241,9 +242,9 @@ ~homogeneous:false () in - GMisc.label ~packing:(table#attach ~top:0 ~left:0) ~text:"Feed:" ~xalign:1.0 () |> ignore; - GMisc.label ~packing:(table#attach ~top:1 ~left:0) ~text:"Path:" ~xalign:1.0 () |> ignore; - GMisc.label ~packing:(table#attach ~top:2 ~left:0) ~text:"Details:" ~xalign:1.0 () |> ignore; + GMisc.label ~packing:(table#attach ~top:0 ~left:0) ~text:"Feed:" ~xalign:1.0 () |> ignore_widget; + GMisc.label ~packing:(table#attach ~top:1 ~left:0) ~text:"Path:" ~xalign:1.0 () |> ignore_widget; + GMisc.label ~packing:(table#attach ~top:2 ~left:0) ~text:"Details:" ~xalign:1.0 () |> ignore_widget; let details_iface = GMisc.label ~packing:(table#attach ~top:0 ~left:1 ~expand:`X) ~xalign:0.0 ~selectable:true () in let details_path = GMisc.label ~packing:(table#attach ~top:1 ~left:1 ~expand:`X) ~xalign:0.0 ~selectable:true () in @@ -253,7 +254,7 @@ details_extra#set_ellipsize `END; let delete = GButton.button ~packing:(table#attach ~top:0 ~left:2) ~stock:`DELETE () in - delete#connect#clicked ~callback:(fun () -> + delete#connect#clicked ==> (fun () -> let iters = selection#get_selected_rows |> List.map (fun sorted_path -> sorted_model#get_iter sorted_path |> Unsorted_list.convert_iter_to_child_iter sorted_model ) in @@ -276,26 +277,26 @@ dialog#misc#set_sensitive true; Lwt.return () ) - ) |> ignore; + ); let verify = Gtk_utils.mixed_button ~packing:(table#attach ~top:1 ~left:2) ~stock:`FIND ~label:"Verify" () in - verify#connect#clicked ~callback:(fun () -> + verify#connect#clicked ==> (fun () -> let dirs = selection#get_selected_rows |> List.map (fun path -> let row = sorted_model#get_iter path in sorted_model#get ~row ~column:impl_dir_col ) in show_verification_box config ~parent:dialog dirs - ) |> ignore; + ); let open_button = GButton.button ~packing:(table#attach ~top:2 ~left:2) ~stock:`OPEN () in - open_button#connect#clicked ~callback:(fun () -> + open_button#connect#clicked ==> (fun () -> match selection#get_selected_rows with | [path] -> let row = sorted_model#get_iter path in let dir = sorted_model#get ~row ~column:impl_dir_col in U.xdg_open_dir ~exec:false config.system dir | _ -> log_warning "Invalid selection!" - ) |> ignore; + ); details_frame#misc#set_sensitive false; @@ -307,10 +308,15 @@ dialog#add_button_stock `CLOSE `CLOSE; - dialog#connect#response ~callback:(function + dialog#connect#response ==> (function | `DELETE_EVENT | `CLOSE -> dialog#destroy (); Lwt.wakeup set_finished () | `HELP -> cache_help#display - ) |> ignore; + ); + + dialog#set_default_size + ~width:(Gdk.Screen.width () / 3) + ~height:(Gdk.Screen.width () / 3); + dialog#show (); (* Make sure the GUI appears before we start the (slow) scan *) @@ -386,7 +392,7 @@ (* Update the details panel when the selection changes *) selection#set_mode `MULTIPLE; - selection#connect#changed ~callback:(fun () -> + selection#connect#changed ==> (fun () -> let interface, path, extra, sensitive, single = match selection#get_selected_rows with | [] -> ("", "", [], false, false) @@ -414,7 +420,7 @@ details_extra#set_text (String.concat ", " extra); details_frame#misc#set_sensitive sensitive; open_button#misc#set_sensitive single; - ) |> ignore; + ); dialog#misc#set_sensitive true; diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/component_box.ml zeroinstall-injector-2.7/ocaml/gui_gtk/component_box.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/component_box.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/component_box.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** The per-component dialog (the one with the Feeds and Versions tabs). *) open Support.Common +open Gtk_common open Zeroinstall.General module FeedAttr = Zeroinstall.Constants.FeedAttr @@ -124,7 +125,7 @@ | Some description -> Str.split (Str.regexp_string "\n\n") description |> List.map format_para | None -> ["-"] in - let homepages = ZI.map feed.F.root "homepage" ~f:(fun homepage -> + let homepages = feed.F.root |> ZI.map ~name:"homepage" (fun homepage -> homepage.Q.last_text_inside; ) in @@ -229,7 +230,7 @@ let error_label = GMisc.label ~packing:vbox#pack ~xpad:4 ~ypad:4 ~line_wrap:true ~show:false () in box#set_default_response `OK; - box#connect#response ~callback:(function + box#connect#response ==> (function | `DELETE_EVENT | `CANCEL -> box#destroy () | `OK -> error_label#misc#hide (); @@ -254,7 +255,7 @@ entry#misc#grab_focus (); Lwt.return () ) - ) |> ignore; + ); box#show () @@ -270,7 +271,7 @@ box#add_button_stock `CANCEL `CANCEL; box#add_select_button_stock `OPEN `OK; - box#connect#response ~callback:(function + box#connect#response ==> (function | `DELETE_EVENT | `CANCEL -> box#destroy () | `OK -> try @@ -282,7 +283,7 @@ box#destroy (); recalculate ~force:false with Safe_exception _ as ex -> Alert_box.report_error ~parent:box ex - ) |> ignore; + ); box#show () @@ -319,8 +320,8 @@ let arch_col = GTree.view_column ~title:"Arch" ~renderer:(renderer, ["text", arch]) () in source_col#add_attribute renderer "sensitive" used; arch_col#add_attribute renderer "sensitive" used; - view#append_column source_col |> ignore; - view#append_column arch_col |> ignore; + append_column view source_col; + append_column view arch_col; let selection = view#selection in selection#set_mode `BROWSE; @@ -330,9 +331,9 @@ let add_local = GButton.button ~packing:button_box#pack ~label:"Add local feed" () in let remove_feed = GButton.button ~packing:button_box#pack ~label:"Remove feed" () in - add_remote#connect#clicked ~callback:(add_remote_feed ~parent:window ~watcher ~recalculate tools iface) |> ignore; - add_local#connect#clicked ~callback:(add_local_feed ~parent:window ~recalculate config iface) |> ignore; - remove_feed#connect#clicked ~callback:(fun () -> + add_remote#connect#clicked ==> (add_remote_feed ~parent:window ~watcher ~recalculate tools iface); + add_local#connect#clicked ==> (add_local_feed ~parent:window ~recalculate config iface); + remove_feed#connect#clicked ==> (fun () -> match selection#get_selected_rows with | [path] -> let iter = feeds_model#get_iter path in @@ -341,7 +342,7 @@ remove_feed#misc#set_sensitive false; recalculate ~force:false; | _ -> log_warning "Impossible selection!" - ) |> ignore; + ); (* Description *) let swin = GBin.scrolled_window @@ -368,7 +369,7 @@ let clear () = buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter in (* Update description when a feed is selected *) - selection#connect#changed ~callback:(fun () -> + selection#connect#changed ==> (fun () -> limit_updates (fun () -> match selection#get_selected_rows with | [] -> clear (); Lwt.return () @@ -385,9 +386,9 @@ add_description_text config ~trust_db ~heading_style ~link_style buffer feed description end | _ -> log_warning "Multiple selection in browse mode!"; Lwt.return () ) - ) |> ignore; + ); - text#event#connect#button_press ~callback:(fun bev -> + text#event#connect#button_press ==> (fun bev -> let module B = GdkEvent.Button in if GdkEvent.get_type bev = `BUTTON_PRESS && B.button bev = 1 then ( let win_type = text#get_window_type (GdkEvent.get_window bev) in @@ -401,7 +402,7 @@ true ) else false ) else false - ) |> ignore; + ); text#misc#set_size_request ~width:(-1) ~height:100 (); @@ -447,14 +448,14 @@ let menu = GMenu.menu () in let unset = GMenu.menu_item ~packing:menu#add ~label:"Unset" () in - unset#connect#activate ~callback:(fun () -> set_stability None) |> ignore; + unset#connect#activate ==> (fun () -> set_stability None); - GMenu.separator_item ~packing:menu#add () |> ignore; + GMenu.separator_item ~packing:menu#add () |> ignore_widget; [Preferred; Packaged; Stable; Testing; Developer; Buggy; Insecure] |> List.iter (fun stability -> let label = F.format_stability stability |> String.capitalize in let item = GMenu.menu_item ~packing:menu#add ~label () in - item#connect#activate ~callback:(fun () -> set_stability (Some stability)) |> ignore + item#connect#activate ==> (fun () -> set_stability (Some stability)) ); menu @@ -473,15 +474,15 @@ ~vpolicy:`AUTOMATIC () in - GMisc.label ~packing:swin#add_with_viewport ~text:reason () |> ignore; + GMisc.label ~packing:swin#add_with_viewport ~text:reason () |> ignore_widget; box#set_default_size ~width:(Gdk.Screen.width () * 3 / 4) ~height:(Gdk.Screen.height () / 3); - box#connect#response ~callback:(function + box#connect#response ==> (function | `DELETE_EVENT | `CLOSE -> box#destroy () - ) |> ignore; + ); box#show () ) else ( let box = GWindow.message_dialog @@ -491,9 +492,9 @@ ~buttons:GWindow.Buttons.close ~message_type:`INFO () in - box#connect#response ~callback:(function + box#connect#response ==> (function | `DELETE_EVENT | `CLOSE -> box#destroy () - ) |> ignore; + ); box#show () ) @@ -562,7 +563,7 @@ let view_col = GTree.view_column ~title ~renderer:(cell, ["text", column]) () in view_col#add_attribute cell "weight" weight; if strike then view_col#add_attribute cell "strikethrough" unusable; - view#append_column view_col |> ignore in + append_column view view_col in add_column "Version" ~strike:true version; add_column "Released" released; @@ -572,7 +573,7 @@ add_column "Lang" langs; add_column "Notes" notes; - view#event#connect#button_press ~callback:(fun bev -> + view#event#connect#button_press ==> (fun bev -> let module B = GdkEvent.Button in match GdkEvent.get_type bev, B.button bev with | `BUTTON_PRESS, (1 | 3) -> @@ -592,9 +593,9 @@ let add_open_item path = let item = GMenu.menu_item ~packing:menu#add ~label:"Open in file manager" () in - item#connect#activate ~callback:(fun () -> + item#connect#activate ==> (fun () -> U.xdg_open_dir config.system path - ) |> ignore in + ) in begin match impl.F.impl_type with | `local_impl path -> add_open_item path | `cache_impl info -> @@ -603,14 +604,14 @@ | `package_impl _ -> () end; let explain = GMenu.menu_item ~packing:menu#add ~label:"Explain this decision" () in - explain#connect#activate ~callback:(fun () -> + explain#connect#activate ==> (fun () -> let reason = Zeroinstall.Diagnostics.justify_decision config watcher#feed_provider reqs iface (F.get_id impl) in show_explanation_box ~parent:window iface version_str reason - ) |> ignore; + ); menu#popup ~button:(B.button bev) ~time:(B.time bev); true end | _ -> false - ) |> ignore; + ); object method widget = vbox#coerce @@ -681,8 +682,8 @@ let label text = (GMisc.label ~text () :> GObj.widget) in let feeds_tab = make_feeds_tab tools ~trust_db ~recalculate ~watcher dialog iface in let versions_tab = make_versions_tab config reqs ~recalculate ~watcher dialog iface in - notebook#append_page ~tab_label:(label "Feeds") (feeds_tab#widget) |> ignore; - notebook#append_page ~tab_label:(label "Versions") (versions_tab#widget) |> ignore; + append_page notebook ~tab_label:(label "Feeds") (feeds_tab#widget); + append_page notebook ~tab_label:(label "Versions") (versions_tab#widget); if select_versions_tab then notebook#next_page (); @@ -698,7 +699,7 @@ dialog#set_response_sensitive `COMPILE false; - dialog#connect#response ~callback:(function + dialog#connect#response ==> (function | `COMPILE -> Gtk_utils.async ~parent:dialog (fun () -> lwt () = Zeroinstall.Gui.compile config watcher#feed_provider iface ~autocompile:true in @@ -707,7 +708,7 @@ ) | `DELETE_EVENT | `CLOSE -> dialog#destroy () | `HELP -> component_help#display - ) |> ignore; + ); object method dialog = dialog diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/component_tree.ml zeroinstall-injector-2.7/ocaml/gui_gtk/component_tree.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/component_tree.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/component_tree.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** The tree of components in the main window. *) open Support.Common +open Gtk_common open Zeroinstall.General module FeedAttr = Zeroinstall.Constants.FeedAttr @@ -86,11 +87,11 @@ let add ~title cell column = let view_col = GTree.view_column ~title ~renderer:(cell, ["text", column]) () in - view#append_column view_col |> ignore; + append_column view view_col; view_col in let component_vc = GTree.view_column ~title:"Component" () in - view#append_column component_vc |> ignore; + append_column view component_vc; component_vc#pack ~expand:false icon_renderer; component_vc#add_attribute icon_renderer "pixbuf" icon; component_vc#pack text_plain; @@ -101,7 +102,7 @@ let summary_vc = add ~title:"Description" text_ellip summary_col in summary_vc#misc#set_property "expand" (`BOOL true); let action_vc = GTree.view_column ~renderer:(action_renderer, []) () in - view#append_column action_vc |> ignore; + append_column view action_vc; view#set_enable_search true; @@ -137,7 +138,7 @@ ) in view#misc#set_has_tooltip true; - view#misc#connect#query_tooltip ~callback:(fun ~x ~y ~kbd tooltip -> + view#misc#connect#query_tooltip ==> (fun ~x ~y ~kbd tooltip -> let (x, y, _) = GtkTree.TreeView.Tooltip.get_context view#as_tree_view ~x ~y ~kbd in match view#get_path_at_pos ~x ~y with | None -> false @@ -146,7 +147,7 @@ GtkBase.Tooltip.set_text tooltip @@ get_tooltip row col#get_oid; GtkTree.TreeView.Tooltip.set_cell view#as_tree_view tooltip ~path ~col:col#as_column (); true - ) |> ignore; + ); (* Menu *) let module B = GdkEvent.Button in @@ -158,11 +159,11 @@ let show_feeds = GMenu.menu_item ~packing ~label:"Show Feeds" () in let show_versions = GMenu.menu_item ~packing ~label:"Show Versions" () in - show_feeds#connect#activate ~callback:(fun () -> show_component iface ~select_versions_tab:false) |> ignore; - show_versions#connect#activate ~callback:(fun () -> show_component iface ~select_versions_tab:true) |> ignore; + show_feeds#connect#activate ==> (fun () -> show_component iface ~select_versions_tab:false); + show_versions#connect#activate ==> (fun () -> show_component iface ~select_versions_tab:true); let report_a_bug = GMenu.menu_item ~packing ~label:"Report a Bug..." () in - report_a_bug#connect#activate ~callback:(fun () -> report_bug iface) |> ignore; + report_a_bug#connect#activate ==> (fun () -> report_bug iface); let compile_item = GMenu.menu_item ~packing ~label:"Compile" () in if have_source then ( @@ -176,14 +177,14 @@ compile_item#set_submenu compile_menu; let packing = compile_menu#add in - (GMenu.menu_item ~packing ~label:"Automatic" ())#connect#activate ~callback:(compile ~autocompile:true) |> ignore; - (GMenu.menu_item ~packing ~label:"Manual..." ())#connect#activate ~callback:(compile ~autocompile:false) |> ignore; + (GMenu.menu_item ~packing ~label:"Automatic" ())#connect#activate ==> (compile ~autocompile:true); + (GMenu.menu_item ~packing ~label:"Manual..." ())#connect#activate ==> (compile ~autocompile:false); ) else ( compile_item#misc#set_sensitive false ); menu#popup ~button:(B.button bev) ~time:(B.time bev) in - view#event#connect#button_press ~callback:(fun bev -> + view#event#connect#button_press ==> (fun bev -> match view#get_path_at_pos ~x:(B.x bev |> truncate) ~y:(B.y bev |> truncate) with | Some (path, col, _x, _y) -> let button = B.button bev in @@ -200,7 +201,7 @@ true ) else false | None -> false - ) |> ignore; + ); (* Populating the model *) let feed_to_iface = Hashtbl.create 100 in diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/gtk_common.ml zeroinstall-injector-2.7/ocaml/gui_gtk/gtk_common.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/gtk_common.ml 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/gtk_common.ml 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,22 @@ +(* Copyright (C) 2013, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** To be opened by all GTK modules. *) + +(** Connect a signal handler, ignoring the resulting signal ID. + * This avoids having to use [|> ignore] everywhere. *) +let (==>) (signal:(callback:_ -> GtkSignal.id)) callback = + ignore (signal ~callback) + +(** Create a widget and ignore it. This is useful for decorations (e.g. labels) + * to avoid using the generic [ignore], which can ignore other things too. *) +let ignore_widget : #GObj.widget -> unit = ignore + +(** Append a column and ignore the returned column ID. *) +let append_column (tv:GTree.view) (col:GTree.view_column) = + ignore (tv#append_column col) + +(** Append a notebook page and ignore the returned page number. *) +let append_page (nb:GPack.notebook) ?tab_label page = + ignore (nb#append_page ?tab_label page) diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/gtk_utils.ml zeroinstall-injector-2.7/ocaml/gui_gtk/gtk_utils.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/gtk_utils.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/gtk_utils.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** Some helper functions for GTK. *) open Support.Common +open Gtk_common module U = Support.Utils @@ -12,8 +13,8 @@ let stock_label ~packing ?(use_mnemonic=false) ~stock ~label () = let align = GBin.alignment ~packing ~xalign:0.5 ~xscale:0.0 () in let hbox = GPack.hbox ~packing:align#add ~spacing:2 () in - GMisc.image ~packing:hbox#pack ~stock ~icon_size:`BUTTON () |> ignore; - GMisc.label ~packing:hbox#pack ~use_underline:use_mnemonic ~text:label () |> ignore + GMisc.image ~packing:hbox#pack ~stock ~icon_size:`BUTTON () |> ignore_widget; + GMisc.label ~packing:hbox#pack ~use_underline:use_mnemonic ~text:label () |> ignore_widget (** Create a button with a stock icon and a custom label. *) let mixed_button ~packing ?use_mnemonic ~stock ~label () = @@ -71,7 +72,7 @@ ~flags:[`MOTION; `DROP; `HIGHLIGHT] ~actions:[`COPY] [ Gtk.({ target = "text/uri-list"; flags = []; info = 0 }) ]; - drag_ops#connect#data_received ~callback:(fun drag_context ~x:_ ~y:_ data ~info:_ ~time -> + drag_ops#connect#data_received ==> (fun drag_context ~x:_ ~y:_ data ~info:_ ~time -> try let data = data#data in match Str.split (Str.regexp "[\n\r]+") data with diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/gui_gtk_plugin.ml zeroinstall-injector-2.7/ocaml/gui_gtk/gui_gtk_plugin.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/gui_gtk_plugin.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/gui_gtk_plugin.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** A GTK GUI plugin *) open Support.Common +open Zeroinstall.General module Ui = Zeroinstall.Ui module Downloader = Zeroinstall.Downloader @@ -20,7 +21,7 @@ object method config = config method distro = distro - method make_fetcher watcher = new Zeroinstall.Fetch.fetcher config trust_db distro download_pool watcher + method make_fetcher watcher = Zeroinstall.Fetch.make config trust_db distro download_pool watcher end in object (self : Zeroinstall.Ui.ui_handler) @@ -69,6 +70,21 @@ (* If this raises an exception, gui.ml will log it and continue without the GUI. *) let try_get_gtk_gui config _use_gui = + log_info "Switching to GLib mainloop..."; + + (* Install Lwt<->Glib integration. + * LWT <= 2.4.4 is buggy (https://github.com/ocsigen/lwt/issues/25) so we have + * to be careful... *) + if config.system#platform.Platform.os = "Linux" then ( + (* On Linux: + * - lwt_into_glib mode hangs for LWT <= 2.4.4 + * - glib_into_lwt works on all versions, so use that *) + Lwt_glib.install ~mode:`glib_into_lwt () + ) else ( + (* Otherwise, glib_into_lwt never works, so use lwt_into_glib (and require LWT > 2.4.4). *) + Lwt_glib.install ~mode:`lwt_into_glib () + ); + (* Initializes GTK. *) ignore (GMain.init ()); Some (make_gtk_ui config) diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/gui_progress.ml zeroinstall-injector-2.7/ocaml/gui_gtk/gui_progress.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/gui_progress.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/gui_progress.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** Keeps track of download progress. *) open Support.Common +open Gtk_common module Downloader = Zeroinstall.Downloader @@ -108,14 +109,14 @@ () in let result, set_result = Lwt.wait () in box#set_default_response `OK; - box#connect#response ~callback:(fun response -> + box#connect#response ==> (fun response -> box#destroy (); Lwt.wakeup set_result ( match response with | `OK -> `ok | `CANCEL | `DELETE_EVENT -> `cancel ) - ) |> ignore; + ); box#show (); result diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/help_box.ml zeroinstall-injector-2.7/ocaml/gui_gtk/help_box.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/help_box.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/help_box.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** Displays a few paragraphs of help text in a dialog box. *) open Support.Common +open Gtk_common let create title sections = object @@ -53,10 +54,10 @@ swin#add (text :> GObj.widget); box#add_button_stock `CLOSE `CLOSE; - box#connect#response ~callback:(function + box#connect#response ==> (function | `CLOSE | `DELETE_EVENT -> box#destroy () - ) |> ignore; - box#connect#destroy ~callback:(fun () -> dialog <- None) |> ignore; + ); + box#connect#destroy ==> (fun () -> dialog <- None); box#set_default_response `CLOSE; box#set_default_size ~width:(Gdk.Screen.width () / 4) diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/preferences_box.ml zeroinstall-injector-2.7/ocaml/gui_gtk/preferences_box.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/preferences_box.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/preferences_box.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** The global preferences dialog. *) open Support.Common +open Gtk_common open Zeroinstall.General module G = Support.Gpg @@ -88,7 +89,7 @@ }) in let model, column = GTree.store_of_list data_conv choices in - GMisc.label ~packing:(table#attach ~left:0 ~top) ~text:label ~xalign:1.0 () |> ignore; + GMisc.label ~packing:(table#attach ~left:0 ~top) ~text:label ~xalign:1.0 () |> ignore_widget; let combo = GEdit.combo_box ~packing:(table#attach ~left:1 ~top ~expand:`X) ~model () in let cell = GTree.cell_renderer_text [] in combo#pack ~expand:true cell; @@ -98,7 +99,7 @@ | x :: _ when x = value -> i | _ :: rest -> index (i + 1) rest in combo#set_active (index 0 choices); - combo#connect#changed ~callback:(fun () -> List.nth choices combo#active |> callback) |> ignore; + combo#connect#changed ==> (fun () -> List.nth choices combo#active |> callback); combo#misc#set_tooltip_text tooltip let find_open_rows (view:GTree.view) column = @@ -135,10 +136,10 @@ let view = GTree.view ~model ~packing:swin#add () in let renderer = GTree.cell_renderer_text [] in let view_col = GTree.view_column ~title:"Trusted keys" ~renderer:(renderer, ["text", name]) () in - view#append_column view_col |> ignore; + append_column view view_col; (* Handle events *) - view#event#connect#button_press ~callback:(fun bev -> + view#event#connect#button_press ==> (fun bev -> let module B = GdkEvent.Button in if GdkEvent.get_type bev = `BUTTON_PRESS && B.button bev = 3 then ( match view#get_path_at_pos ~x:(B.x bev |> truncate) ~y:(B.y bev |> truncate) with @@ -152,12 +153,12 @@ let domain = model#get ~row:iter ~column:name in let menu = GMenu.menu () in let item = GMenu.menu_item ~packing:menu#add ~label:(Printf.sprintf "Remove key for \"%s\"" key) () in - item#connect#activate ~callback:(fun () -> trust_db#untrust_key ~domain fpr) |> ignore; + item#connect#activate ==> (fun () -> trust_db#untrust_key ~domain fpr); menu#popup ~button:(B.button bev) ~time:(B.time bev); true ) else false ) else false - ) |> ignore; + ); (* Populate model *) let populate_model () = @@ -190,7 +191,7 @@ Lwt.return () in let unregister = trust_db#add_watcher (object method notify = Gtk_utils.async populate_model end) in - view#connect#destroy ~callback:unregister |> ignore; + view#connect#destroy ==> unregister; Gtk_utils.async populate_model @@ -242,14 +243,14 @@ "Try out new versions as soon as they are available, instead of waiting for them to be marked as 'stable'. \ This sets the default policy. Choose 'Show Versions' from the menu in the main window to set the policy \ for an individual component."; - help_with_testing#connect#toggled ~callback:(fun () -> + help_with_testing#connect#toggled ==> (fun () -> config.help_with_testing <- help_with_testing#active; apply_changes () - ) |> ignore; + ); (* Keys *) let security_settings = frame ~packing:(vbox#pack ~expand:true ~fill:true) ~title:"Security" in let vbox = GPack.vbox ~border_width:12 ~packing:security_settings#add () in - GMisc.label ~packing:vbox#pack ~xalign:0.0 ~markup:"These keys may sign software updates:" () |> ignore; + GMisc.label ~packing:vbox#pack ~xalign:0.0 ~markup:"These keys may sign software updates:" () |> ignore_widget; add_key_list ~packing:(vbox#pack ~expand:true ~fill:true) config trust_db; @@ -261,9 +262,9 @@ auto_approve#misc#set_tooltip_text "When fetching a feed for the first time, if the key is known to the key information server then \ approve it automatically without confirmation."; - auto_approve#connect#toggled ~callback:(fun () -> + auto_approve#connect#toggled ==> (fun () -> config.auto_approve_keys <- auto_approve#active; apply_changes () - ) |> ignore; + ); (* Buttons *) dialog#add_button_stock `HELP `HELP; @@ -275,10 +276,10 @@ dialog#set_default_response `CLOSE; let result, set_result = Lwt.wait () in - dialog#connect#response ~callback:(function + dialog#connect#response ==> (function | `DELETE_EVENT | `CLOSE -> Lwt.wakeup set_result (); dialog#destroy () | `HELP -> preferences_help#display - ) |> ignore; + ); dialog#set_default_size ~width:(-1) ~height:(Gdk.Screen.height () / 3); (dialog, result) diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/solver_box.ml zeroinstall-injector-2.7/ocaml/gui_gtk/solver_box.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/solver_box.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/solver_box.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** The main GUI window showing the progress of a solve. *) open Support.Common +open Gtk_common module Feed_url = Zeroinstall.Feed_url module Driver = Zeroinstall.Driver @@ -162,15 +163,15 @@ let widgets = make_dialog reqs.Requirements.message mode ~systray in let dialog = widgets.dialog in - widgets.refresh_button#connect#clicked ~callback:(fun () -> recalculate ~force:true) |> ignore; - widgets.stop_button#connect#clicked ~callback:(fun () -> watcher#abort_all_downloads) |> ignore; + widgets.refresh_button#connect#clicked ==> (fun () -> recalculate ~force:true); + widgets.stop_button#connect#clicked ==> (fun () -> watcher#abort_all_downloads); - widgets.dialog#connect#response ~callback:(function + widgets.dialog#connect#response ==> (function | `HELP -> main_window_help#display | `PREFERENCES -> Gtk_utils.async ~parent:dialog show_preferences | `DELETE_EVENT | `CANCEL -> Lwt.wakeup set_user_response `aborted_by_user - ) |> ignore; + ); (* If a system tray icon was requested, create one. Otherwise, show the main window. *) if systray then ( @@ -205,7 +206,7 @@ | None -> let box = Component_box.create tools ~trust_db reqs iface ~recalculate ~select_versions_tab ~watcher in component_boxes := !component_boxes |> StringMap.add iface box; - box#dialog#connect#destroy ~callback:(fun () -> component_boxes := !component_boxes |> StringMap.remove iface) |> ignore; + box#dialog#connect#destroy ==> (fun () -> component_boxes := !component_boxes |> StringMap.remove iface); box#update; box#dialog#show () in @@ -214,7 +215,7 @@ component_tree#set_update_icons !refresh; (* Handling the Select/Download/Run toggle button *) - widgets.ok_button#connect#toggled ~callback:(fun () -> + widgets.ok_button#connect#toggled ==> (fun () -> log_info "OK button => %b" widgets.ok_button#active; let on_success () = (* Downloads done - check button is still pressed *) @@ -242,7 +243,7 @@ Lwt.return () ) ) - ) |> ignore; + ); let box_open_time = Unix.gettimeofday () in diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/tray_icon.ml zeroinstall-injector-2.7/ocaml/gui_gtk/tray_icon.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/tray_icon.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/tray_icon.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** The system tray notification icon (used for background updates) *) open Support.Common +open Gtk_common class tray_icon systray = let clicked, set_clicked = Lwt.wait () in @@ -47,7 +48,7 @@ if systray then ( let i = GMisc.status_icon_from_icon_name "zeroinstall" in icon <- Some i; - i#connect#activate ~callback:self#activate |> ignore + i#connect#activate ==> self#activate ) else ( Lwt.wakeup set_clicked () ) diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk/trust_box.ml zeroinstall-injector-2.7/ocaml/gui_gtk/trust_box.ml --- zeroinstall-injector-2.6.1/ocaml/gui_gtk/trust_box.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk/trust_box.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ (** A dialog box for confirming whether to trust a feed's GPG key(s). *) open Support.Common +open Gtk_common open Zeroinstall.General module Progress = Zeroinstall.Progress @@ -125,10 +126,10 @@ ~buttons:GWindow.Buttons.ok_cancel ~position:`CENTER () in - box#connect#response ~callback:(function + box#connect#response ==> (function | `OK -> Lwt.wakeup set_result true; box#destroy () | `DELETE_EVENT | `CANCEL -> Lwt.wakeup set_result false; box#destroy () - ) |> ignore; + ); box#show (); result in match unknown with @@ -248,15 +249,15 @@ ~label:"_Trust this key" () in trust_checkboxes := (fpr, checkbox) :: !trust_checkboxes; page#pack ~expand:false ~fill:true (checkbox :> GObj.widget); - checkbox#connect#toggled ~callback:(fun _cb -> update_ok_button ()) |> ignore; + checkbox#connect#toggled ==> (fun _cb -> update_ok_button ()); let tab_label = (GMisc.label ~text:name () :> GObj.widget) in - notebook#append_page ~tab_label (page :> GObj.widget) |> ignore; + append_page notebook ~tab_label (page :> GObj.widget); ); (List.hd !trust_checkboxes |> snd)#set_active true; vbox#pack ~expand:true ~fill:true (notebook :> GObj.widget); - dialog#connect#response ~callback:(function + dialog#connect#response ==> (function | `OK -> let to_trust = !trust_checkboxes |> U.filter_map (fun (fpr, box) -> if box#active then Some fpr else None @@ -273,7 +274,7 @@ ) | `DELETE_EVENT | `CANCEL -> Lwt.wakeup set_result []; dialog#destroy () | `HELP -> confirm_keys_help#display - ) |> ignore; + ); dialog#show (); result diff -Nru zeroinstall-injector-2.6.1/ocaml/gui_gtk.mlpack zeroinstall-injector-2.7/ocaml/gui_gtk.mlpack --- zeroinstall-injector-2.6.1/ocaml/gui_gtk.mlpack 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/gui_gtk.mlpack 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ Cache_explorer_box Component_box Component_tree +Gtk_common Gtk_utils Gui_gtk_plugin Gui_progress diff -Nru zeroinstall-injector-2.6.1/ocaml/main.ml zeroinstall-injector-2.7/ocaml/main.ml --- zeroinstall-injector-2.6.1/ocaml/main.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/main.ml 2014-05-25 09:29:17.000000000 +0000 @@ -29,21 +29,6 @@ Printf.fprintf stderr "(wrote crash logs to %s)\n" log_file let main (system:system) : unit = -IFDEF HAVE_GTK THEN - (* Install Lwt<->Glib integration in case we need the GUI. - * LWT <= 2.4.4 is buggy (https://github.com/ocsigen/lwt/issues/25) so we have - * to be careful... *) - if system#platform.Platform.os = "Linux" then ( - (* On Linux: - * - lwt_into_glib mode hangs for LWT <= 2.4.4 - * - glib_into_lwt works on all versions, so use that *) - Lwt_glib.install ~mode:`glib_into_lwt () - ) else ( - (* Otherwise, glib_into_lwt never works, so use lwt_into_glib (and require LWT > 2.4.4). *) - Lwt_glib.install ~mode:`lwt_into_glib () - ) -ENDIF; - begin match system#getenv "ZEROINSTALL_CRASH_LOGS" with | Some dir when dir <> "" -> Support.Logging.set_crash_logs_handler (crash_handler system dir) | _ -> () end; diff -Nru zeroinstall-injector-2.6.1/ocaml/Makefile zeroinstall-injector-2.7/ocaml/Makefile --- zeroinstall-injector-2.6.1/ocaml/Makefile 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/Makefile 2014-05-25 09:29:17.000000000 +0000 @@ -1,13 +1,16 @@ OCAML_BUILDDIR=../build/ocaml TYPE=native DEBUG=-cflags -g -OCAMLBUILD=ocamlbuild -j 0 ${DEBUG} -use-ocamlfind -build-dir "${OCAML_BUILDDIR}" +OCAMLBUILD=ocamlbuild -j 0 ${DEBUG} -build-dir "${OCAML_BUILDDIR}" ifeq ($(OS), Windows_NT) WINDOWS_LIBS = $(shell dirname $(shell which ocamlc)) OCAMLBUILDFLAGS = -lflag -cclib -lflag -lshell32 endif -MS_SDK:="/cygdrive/c/Program Files/Microsoft SDKs/Windows/v7.0/Bin" TEST_BINARY=${OCAML_BUILDDIR}/tests/test.$(TYPE) +# Windows only: Set WINDRES, if it is neither called i686-w64-mingw32-windres.exe (i686) +# nor x86_64-w64-mingw32-windres.exe (x86_64). +# WINDRES=i686-w64-windres +# export WINDRES .PHONY: all ocaml doc clean tags test @@ -26,12 +29,9 @@ if [ "$(OS)" = "Windows_NT" ];then make ocaml_windows; else make ocaml_posix; fi # For static Windows version, we also need the runenv.native helper. -# Also, we need an XML manifest, or Windows 7 won't run it because it has "install" in its name. ocaml_windows: cp ${OCAML_BUILDDIR}/static_0install.$(TYPE) ${OCAML_BUILDDIR}/0install.exe cp ${OCAML_BUILDDIR}/runenv.native ${OCAML_BUILDDIR}/0install-runenv.exe - ${MS_SDK}/mt.exe -nologo -manifest 0install.exe.manifest -outputresource:"${OCAML_BUILDDIR}/0install.exe;#1" - ${MS_SDK}/mt.exe -nologo -manifest 0install.exe.manifest -outputresource:"${OCAML_BUILDDIR}/0install-runenv.exe;#1" ln -f "${OCAML_BUILDDIR}/0install.exe" "${OCAML_BUILDDIR}/0launch.exe" cp "${WINDOWS_LIBS}/libeay32.dll" "${WINDOWS_LIBS}/ssleay32.dll" "${OCAML_BUILDDIR}" diff -Nru zeroinstall-injector-2.6.1/ocaml/man.ml zeroinstall-injector-2.7/ocaml/man.ml --- zeroinstall-injector-2.6.1/ocaml/man.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/man.ml 2014-05-25 09:29:17.000000000 +0000 @@ -51,8 +51,8 @@ let manpath = impl_path +/ mandir in if U.is_dir system manpath then ( (* Note: unlike "man -M", this also copes with LANG settings... *) - let env = Env.copy_current_env system in - Zeroinstall.Env.putenv "MANPATH" manpath env; + let env = Env.create system#environment in + Env.put env "MANPATH" manpath; exec_man config ~env:(Env.to_array env) [prog_name]; ) ); diff -Nru zeroinstall-injector-2.6.1/ocaml/.merlin zeroinstall-injector-2.7/ocaml/.merlin --- zeroinstall-injector-2.6.1/ocaml/.merlin 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/.merlin 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,11 @@ +B _build/ +B _build/zeroinstall +B _build/support +B _build/gui_gtk +S . +S ocaml +S support +S zeroinstall +S gui_gtk +PKG yojson xmlm str lwt lwt.unix lwt.react lwt.preemptive extlib curl dynlink lablgtk2 +EXT lwt diff -Nru zeroinstall-injector-2.6.1/ocaml/myocamlbuild.ml zeroinstall-injector-2.7/ocaml/myocamlbuild.ml --- zeroinstall-injector-2.6.1/ocaml/myocamlbuild.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/myocamlbuild.ml 2014-05-25 09:29:17.000000000 +0000 @@ -22,13 +22,19 @@ } let get_info package = - let c_out, c_in, c_err = Unix.open_process_full ("ocamlfind query -format '%v\n%d' " ^ package) (Unix.environment ()) in + (* Windows can't handle newlines or tabs in the format string, so use ASCII unit separator. *) + let c_out, c_in, c_err = Unix.open_process_full ("ocamlfind query -format %v\x1f%d " ^ package) (Unix.environment ()) in let info = try - let version = input_line c_out in - let dir = input_line c_out in - (* Printf.printf "version(%s) = %s\n" package v; *) - if version = "" then None else Some {version; dir} + let record = input_line c_out in + let sep = String.index record '\x1f' in + let dir_len = String.length record - sep - 1 in + let dir_len = + if record.[sep + dir_len] = '\r' then dir_len - 1 else dir_len in + let version = String.sub record 0 sep in + let dir = String.sub record (sep + 1) dir_len in + (* Printf.printf "version(%s) = %s\n" package version; *) + Some {version; dir} with End_of_file -> None in match Unix.close_process_full (c_out, c_in, c_err) with | Unix.WEXITED 0 -> info @@ -49,6 +55,21 @@ let add x xs = xs := A x :: !xs +let windres = + match on_windows with + | false -> "" + | true -> + try + match Sys.getenv "WINDRES" with + | "" -> raise Not_found + | x -> x + with + | Not_found -> + if Sys.word_size = 32 then + "i686-w64-mingw32-windres.exe" + else + "x86_64-w64-mingw32-windres.exe" + let () = let v = Sys.ocaml_version in let first_dot = String.index v '.' in @@ -96,6 +117,8 @@ flag ["link"; "ocaml"; "byte"] (A"-custom"); dispatch (function + | Before_options -> + Options.use_ocamlfind := true; | After_rules -> rule "Build everything (native)" ~prod:"all-native.otarget" @@ -107,16 +130,44 @@ ~deps:byte_targets (fun _ _ -> Command.Nop); + if on_windows then ( + (* We need an XML manifest, or Windows 7 won't run it because it has "install" in its name. *) + rule ".rc.o" ~deps:["%.rc";"%.manifest"] ~prod:"%.o" + (fun env _ -> + let rc = env "%.rc" and o = env "%.o" in + Cmd (S [P windres;A "--input-format";A "rc";A "--input";P rc; + A "--output-format";A "coff";A "--output"; Px o])) + ); + if use_dbus then tag_any ["package(obus,obus.notification,obus.network-manager)"]; pdep ["link"] "linkdep_win" (fun param -> if on_windows then [param] else []); pdep ["link"] "link" (fun param -> [param]); + let have_ocurl_lwt = + match get_info "curl" with + | Some {version; dir = _} -> parse_version version >= [0; 7; 1] + | None -> failwith "Missing curl!" in + + let have_sha = get_info "sha" <> None in + + if have_ocurl_lwt then + flag ["link"] (S [A"-package"; A"curl.lwt"]); + + if not have_ocurl_lwt || not have_sha then ( + flag ["compile"] (S [A"-package"; A"ssl"]); + flag ["link"] (S [A"-package"; A"ssl"]); + ); + begin match gtk_dir with | Some gtk_dir -> + let lwt_dir = + match get_info "lwt.glib" with + | Some {version=_; dir} -> dir + | None -> failwith "lablgtk2 is present, but missing lwt.glib dependency!" in (* ("-thread" is needed on Ubuntu 13.04 for some reason, even though it's in the _tags too) *) - flag ["library"; "native"; "link_gtk"] (S [A"-thread"; A (gtk_dir / "lablgtk.cmxa")]); - flag ["library"; "byte"; "link_gtk"] (S [A"-thread"; A (gtk_dir / "lablgtk.cma")]); + flag ["library"; "native"; "link_gtk"] (S [A"-thread"; A (gtk_dir / "lablgtk.cmxa"); A (lwt_dir / "lwt-glib.cmxa")]); + flag ["library"; "byte"; "link_gtk"] (S [A"-thread"; A (gtk_dir / "lablgtk.cma"); A (lwt_dir / "lwt-glib.cma")]); | None -> () end; (* We use mypp rather than camlp4of because if you pass -pp and -ppopt to ocamlfind @@ -126,13 +177,23 @@ if (major_version < 4 || (major_version == 4 && minor_version < 1)) then add "-DOCAML_LT_4_01" defines_portable; if use_dbus then add "-DHAVE_DBUS" defines_portable; if gtk_dir <> None then add "-DHAVE_GTK" defines_portable; + if have_ocurl_lwt then add "-DHAVE_OCURL_LWT" defines_portable; + + if have_sha then ( + (* Use "sha" package instead of libcrypto *) + add "-DHAVE_SHA" defines_portable; + flag ["compile"; "link_crypto"] (S [A"-ccopt"; A"-DHAVE_SHA"]); + flag ["compile"; "ocaml"] (S [A"-package"; A"sha"]); + flag ["link"] (S [A"-package"; A"sha"]); + ) else ( + print_endline "sha (ocaml-sha) not found; using OpenSSL instead" + ); let defines_native = ref !defines_portable in if on_windows then add "-DWINDOWS" defines_native; if gtk_dir <> None then ( let add_glib tag = - flag ["ocaml"; tag] (S[A"-package"; A "lwt.glib"]); flag ["ocaml"; tag] (S[A"-package"; A "dynlink"]) in List.iter add_glib ["compile"; "ocamldep"; "doc"; "link"; "infer_interface"] ); diff -Nru zeroinstall-injector-2.6.1/ocaml/options.mli zeroinstall-injector-2.7/ocaml/options.mli --- zeroinstall-injector-2.6.1/ocaml/options.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/options.mli 2014-05-25 09:29:17.000000000 +0000 @@ -71,6 +71,7 @@ trust_db : Zeroinstall.Trust.trust_db; set_use_gui : Support.Common.yes_no_maybe -> unit; use_gui : Support.Common.yes_no_maybe; + release : unit; (** Call this to release any open connections held by the download pool. *) > type global_settings = { diff -Nru zeroinstall-injector-2.6.1/ocaml/remove_feed.ml zeroinstall-injector-2.7/ocaml/remove_feed.ml --- zeroinstall-injector-2.6.1/ocaml/remove_feed.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/remove_feed.ml 2014-05-25 09:29:17.000000000 +0000 @@ -20,11 +20,11 @@ | [feed_url] -> let print fmt = Support.Utils.print config.system fmt in print "Feed '%s':" feed_url; - let user_import = G.canonical_iface_uri config.system feed_url |> Zeroinstall.Feed_url.master_feed_of_iface in + let user_import = G.canonical_feed_url config.system feed_url in Add_feed.edit_feeds_interactive config `remove user_import | [iface; feed_src] -> let iface = G.canonical_iface_uri config.system iface in - let feed_src = G.canonical_iface_uri config.system feed_src |> Zeroinstall.Feed_url.master_feed_of_iface in + let feed_src = G.canonical_feed_url config.system feed_src in let user_import = Zeroinstall.Feed.make_user_import feed_src in let iface_config = FC.load_iface_config config iface in diff -Nru zeroinstall-injector-2.6.1/ocaml/sample_client.py zeroinstall-injector-2.7/ocaml/sample_client.py --- zeroinstall-injector-2.6.1/ocaml/sample_client.py 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/sample_client.py 2014-05-25 09:29:17.000000000 +0000 @@ -20,7 +20,7 @@ print("Usage: %s IFACE" % sys.argv[0]) sys.exit(1) -slave_args = ["./0install", "--console", "slave", "2.6"] +slave_args = ["./0install", "--console", "slave", "2.7"] if verbosity > 1: slave_args.append("-v") c = subprocess.Popen(slave_args, stdin = subprocess.PIPE, stdout = subprocess.PIPE) @@ -124,8 +124,9 @@ #"message": "I need this because ...", } -def show_selections(status, result): +def show_selections(status, result, info): print(status) + print(info) print(result) sys.exit(0) diff -Nru zeroinstall-injector-2.6.1/ocaml/search.ml zeroinstall-injector-2.7/ocaml/search.ml --- zeroinstall-injector-2.6.1/ocaml/search.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/search.ml 2014-05-25 09:29:17.000000000 +0000 @@ -26,7 +26,7 @@ log_info "Fetching %s..." url; let switch = Lwt_switch.create () in try - let result = (tools#download_pool tools#ui#watcher#monitor)#download ~switch url in + let result = (tools#download_pool#with_monitor tools#ui#watcher#monitor)#download ~switch url in match Lwt_main.run result with | `aborted_by_user -> () | `network_failure msg -> raise_safe "%s" msg diff -Nru zeroinstall-injector-2.6.1/ocaml/slave.ml zeroinstall-injector-2.7/ocaml/slave.ml --- zeroinstall-injector-2.6.1/ocaml/slave.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/slave.ml 2014-05-25 09:29:17.000000000 +0000 @@ -11,7 +11,6 @@ module Q = Support.Qdom module J = Yojson.Basic module JC = Zeroinstall.Json_connection -module H = Zeroinstall.Helpers module Ui = Zeroinstall.Ui module Progress = Zeroinstall.Progress @@ -107,22 +106,48 @@ table |> Hashtbl.iter (fun name _ -> log_warning "Unexpected requirements field '%s'!" name); reqs -let register_handlers options connection = - let ui = make_ui options.config connection options.tools#use_gui in - - let do_select = function - | [`Assoc reqs; `Bool refresh] -> - let requirements = parse_requirements reqs in - lwt resp = - try_lwt - match_lwt ui#run_solver options.tools `Select_only requirements ~refresh with - | `Aborted_by_user -> `List [`String "aborted-by-user"] |> Lwt.return - | `Success sels -> `WithXML (`List [`String "ok"], Zeroinstall.Selections.as_xml sels) |> Lwt.return - with Safe_exception (msg, _) -> `List [`String "fail"; `String msg] |> Lwt.return in - resp |> Lwt.return - | _ -> raise JC.Bad_request in - - connection#register_handler "select" do_select +let select options (ui:Zeroinstall.Ui.ui_handler) requirements refresh = + let success ~sels ~stale = + let info = `Assoc [ + "stale", `Bool stale; + ] in + let json : JC.J.json = `List [`String "ok"; info] in + `WithXML (json, Zeroinstall.Selections.as_xml sels) |> Lwt.return in + + let select_with_refresh refresh = + match_lwt ui#run_solver options.tools `Select_only requirements ~refresh with + | `Success sels -> success ~sels ~stale:false + | `Aborted_by_user -> `List [`String "aborted-by-user"] |> Lwt.return in + + if refresh || options.tools#use_gui = Yes then select_with_refresh refresh + else ( + let feed_provider = new Zeroinstall.Feed_provider_impl.feed_provider options.config options.tools#distro in + match Zeroinstall.Solver.solve_for options.config feed_provider requirements with + | (false, _results) -> + log_info "Quick solve failed; can't select without updating feeds"; + select_with_refresh true + | (true, results) -> + let sels = results#get_selections in + success ~sels ~stale:feed_provider#have_stale_feeds + ) + +(* Note: this function only supports the latest API. Previous APIs are handled using wrappers. *) +let handle_request options ui = function + | "select", [`Assoc reqs; `Bool refresh] -> begin + let requirements = parse_requirements reqs in + try_lwt select options ui requirements refresh + with Safe_exception (msg, _) -> `List [`String "fail"; `String msg] |> Lwt.return end + | _ -> raise JC.Bad_request + +(* Wrap for 2.6. Convert 2.6 requests and responses to/from 2.7 format. *) +let wrap_for_2_6 next (op, args) = + match op with + | "select" -> + (* Strip out the new "status" response for old clients *) + begin match_lwt next (op, args) with + | `WithXML (`List [`String "ok"; _info], xml) -> `WithXML (`List [`String "ok"], xml) |> Lwt.return + | x -> Lwt.return x end; + | _ -> next (op, args) let handle options flags args = Support.Argparse.iter_options flags (Common_options.process_common_option options); @@ -135,8 +160,17 @@ raise_safe "Minimum supported API version is 2.6"; let api_version = min requested_api_version Zeroinstall.About.parsed_version in - let connection = new JC.json_connection ~from_peer:Lwt_io.stdin ~to_peer:Lwt_io.stdout in - register_handlers options connection; + let handler, set_handler = Lwt.wait () in + let connection = new JC.json_connection ~from_peer:Lwt_io.stdin ~to_peer:Lwt_io.stdout handler in + let ui = make_ui options.config connection options.tools#use_gui in + + let handle_request = handle_request options ui in + let handle_request = + if api_version <= V.parse_version "2.6" then wrap_for_2_6 handle_request + else handle_request in + + Lwt.wakeup set_handler handle_request; + connection#notify "set-api-version" [`String (V.format_version api_version)] |> Lwt_main.run; Lwt_main.run connection#run; diff -Nru zeroinstall-injector-2.6.1/ocaml/support/argparse.ml zeroinstall-injector-2.7/ocaml/support/argparse.ml --- zeroinstall-injector-2.6.1/ocaml/support/argparse.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/argparse.ml 2014-05-25 09:29:17.000000000 +0000 @@ -28,7 +28,7 @@ let is_empty stream = None = Stream.peek stream -type 'a option_value = (string * 'a) +type 'a parsed_options = (string * 'a) list type ('a,'b) argparse_spec = { options_spec : ('a,'b) opt_spec list; @@ -201,7 +201,7 @@ List.map parse_option raw_options -let iter_options (options : 'a option_value list) fn = +let iter_options options fn = let process (actual_opt, value) = try fn value with Safe_exception _ as ex -> reraise_with_context ex "... processing option '%s'" actual_opt diff -Nru zeroinstall-injector-2.6.1/ocaml/support/argparse.mli zeroinstall-injector-2.7/ocaml/support/argparse.mli --- zeroinstall-injector-2.6.1/ocaml/support/argparse.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/argparse.mli 2014-05-25 09:29:17.000000000 +0000 @@ -34,16 +34,12 @@ method parse : string list -> 'a end -(* [option names], n_args, help text, [arg types] +(* [option names], n_args, help text, parser 'a is the type of the tags, 'b is the type of arg types. - The callback gets the argument stream (use this for options which take a variable number of arguments) - and a list of values (one for each declared argument). - *) + The parser gets the argument stream (use this for options which take a variable number of arguments) + and a list of values (one for each declared argument). *) type ('a, 'b) opt_spec = string list * int * string * ('a, 'b) option_parser -(* actual option used, parsed option *) -type 'a option_value = string * 'a - type ('a, 'b) argparse_spec = { options_spec : ('a, 'b) opt_spec list; no_more_options : string list -> bool; @@ -59,8 +55,12 @@ (** [cword] is the index in [input_args] that we are trying to complete, or None if we're not completing. *) val read_args : ?cword:int -> ('a, 'b) argparse_spec -> string list -> raw_option list * string list * 'b complete -val parse_options : ('a, 'b) opt_spec list -> raw_option list -> (string * 'a) list -val iter_options : 'a option_value list -> ('a -> unit) -> unit +type 'a parsed_options + +val parse_options : ('a, 'b) opt_spec list -> raw_option list -> 'a parsed_options + +(** Invoke the callback on each option. If it raises [Safe_exception], add the name of the option to the error message. *) +val iter_options : 'a parsed_options -> ('a -> unit) -> unit (** {2 Handy wrappers for option handlers} *) diff -Nru zeroinstall-injector-2.6.1/ocaml/support/hash.ml zeroinstall-injector-2.7/ocaml/support/hash.ml --- zeroinstall-injector-2.6.1/ocaml/support/hash.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/hash.ml 2014-05-25 09:29:17.000000000 +0000 @@ -4,30 +4,82 @@ (** Secure hashes. *) -type digest_context -external evp_md_ctx_init : string -> digest_context = "ocaml_EVP_MD_CTX_init" -external evp_digest_update : digest_context -> string -> unit = "ocaml_DigestUpdate" -external evp_digest_final_ex : digest_context -> string = "ocaml_DigestFinal_ex" +class type digest_context = + object + method update : string -> unit + + (** Return the final digest as an ASCII string. The context cannot be used after this. *) + method to_hex : string + + (** Return the final digest as a binary string. The context cannot be used after this. *) + method to_bin : string + end + +IFDEF HAVE_SHA THEN +open Common + +(* Implementation using the "sha" package *) + +module type DIGEST = + sig + type ctx + type t + val init: unit -> ctx + val update_string : ctx -> string -> unit + val finalize : ctx -> t + val to_bin : t -> string + val to_hex : t -> string + end + +let make_context (module D : DIGEST) = + let ctx = D.init () in + object + method update data = D.update_string ctx data + method to_bin = D.finalize ctx |> D.to_bin + method to_hex = D.finalize ctx |> D.to_hex + end + +let create = function + | "sha1" -> make_context (module Sha1) + | "sha256" -> make_context (module Sha256) + | x -> raise_safe "Unknown digest type '%s'" x + +ELSE + +(* Implementation using openssl *) + +type evp_context +external evp_md_ctx_init : string -> evp_context = "ocaml_EVP_MD_CTX_init" +external evp_digest_update : evp_context -> string -> unit = "ocaml_DigestUpdate" +external evp_digest_final_ex : evp_context -> string = "ocaml_DigestFinal_ex" let hex_chars = "0123456789abcdef" -let base32_chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" -let create = evp_md_ctx_init -let update = evp_digest_update +let create alg = + let ctx = evp_md_ctx_init alg in + object + method update = evp_digest_update ctx + method to_bin = evp_digest_final_ex ctx + method to_hex = + let raw_digest = evp_digest_final_ex ctx in + let str_digest = String.create (String.length raw_digest * 2) in + for i = 0 to String.length raw_digest - 1 do + str_digest.[i * 2] <- hex_chars.[(Char.code raw_digest.[i] land 0xf0) lsr 4]; + str_digest.[i * 2 + 1] <- hex_chars.[Char.code raw_digest.[i] land 0xf]; + done; + str_digest + end -(** Return the final digest of [ctx] as an ASCII string. [ctx] cannot be used after this. *) -let hex_digest ctx = - let raw_digest = evp_digest_final_ex ctx in - let str_digest = String.create (String.length raw_digest * 2) in - for i = 0 to String.length raw_digest - 1 do - str_digest.[i * 2] <- hex_chars.[(Char.code raw_digest.[i] land 0xf0) lsr 4]; - str_digest.[i * 2 + 1] <- hex_chars.[Char.code raw_digest.[i] land 0xf]; - done; - str_digest +ENDIF + +let hex_digest ctx = ctx#to_hex +let update ctx = ctx#update + +let base32_chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" (** Return the digest as a base-32-encoded ASCII string (with no padding characters) *) let b32_digest ctx = - let raw_digest = evp_digest_final_ex ctx in + let raw_digest = ctx#to_bin in let str_digest = String.create ((String.length raw_digest * 8 + 4) / 5) in let in_byte = ref 0 in let in_bit = ref 3 in @@ -57,5 +109,5 @@ let rec read () = match input ch buf 0 (String.length buf) with | 0 -> () - | n -> update ctx (String.sub buf 0 n); read () in + | n -> ctx#update (String.sub buf 0 n); read () in read () diff -Nru zeroinstall-injector-2.6.1/ocaml/support/hash.mli zeroinstall-injector-2.7/ocaml/support/hash.mli --- zeroinstall-injector-2.6.1/ocaml/support/hash.mli 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/hash.mli 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,23 @@ +(* Copyright (C) 2014, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** Secure hashes. *) + +type digest_context + +(** Create a new context from an algorithm name. + * Supported names are "sha1" and "sha256". *) +val create : string -> digest_context + +(** Add bytes to a context. *) +val update : digest_context -> string -> unit + +(** Return the final digest of [ctx] as an ASCII string. [ctx] cannot be used after this. *) +val hex_digest : digest_context -> string + +(** Return the digest as a base-32-encoded ASCII string (with no padding characters) *) +val b32_digest : digest_context -> string + +(** Read until the end of the channel, adding each byte to the digest. *) +val update_from_channel : digest_context -> in_channel -> unit diff -Nru zeroinstall-injector-2.6.1/ocaml/support/locale.ml zeroinstall-injector-2.7/ocaml/support/locale.ml --- zeroinstall-injector-2.6.1/ocaml/support/locale.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/locale.ml 2014-05-25 09:29:17.000000000 +0000 @@ -36,16 +36,17 @@ (** Get the users preferred language(s), most preferred first. The default is always included. See: http://www.gnu.org/software/gettext/manual/html_mono/gettext.html#The-LANGUAGE-variable *) let get_langs ?(default=("en", Some "gb")) (system:system) = + let get var = + match system#getenv var with + | None | Some "" -> None + | v -> v in + let lang = - match system#getenv "LC_ALL" with - | Some lang -> lang - | None -> - match system#getenv "LC_MESSAGES" with - | Some lang -> lang - | None -> - match system#getenv "LANG" with - | Some lang -> lang - | None -> "C" in + get "LC_ALL" |? lazy ( + get "LC_MESSAGES" |? lazy ( + get "LANG" |? lazy "C" + )) in + let langs = if lang = "C" then [] diff -Nru zeroinstall-injector-2.6.1/ocaml/support/locale.mli zeroinstall-injector-2.7/ocaml/support/locale.mli --- zeroinstall-injector-2.6.1/ocaml/support/locale.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/locale.mli 2014-05-25 09:29:17.000000000 +0000 @@ -9,19 +9,13 @@ type lang_spec = (string * string option) (* Langauge, country *) -module LangType : - sig - type t = lang_spec - val compare : lang_spec -> lang_spec -> int - end - -module LangMap : (Map.S with type key = LangType.t) +module LangMap : (Map.S with type key = lang_spec) val parse_lang : string -> lang_spec option val format_lang : lang_spec -> string -(** Get the users preferred language(s), most preferred first. The default is always included. +(** Get the user's preferred language(s), most preferred first. The default is always included. See: http://www.gnu.org/software/gettext/manual/html_mono/gettext.html#The-LANGUAGE-variable *) val get_langs : ?default:lang_spec -> Common.system -> lang_spec list diff -Nru zeroinstall-injector-2.6.1/ocaml/support/logging.ml zeroinstall-injector-2.7/ocaml/support/logging.ml --- zeroinstall-injector-2.6.1/ocaml/support/logging.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/logging.ml 2014-05-25 09:29:17.000000000 +0000 @@ -37,35 +37,28 @@ let will_log level = level >= !threshold -class type handler = - object - method handle : ?ex:exn -> level -> string -> unit - end - -let console_handler = - object (_ : handler) - method handle ?ex level msg = - - begin match !clear_fn with - | None -> () - | Some fn -> - fn (); - clear_fn := None end; - - let term = if ex = None then "\n" else ": " in - output_string stderr (string_of_level level ^ ": " ^ msg ^ term); - let () = - match ex with - | None -> () - | Some ex -> - output_string stderr (Printexc.to_string ex); - if Printexc.backtrace_status () then ( - output_string stderr "\n"; - Printexc.print_backtrace stderr - ); - output_string stderr "\n" in - flush stderr - end +type handler = ?ex:exn -> level -> string -> unit + +let console_handler ?ex level msg = + begin match !clear_fn with + | None -> () + | Some fn -> + fn (); + clear_fn := None end; + + let term = if ex = None then "\n" else ": " in + output_string stderr (string_of_level level ^ ": " ^ msg ^ term); + let () = + match ex with + | None -> () + | Some ex -> + output_string stderr (Printexc.to_string ex); + if Printexc.backtrace_status () then ( + output_string stderr "\n"; + Printexc.print_backtrace stderr + ); + output_string stderr "\n" in + flush stderr let handler = ref console_handler @@ -78,7 +71,7 @@ let log level ?ex = let do_log msg = if level >= !threshold then - !handler#handle ?ex level msg; + !handler ?ex level msg; match !crash_log with | None -> () diff -Nru zeroinstall-injector-2.6.1/ocaml/support/logging.mli zeroinstall-injector-2.7/ocaml/support/logging.mli --- zeroinstall-injector-2.6.1/ocaml/support/logging.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/logging.mli 2014-05-25 09:29:17.000000000 +0000 @@ -19,10 +19,7 @@ (* If set, we call this before logging anything and then set it to None. This is used to clear progress displays. *) val clear_fn : (unit -> unit) option ref -class type handler = - object - method handle : ?ex:exn -> level -> string -> unit - end +type handler = ?ex:exn -> level -> string -> unit val handler : handler ref diff -Nru zeroinstall-injector-2.6.1/ocaml/support/qdom.ml zeroinstall-injector-2.7/ocaml/support/qdom.ml --- zeroinstall-injector-2.6.1/ocaml/support/qdom.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/qdom.ml 2014-05-25 09:29:17.000000000 +0000 @@ -13,22 +13,48 @@ module AttrMap = struct - include Map.Make(AttrType) + module M = Map.Make(AttrType) + + type t = (string * string) M.t (* (prefix_hint, value) *) + + let empty = M.empty let get name attrs = - try Some (find name attrs |> snd) + try Some (M.find name attrs |> snd) with Not_found -> None let get_no_ns name attrs = get ("", name) attrs let add_no_ns name value attrs = - add ("", name) ("", value) attrs - end + M.add ("", name) ("", value) attrs + + let add ~prefix name value = + M.add name (prefix, value) -type attr_value = (string * string) (* (prefix_hint, value) *) + let singleton name value = + M.singleton ("", name) ("", value) -type attributes = attr_value AttrMap.t + let remove = M.remove + let mem = M.mem + + let compare a b = + M.compare (fun (_, a_value) (_, b_value) -> String.compare a_value b_value) a b + + let add_all overrides attrs = + M.merge (fun _key old override -> + match old, override with + | _, (Some _ as override) -> override + | (Some _ as old), None -> old + | None, None -> None + ) attrs overrides + + let iter_values fn attrs = + M.iter (fun tag (_prefix, value) -> fn tag value) attrs + + let map fn attrs = + M.map (fun (hint, value) -> (hint, fn value)) attrs + end (* Used in diagnostic messages to show the source of an element. *) type source_hint = @@ -40,7 +66,7 @@ and element = { prefix_hint : string; tag: Xmlm.name; - attrs: attributes; + attrs: AttrMap.t; child_nodes: element list; text_before: string; (** The text node immediately before us *) last_text_inside: string; (** The last text node inside us with no following element *) @@ -80,9 +106,9 @@ ) in (* Now we have all the prefixes defined, attach them to the remaining attributes *) let map = ref AttrMap.empty in - non_ns_attrs |> List.iter (fun ((ns, _name) as pair, value) -> + non_ns_attrs |> List.iter (fun ((ns, name), value) -> let prefix = if ns = "" then ns else get_hint ns in - map := !map |> AttrMap.add pair (prefix, value) + map := !map |> AttrMap.add ~prefix (ns, name) value ); !map in @@ -117,9 +143,9 @@ ) with Xmlm.Error ((line, col), err) -> raise_safe "[%d:%d] %s" line col (Xmlm.error_message err) -let parse_file (system:system) path = +let parse_file (system:system) ?name path = try path |> system#with_open_in [Open_rdonly; Open_binary] (fun ch -> - parse_input (Some path) (Xmlm.make_input (`Channel ch)) + parse_input (Some (name |> default path)) (Xmlm.make_input (`Channel ch)) ) with | Safe_exception _ as ex -> reraise_with_context ex "... parsing XML document %s" path @@ -188,7 +214,7 @@ let rec collect_hints elem = let ns = fst elem.tag in if ns <> default_ns then add_hint ns elem.prefix_hint; (* (we ensure default_ns is bound at the end) *) - elem.attrs |> AttrMap.iter (fun (ns, _) (prefix_hint, _) -> + elem.attrs |> AttrMap.M.iter (fun (ns, _) (prefix_hint, _) -> if ns <> "" then add_hint ns prefix_hint ); elem.child_nodes |> List.iter collect_hints in @@ -205,13 +231,13 @@ let root_attrs = ref root.attrs in prefix_of_ns |> Hashtbl.iter (fun ns prefix -> let prefix = if prefix = "" then "xmlns" else prefix in - root_attrs := !root_attrs |> AttrMap.add (Xmlm.ns_xmlns, prefix) ("", ns) + root_attrs := !root_attrs |> AttrMap.add ~prefix:"" (Xmlm.ns_xmlns, prefix) ns (* (prefix "" is unused) *) ); Xmlm.output o @@ `Dtd None; let rec output_node node = if node.text_before <> "" then Xmlm.output o @@ `Data node.text_before; - Xmlm.output o @@ `El_start (node.tag, node.attrs |> AttrMap.bindings |> List.map (fun (k, (_, v)) -> (k, v))); + Xmlm.output o @@ `El_start (node.tag, node.attrs |> AttrMap.M.bindings |> List.map (fun (k, (_, v)) -> (k, v))); List.iter output_node node.child_nodes; if node.last_text_inside <> "" then Xmlm.output o @@ `Data node.last_text_inside; Xmlm.output o @@ `El_end in @@ -233,25 +259,8 @@ } in process "\n" {root with text_before = ""} -let attrs_of_list xs = - let map = ref AttrMap.empty in - xs |> List.iter (fun (name, value) -> - map := !map |> AttrMap.add_no_ns name value - ); - !map - -let iter_attrs fn elem = - AttrMap.iter (fun tag (_prefix, value) -> fn tag value) elem.attrs - exception Compare_result of int -module AttrSet = Set.Make( - struct - type t = (Xmlm.name * string) - let compare a b = compare a b - end -) - let compare_nodes ~ignore_whitespace a b = let test x y = match compare x y with @@ -261,8 +270,7 @@ let rec find_diff a b = test a.tag b.tag; let () = - (* (we compare namespace URIs but not prefix hints) *) - match AttrMap.compare (fun (_, a_value) (_, b_value) -> String.compare a_value b_value) a.attrs b.attrs with + match AttrMap.compare a.attrs b.attrs with | 0 -> () | x -> raise (Compare_result x) in if ignore_whitespace then ( @@ -286,14 +294,15 @@ if elem_ns = Ns.ns then Some name else None - let map ~f node tag = + let map ?name f elem = let rec loop = function | [] -> [] - | (node::xs) -> - if node.tag = (Ns.ns, tag) - then let result = f node in result :: loop xs + | (elem::xs) -> + let (ns, elem_name) = elem.tag in + if ns = Ns.ns && (name = None || name = Some elem_name) + then f elem :: loop xs else loop xs in - loop node.child_nodes + loop elem.child_nodes let filter_map fn node = let rec loop = function diff -Nru zeroinstall-injector-2.6.1/ocaml/support/qdom.mli zeroinstall-injector-2.7/ocaml/support/qdom.mli --- zeroinstall-injector-2.6.1/ocaml/support/qdom.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/qdom.mli 2014-05-25 09:29:17.000000000 +0000 @@ -1,29 +1,53 @@ (** XML processing *) type source_hint -type attr_value = (string * string) (* (prefix_hint, value) *) module AttrType : sig type t = Xmlm.name val compare : 'a -> 'a -> int end module AttrMap : sig - include Map.S with type key = AttrType.t + (** Maps Xmlm.names to (prefix-hint, value) pairs *) + type t - (* Add a binding with no namespace (and, therefore, no prefix) *) - val add_no_ns : string -> string -> attr_value t -> attr_value t + val empty : t - (* Get the value of this (namespaced) attribute, as an option. *) - val get : Xmlm.name -> attr_value t -> string option + (** Add a binding with a namespace and suggested prefix. *) + val add : prefix:string -> Xmlm.name -> string -> t -> t - (* Simple wrapper for [get] for non-namespaced attributes. *) - val get_no_ns : string -> attr_value t -> string option + (** Add a binding with no namespace (and, therefore, no prefix) *) + val add_no_ns : string -> string -> t -> t + + (** Convenience function to create a map with a single non-namespaced attribute. *) + val singleton : string -> string -> t + + (** Get the value of this (namespaced) attribute, as an option. *) + val get : Xmlm.name -> t -> string option + + (** Simple wrapper for [get] for non-namespaced attributes. *) + val get_no_ns : string -> t -> string option + + val remove : Xmlm.name -> t -> t + + (** Compare maps, ignoring prefix hints. *) + val compare : t -> t -> int + + val mem : Xmlm.name -> t -> bool + + (** [add_all overrides old_attrs] returns a map with all the bindings of + * [overrides] plus all non-conflicting bindings from [old_attrs]. *) + val add_all : t -> t -> t + + (** Iterate over the values (ignoring the prefix hints) *) + val iter_values : (Xmlm.name -> string -> unit) -> t -> unit + + (** Map attribute values. *) + val map : (string -> string) -> t -> t end -type attributes = (string * string) AttrMap.t (** An XML element node (and nearby text). *) type element = { prefix_hint : string; (* Suggested prefix when serialising this element *) tag: Xmlm.name; - attrs: attributes; + attrs: AttrMap.t; child_nodes: element list; text_before: string; (** The text node immediately before us *) last_text_inside: string; (** The last text node inside us with no following element *) @@ -35,8 +59,10 @@ (** @raise Safe_exception if the XML is not well formed. *) val parse_input : string option -> Xmlm.input -> element -(** @raise Safe_exception if the XML is not well formed. *) -val parse_file : Common.system -> string -> element +(** Load XML from a file. + * @param name: optional name to report in location messages (if missing, uses file name) + * @raise Safe_exception if the XML is not well formed. *) +val parse_file : Common.system -> ?name:string -> string -> element (** {2 Helper functions} *) @@ -71,11 +97,6 @@ (e.g. [Bob] do not have their content changed. *) val reindent : element -> element -(* Convert a list of (name, value) pairs into a set of (non-namespaced) attributes. *) -val attrs_of_list : (string * string) list -> attributes - -val iter_attrs : (Xmlm.name -> string -> unit) -> element -> unit - module type NsType = sig val ns : string val prefix_hint : string (* A suggested namespace prefix (for serialisation) *) @@ -92,8 +113,8 @@ val fold_left : f:('a -> element -> 'a) -> 'a -> element -> string -> 'a - (** Apply [fn] to each child node in our namespace with local name [tag] *) - val map : f:(element -> 'a) -> element -> string -> 'a list + (** Apply [fn] to each child node in our namespace with local name [name] *) + val map : ?name:string -> (element -> 'a) -> element -> 'a list (** Apply [fn] to each child node in our namespace *) val filter_map : (element -> 'a option) -> element -> 'a list @@ -112,5 +133,5 @@ (** Create a new element in our namespace. * @param source_hint will be used in error messages *) - val make : ?source_hint:element -> ?attrs:attributes -> ?child_nodes:element list -> string -> element + val make : ?source_hint:element -> ?attrs:AttrMap.t -> ?child_nodes:element list -> string -> element end diff -Nru zeroinstall-injector-2.6.1/ocaml/support/sat.ml zeroinstall-injector-2.7/ocaml/support/sat.ml --- zeroinstall-injector-2.6.1/ocaml/support/sat.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/sat.ml 2014-05-25 09:29:17.000000000 +0000 @@ -2,6 +2,10 @@ * See the README file for details, or visit http://0install.net. *) +open Common + +let () = ignore on_windows + (** A general purpose SAT solver. *) (** The design of this solver is very heavily based on the one described in @@ -25,6 +29,24 @@ val to_string : t -> string end +module VarID : + sig + type t + type mint + val compare : t -> t -> int + val make_mint : unit -> mint + val issue : mint -> t + end = struct + type t = int + type mint = int ref + let compare (a:int) (b:int) = compare a b + let make_mint () = ref 0 + let issue mint = + let i = !mint in + incr mint; + i + end + module MakeSAT(User : USER) = struct type var_value = True | False | Undecided @@ -34,58 +56,84 @@ print_endline ("sat: " ^ msg) in Printf.ksprintf do_print fmt - type lit = int - type var = int - type solution = var -> bool + type sign = Pos | Neg - class type clause = - object + type clause = < (* [lit] is now [True]. Add any new deductions. @return false if there is a conflict. *) - method propagate : lit -> bool + propagate : lit -> bool; (** Why are we causing a conflict? @return a list of literals which caused the problem by all being True. *) - method calc_reason : lit list + calc_reason : lit list; (** Which literals caused [lit] to have its current value? @return a list of literals which caused the problem by all being True. *) - method calc_reason_for : lit -> lit list + calc_reason_for : lit -> lit list; (** For debugging *) - method to_string : string - end + to_string : string; + > (** The reason why a literal is set. *) - type reason = + and reason = | Clause of clause (* the clause that caused this literal to be true *) | External of string (* set externally (input fact or decider choice) *) - (** Using an array of VarInfo objects is less efficient than using multiple arrays, but - easier for me to understand. *) - type var_info = { - mutable value : var_value; (* True/False/Undecided *) - mutable reason : reason option; (* The constraint that implied our value, if True or False *) - mutable level: int; (* The decision level at which we got a value (when not Undecided) *) - mutable undo: (lit -> unit) list; (* Functions to call if we become unbound (by backtracking) *) - obj: User.t; (* The object this corresponds to (for our caller and for debugging) *) + and var = { + id : VarID.t; (* A unique ID, used to test identity *) + mutable value : var_value; (* True/False/Undecided *) + mutable reason : reason option; (* The constraint that implied our value, if True or False *) + mutable level: int; (* The decision level at which we got a value (when not Undecided) *) + mutable undo: (lit -> unit) list; (* Functions to call if we become unbound (by backtracking) *) + watch_queue : clause Queue.t; (* Clauses to notify when var becomes True *) + neg_watch_queue : clause Queue.t; (* Clauses to notify when var becomes False *) + obj: User.t; (* The object this corresponds to (for our caller and for debugging) *) } - let make_var obj = { - value = Undecided; - reason = None; - level = -1; - undo = []; - obj; - } + and lit = (sign * var) + + let lit_equal (s1, v1) (s2, v2) = + s1 == s2 && v1 == v2 + + module VarSet = Set.Make( + struct + type t = var + let compare a b = VarID.compare a.id b.id + end + ) + + module LitSet = Set.Make( + struct + type t = lit + let compare (s1, v1) (s2, v2) = + match VarID.compare v1.id v2.id with + | 0 -> compare s1 s2 + | x -> x + end + ) + + type solution = lit -> bool + + let make_var id obj = { + id; + value = Undecided; + reason = None; + level = -1; + undo = []; + watch_queue = Queue.create (); + neg_watch_queue = Queue.create (); + obj; + } type sat_problem = { + id_maker : VarID.mint; + (* Propagation *) - watches : clause Queue.t DynArray.t; (* watches[2i,2i+1] = constraints to check when literal[i] becomes True/False *) + mutable vars : var list; propQ : lit Queue.t; (* propagation queue *) (* Assignments *) - assigns : var_info DynArray.t; (* the current values of the variables *) mutable trail : lit list; (* order of assignments, most recent first *) mutable trail_lim : int list; (* decision levels (len(trail) at each decision) *) @@ -98,30 +146,24 @@ | Clause clause -> clause#to_string | External msg -> msg - (* Variables are numbered from 0 - Literals have the same number as the corresponding variable, - except that for negatives they are (-1-v): - - Variable Literal not(Literal) - 0 0 -1 - 1 1 -2 - *) - let neg lit = -1 - lit - - let var_of_lit lit = if lit >= 0 then lit else neg lit - - let watch_index lit = - if lit >= 0 then lit * 2 - else neg lit * 2 + 1 + let neg = function + | (Pos, var) -> (Neg, var) + | (Neg, var) -> (Pos, var) + + let var_of_lit (_, var) = var + + let watch_queue = function + | (Pos, var) -> var.watch_queue + | (Neg, var) -> var.neg_watch_queue let remove_duplicates lits = - let seen = Hashtbl.create (List.length lits) in + let seen = ref LitSet.empty in let rec find_unique = function | [] -> [] - | (x::xs) when Hashtbl.mem seen x -> find_unique xs + | (x::xs) when LitSet.mem x !seen -> find_unique xs | (x::xs) -> - Hashtbl.add seen x true; + seen := LitSet.add x !seen; x :: find_unique xs in find_unique lits @@ -136,9 +178,6 @@ | False -> "false" | Undecided -> "undecided" - let string_of_var info = - Printf.sprintf "%s=%s" (User.to_string info.obj) (string_of_value info.value) - exception ConflictingClause of clause exception SolveDone of solution option @@ -149,10 +188,10 @@ let create () = if debug then log_debug "--- new SAT problem ---"; { - watches = DynArray.make 100; + id_maker = VarID.make_mint (); + vars = []; propQ = Queue.create (); - assigns = DynArray.make 100; trail = []; trail_lim = []; @@ -160,39 +199,37 @@ set_to_false = false; } - (* For nicer if debug then log_debug messages *) - let name_lit problem lit = - if lit >= 0 then - User.to_string (DynArray.get problem.assigns lit).obj - else - let info = DynArray.get problem.assigns (neg lit) in - Printf.sprintf "not(%s)" (User.to_string info.obj) - - let string_of_lits problem lits = - "[" ^ (String.concat ", " (List.map (name_lit problem) lits)) ^ "]" - - let lit_value (problem:sat_problem) lit = - if lit >= 0 then ( - (DynArray.get problem.assigns lit).value - ) else ( - match (DynArray.get problem.assigns (neg lit)).value with - | Undecided -> Undecided - | True -> False - | False -> True - ) + (* For nicer log_debug messages *) + let name_lit (sign, var) = + let name = User.to_string var.obj in + match sign with + | Pos -> name + | Neg -> Printf.sprintf "not(%s)" name + + let string_of_lits lits = + "[" ^ (String.concat ", " (List.map name_lit lits)) ^ "]" + + let lit_value (sign, var) = + match sign with + | Pos -> var.value + | Neg -> + match var.value with + | Undecided -> Undecided + | True -> False + | False -> True - let get_varinfo_for_lit problem lit = - DynArray.get problem.assigns (var_of_lit lit) + let get_user_data_for_lit lit = + (var_of_lit lit).obj (* Why is [lit] assigned the way it is? For debugging. *) - let explain_reason problem lit = + let explain_reason lit = let show_lit_assignment l = - let info = get_varinfo_for_lit problem l in + let info = var_of_lit l in (User.to_string info.obj) ^ "=" ^ (string_of_value info.value) in - let value = lit_value problem lit in + let value = lit_value lit in if value = Undecided then "undecided!" else ( - let info = get_varinfo_for_lit problem lit in + let info = var_of_lit lit in let reason = match info.reason with | None -> "no reason (BUG)" @@ -206,28 +243,25 @@ let get_decision_level problem = List.length problem.trail_lim - let add_variable problem obj : var = + let add_variable problem obj : lit = (* if debug then log_debug "add_variable('%s')" obj; *) - let index = DynArray.length problem.assigns in - - DynArray.add problem.watches (Queue.create ()); (* Add watch lists for X and not(X) *) - DynArray.add problem.watches (Queue.create ()); - - DynArray.add problem.assigns (make_var obj); - index + let i = VarID.issue problem.id_maker in + let var = make_var i obj in + problem.vars <- var :: problem.vars; + (Pos, var) (* [lit] is now [True]. [reason] is the clause that is asserting this. @return [false] if this immediately causes a conflict. *) let enqueue problem lit reason = - if debug then log_debug "enqueue: %s (%s)" (name_lit problem lit) (string_of_reason reason); - let old_value = lit_value problem lit in + if debug then log_debug "enqueue: %s (%s)" (name_lit lit) (string_of_reason reason); + let old_value = lit_value lit in match old_value with | False -> false (* Conflict *) | True -> true (* Already set (shouldn't happen) *) | Undecided -> - let var_info = get_varinfo_for_lit problem lit in - var_info.value <- if lit < 0 then False else True; + let var_info = var_of_lit lit in + var_info.value <- if fst lit == Neg then False else True; var_info.level <- get_decision_level problem; var_info.reason <- Some reason; @@ -241,8 +275,8 @@ match problem.trail with | [] -> assert false | lit :: rest -> - (* if debug then log_debug "(pop %s)" (name_lit problem lit); *) - let var_info = get_varinfo_for_lit problem lit in + (* if debug then log_debug "(pop %s)" (name_lit lit); *) + let var_info = var_of_lit lit in var_info.value <- Undecided; var_info.reason <- None; var_info.level <- -1; @@ -255,7 +289,7 @@ done let cancel problem = - let n_this_level = List.length problem.trail - (List.hd problem.trail_lim) in + let n_this_level = List.length problem.trail - List.hd problem.trail_lim in if debug then log_debug "backtracking from level %d (%d assignments)" (get_decision_level problem) n_this_level; for _i = 1 to n_this_level do undo_one problem; @@ -274,11 +308,11 @@ try while not (Queue.is_empty problem.propQ) do let lit = Queue.take problem.propQ in - let wi = watch_index lit in - let old_watches = DynArray.get problem.watches wi in - DynArray.set problem.watches wi (Queue.create ()); + let old_watches = Queue.create () in + let watches = watch_queue lit in + Queue.transfer watches old_watches; - (* if debug then log_debug "%s -> True : watches: %d" (name_lit problem lit) (Queue.length old_watches); *) + (* if debug then log_debug "%s -> True : watches: %d" (name_lit lit) (Queue.length old_watches); *) (* Notifiy all watchers *) while not (Queue.is_empty old_watches) do @@ -287,7 +321,7 @@ (* Conflict *) (* Re-add remaining watches *) - Queue.transfer old_watches (DynArray.get problem.watches wi); + Queue.transfer old_watches watches; (* No point processing the rest of the queue as we'll have to backtrack now. *) @@ -304,12 +338,12 @@ problem.toplevel_conflict <- true (* Call [clause#propagate lit] when lit becomes True *) - let watch_lit problem lit clause = - (* if debug then log_debug "%s is watching for %s to become True" clause#to_string (name_lit problem lit); *) - Queue.add clause (DynArray.get problem.watches (watch_index lit)) + let watch_lit lit clause = + (* if debug then log_debug "%s is watching for %s to become True" clause#to_string (name_lit lit); *) + Queue.add clause (watch_queue lit) - class union_clause problem lits = - object (self : #clause) + let union_clause problem lits = + object (self : clause) (* Try to infer new facts. We can do this only when all of our literals are False except one, which is undecided. That is, @@ -332,29 +366,29 @@ - value[lits[0]] = Undecided | True - value[lits[1]] = False If it's the other way around, just swap them before we start. *) - if lits.(0) = neg lit then swap lits 0 1; + if lit_equal lits.(0) (neg lit) then swap lits 0 1; - if lit_value problem lits.(0) = True then ( + if lit_value lits.(0) = True then ( (* We're already satisfied. Do nothing. *) - watch_lit problem lit (self :> clause); + watch_lit lit (self :> clause); true ) else ( - assert (lit_value problem lits.(1) = False); + assert (lit_value lits.(1) = False); (* Find a new literal to watch now that lits[1] is resolved, *) (* swap it with lits[1], and start watching it. *) let rec find_not_false i = if i = Array.length lits then ( (* Only lits[0], is now undefined, so set it to True. *) - watch_lit problem lit (self :> clause); + watch_lit lit (self :> clause); enqueue problem lits.(0) (Clause (self :> clause)) ) else ( - match lit_value problem lits.(i) with + match lit_value lits.(i) with | Undecided | True -> (* If it's True then we've already done our job, so this means we don't get notified unless we backtrack, which is fine. *) swap lits 1 i; - watch_lit problem (neg lits.(1)) (self :> clause); + watch_lit (neg lits.(1)) (self :> clause); true | False -> find_not_false (i + 1) ) in @@ -362,25 +396,24 @@ ) (* We can only cause a conflict if all our lits are False, so they're all the cause. - e.g. if we are "A or B or not(C)" then "not(A) and not(B) and C" causes a conflict. - *) + e.g. if we are "A or B or not(C)" then "not(A) and not(B) and C" causes a conflict. *) method calc_reason = List.map neg (Array.to_list lits) (** Which literals caused [lit] to have its current value? *) method calc_reason_for lit = - assert (lit = lits.(0)); + assert (lit_equal lit lits.(0)); (* The cause is everything except lit. *) let rec get_cause i = if i = Array.length lits then [] else ( let l = lits.(i) in - if l = lit then get_cause (i + 1) + if lit_equal l lit then get_cause (i + 1) else neg l :: get_cause (i + 1) ) in get_cause 0 method to_string = - Printf.sprintf "" (String.concat ", " (Array.to_list (Array.map (name_lit problem) lits))) + Printf.sprintf "" (String.concat ", " (Array.to_list (Array.map name_lit lits))) end exception Conflict @@ -391,16 +424,15 @@ (* The single literal from our set that is True. We store this explicitly because the decider needs to know quickly. *) let current = ref None in - let lit_val = lit_value problem in - object (self : #clause) + object (self) method propagate lit = (* Re-add ourselves to the watch list. (we we won't get any more notifications unless we backtrack, in which case we'd need to get back on the list anyway) *) - watch_lit problem lit (self :> clause); + watch_lit lit (self :> clause); (* value[lit] has just become true *) - assert (lit_val lit = True); + assert (lit_value lit = True); (* if debug then log_debug("%s: noticed %s has become True" % (self, self.solver.name_lit(lit))) *) @@ -416,26 +448,28 @@ (* If we later backtrack, unset current *) let undo lit = - if debug then log_debug "(backtracking: no longer selected %s)" (name_lit problem lit); - assert (Some lit = !current); + if debug then log_debug "(backtracking: no longer selected %s)" (name_lit lit); + begin match !current with + | Some l -> assert (lit_equal lit l) + | None -> assert false end; current := None in - let var_info = get_varinfo_for_lit problem lit in + let var_info = var_of_lit lit in var_info.undo <- undo :: var_info.undo; try (* We set all other literals to False. *) - ListLabels.iter lits ~f:(fun l -> - match lit_val l with - | True when l <> lit -> + lits |> List.iter (fun l -> + match lit_value l with + | True when not (lit_equal l lit) -> (* Due to queuing, we might get called with current = None and two versions already selected. *) - if debug then log_debug "CONFLICT: already selected %s" (name_lit problem l); + if debug then log_debug "CONFLICT: already selected %s" (name_lit l); raise Conflict | Undecided -> (* Since one of our lits is already true, all unknown ones can be set to False. *) if not (enqueue problem (neg l) (Clause (self :> clause))) then ( - if debug then log_debug "CONFLICT: enqueue failed for %s" (name_lit problem (neg l)); + if debug then log_debug "CONFLICT: enqueue failed for %s" (name_lit (neg l)); raise Conflict (* Can't happen, since we already checked we're Undecided *) ) | _ -> () @@ -448,7 +482,7 @@ (* Find two True literals *) let rec find_two found = function | [] -> assert false (* Don't know why! *) - | (x::xs) when lit_val x <> True -> find_two found xs + | (x::xs) when lit_value x <> True -> find_two found xs | (x::xs) -> match found with | None -> find_two (Some x) xs @@ -459,18 +493,18 @@ (** Which literals caused [lit] to have its current value? *) method calc_reason_for lit = (* Find the True literal. Any true literal other than [lit] would do. *) - [List.find (fun l -> l <> lit && lit_val l = True) lits] + [List.find (fun l -> not (lit_equal l lit) && lit_value l = True) lits] method best_undecided = - (* if debug then log_debug "best_undecided: %s" (string_of_lits problem lits); *) - try Some (List.find (fun l -> lit_val l = Undecided) lits) + (* if debug then log_debug "best_undecided: %s" (string_of_lits lits); *) + try Some (List.find (fun l -> lit_value l = Undecided) lits) with Not_found -> None method get_selected = !current method to_string = - Printf.sprintf "" (string_of_lits problem lits) + Printf.sprintf "" (string_of_lits lits) end let get_best_undecided clause = clause#best_undecided @@ -490,7 +524,7 @@ AddedFact (enqueue problem lit reason) | lits -> let lits = Array.of_list lits in - let clause = new union_clause problem lits in + let clause = union_clause problem lits in if learnt then ( (* lits[0] is Undecided because we just backtracked. @@ -499,7 +533,7 @@ let best_i = ref 1 in for i = 0 to (Array.length lits) - 1 do let lit = lits.(i) in - let level = (get_varinfo_for_lit problem lit).level in + let level = (var_of_lit lit).level in if level > !best_level then ( best_level := level; best_i := i @@ -510,7 +544,7 @@ (* Watch the first two literals in the clause (both must be undefined at this point). *) - let watch i = watch_lit problem (neg lits.(i)) clause in + let watch i = watch_lit (neg lits.(i)) clause in watch 0; watch 1; @@ -521,21 +555,21 @@ if List.length lits = 0 then ( problem.toplevel_conflict <- true; ) else ( - (* if debug then log_debug "at_least_one(%s)" (string_of_lits problem lits); *) + (* if debug then log_debug "at_least_one(%s)" (string_of_lits lits); *) - if List.exists (fun l -> (lit_value problem l) = True) lits then ( + if List.exists (fun l -> (lit_value l) = True) lits then ( (* Trivially true already if any literal is True. *) () ) else ( - let seen = Hashtbl.create (List.length lits) in + let seen = ref LitSet.empty in let rec simplify unique = function | [] -> Some unique - | (x::_) when Hashtbl.mem seen (neg x) -> None (* X or not(X) is always True *) - | (x::xs) when Hashtbl.mem seen x -> simplify unique xs (* Skip duplicates *) - | (x::xs) when lit_value problem x = False -> simplify unique xs (* Skip values known to be False *) + | (x::_) when LitSet.mem (neg x) !seen -> None (* X or not(X) is always True *) + | (x::xs) when LitSet.mem x !seen -> simplify unique xs (* Skip duplicates *) + | (x::xs) when lit_value x = False -> simplify unique xs (* Skip values known to be False *) | (x::xs) -> - Hashtbl.add seen x true; + seen := LitSet.add x !seen; simplify (x :: unique) xs in (* At this point, [unique] contains only [Undefined] literals. *) @@ -554,7 +588,7 @@ let at_most_one problem lits = assert (List.length lits > 0); - (* if debug then log_debug "at_most_one(%s)" (string_of_lits problem lits); *) + (* if debug then log_debug "at_most_one(%s)" (string_of_lits lits); *) (* If we have zero or one literals then we're trivially true and not really needed for the solve. However, Zero Install @@ -570,11 +604,11 @@ (* Ignore any literals already known to be False. If any are True then they're enqueued and we'll process them soon. *) - let lits = List.filter (fun l -> lit_value problem l <> False) lits in + let lits = List.filter (fun l -> lit_value l <> False) lits in let clause = new at_most_one_clause problem lits in - List.iter (fun l -> watch_lit problem l (clause :> clause)) lits; + List.iter (fun l -> watch_lit l (clause :> clause)) lits; clause @@ -623,15 +657,15 @@ *) let learnt = ref [] in (* The general rule we're learning *) let btlevel = ref 0 in (* The deepest decision in learnt *) - let seen = Hashtbl.create 10 in (* The variables involved in the conflict *) + let seen = ref VarSet.empty in (* The variables involved in the conflict *) - let counter = ref 0 in (* The number of pending variables to check *) + let counter = ref 0 in (* The number of pending variables to check *) (* [outcome] was caused by the literals [p_reason] all being True. Follow the causes back, adding anything decided before this level to [learnt]. When we get bored, return the literal we were processing at the time. *) let rec follow_causes p_reason outcome = - if debug then log_debug "because %s => %s" (String.concat " and " (List.map (name_lit problem) p_reason)) outcome; + if debug then log_debug "because %s => %s" (String.concat " and " (List.map name_lit p_reason)) outcome; (* p_reason is in the form (A and B and ...) *) @@ -641,25 +675,24 @@ mark it for expansion - otherwise, add it to learnt *) - ListLabels.iter p_reason ~f:(fun lit -> + p_reason |> List.iter (fun lit -> let var = var_of_lit lit in - if not (Hashtbl.mem seen var) then ( - Hashtbl.add seen var true; - let var_info = get_varinfo_for_lit problem lit in + if not (VarSet.mem var !seen) then ( + seen := VarSet.add var !seen; + let var_info = var_of_lit lit in if var_info.level = get_decision_level problem then ( (* We deduced this var since the last decision. It must be in [trail], so we'll get to it soon. Remember not to stop until we've processed it. *) - (* if debug then log_debug "(will look at %s soon)" (name_lit problem lit); *) - counter := !counter + 1 + (* if debug then log_debug "(will look at %s soon)" (name_lit lit); *) + incr counter ) else if var_info.level > 0 then ( (* We won't expand lit, just remember it. - (we could expand it if it's not a decision, but - apparently not doing so is useful) *) - (* if debug then log_debug "Can't follow %s past a decision point" (name_lit problem lit); *) + (we could expand it if it's not a decision, but apparently not doing so is useful) *) + (* if debug then log_debug "Can't follow %s past a decision point" (name_lit lit); *) learnt := neg lit :: !learnt; btlevel := max !btlevel (var_info.level) - ) (* else if debug then log_debug "Input fact: %s" (name_lit problem lit) *) + ) (* else if debug then log_debug "Input fact: %s" (name_lit lit) *) ) (* else we already considered the cause of this assignment *) ); @@ -684,11 +717,10 @@ let rec next_interesting () = let lit = List.hd problem.trail in let var = var_of_lit lit in - let var_info = get_varinfo_for_lit problem lit in - let reason = var_info.reason in + let reason = var.reason in undo_one problem; - if not (Hashtbl.mem seen var) then ( - (* if debug then log_debug "(irrelevant: %s)" (name_lit problem lit); *) + if not (VarSet.mem var !seen) then ( + (* if debug then log_debug "(irrelevant: %s)" (name_lit lit); *) next_interesting (); ) else ( (reason, lit) @@ -697,16 +729,15 @@ (* [reason] is the reason why [p] is True (i.e. it enqueued it). *) (* [p] is the literal we want to expand now. *) - counter := !counter - 1; + decr counter; if !counter > 0 then ( - let cause = (match reason with + let cause = match reason with | Some (Clause c) -> c | Some (External msg) -> failwith msg (* Can't happen *) - | None -> failwith "No reason!" (* Can't happen *) - ) in + | None -> failwith "No reason!" in (* Can't happen *) let p_reason = cause#calc_reason_for p in - let outcome = name_lit problem p in + let outcome = name_lit p in if debug then log_debug "why did %s lead to %s?" cause#to_string outcome; follow_causes p_reason outcome ) else ( @@ -729,13 +760,12 @@ directly to the learnt clause. *) let learnt = neg p :: !learnt in - if debug then log_debug "learnt: %s" (String.concat " or " (List.map (name_lit problem) learnt)); + if debug then log_debug "learnt: %s" (String.concat " or " (List.map name_lit learnt)); (learnt, !btlevel) - let get_assignment solution var = - assert (var >= 0); - match (get_varinfo_for_lit solution var).value with + let get_assignment var = + match lit_value var with | True -> true | False -> false | Undecided -> assert false @@ -754,37 +784,36 @@ | None -> ( (* No conflicts *) (* if debug then log_debug "new state: %s" problem.assigns *) + + (* Pick a variable and try assigning it one way. + If it leads to a conflict, we'll backtrack and + try it the other way. *) let undecided = - try DynArray.index_of (fun info -> info.value = Undecided) problem.assigns + try List.find (fun info -> info.value = Undecided) problem.vars with Not_found -> (* Everything is assigned without conflicts *) (* if debug then log_debug "SUCCESS!"; *) - raise (SolveDone (Some (get_assignment problem))) in - (* Pick a variable and try assigning it one way. - If it leads to a conflict, we'll backtrack and - try it the other way. *) + raise (SolveDone (Some get_assignment)) in let lit = if problem.set_to_false then ( - (* Printf.printf "%s -> false\n" (name_lit problem undecided); *) - neg undecided + (* Printf.printf "%s -> false\n" (name_lit undecided); *) + (Neg, undecided) ) else ( match decide () with | Some lit -> lit | None -> (* Switch to set_to_false mode (until we backtrack). *) - let lit = neg undecided in problem.set_to_false <- true; - let var_info = get_varinfo_for_lit problem lit in let undo _ = problem.set_to_false <- false in - var_info.undo <- undo :: var_info.undo; - (* Printf.printf "%s -> false\n" (name_lit problem undecided); *) - lit + undecided.undo <- undo :: undecided.undo; + (* Printf.printf "%s -> false\n" (name_lit undecided); *) + (Neg, undecided) ) in - if debug then log_debug "TRYING: %s" (name_lit problem lit); - let old = lit_value problem lit in - if (old <> Undecided) then - failwith ("Decider chose already-decided variable: " ^ (name_lit problem lit) ^ " was " ^ (string_of_value old)); - problem.trail_lim <- (List.length problem.trail) :: problem.trail_lim; + if debug then log_debug "TRYING: %s" (name_lit lit); + let old = lit_value lit in + if old <> Undecided then + failwith ("Decider chose already-decided variable: " ^ (name_lit lit) ^ " was " ^ (string_of_value old)); + problem.trail_lim <- List.length problem.trail :: problem.trail_lim; let r = enqueue problem lit (External "considering") in assert r ) diff -Nru zeroinstall-injector-2.6.1/ocaml/support/sat.mli zeroinstall-injector-2.7/ocaml/support/sat.mli --- zeroinstall-injector-2.6.1/ocaml/support/sat.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/sat.mli 2014-05-25 09:29:17.000000000 +0000 @@ -16,16 +16,13 @@ (** A SAT problem consists of a set of variables and a set of clauses which must be satisfied. *) type sat_problem - type var - val add_variable : sat_problem -> User.t -> var type var_value = True | False | Undecided - (** A literal is either a variable (e.g. [A]) or a negated variable ([not A]). - A variable is equal to its corresponding positive literal (so [var] is really - a subset of [lit]). *) - type lit = var + (** A literal is either a variable (e.g. [A]) or a negated variable ([not A]). *) + type lit val neg : lit -> lit - val var_of_lit : lit -> var + + val add_variable : sat_problem -> User.t -> lit (** A clause is a boolean expression made up of literals. e.g. [A and B and not(C)] *) type clause @@ -35,8 +32,8 @@ (* Create a problem. *) val create : unit -> sat_problem - (** Get the assignment for this variable in the discovered solution. *) - type solution = var -> bool + (** Get the assignment for this literal in the discovered solution. *) + type solution = lit -> bool (** Indicate that the problem is unsolvable, before even starting. This is a convenience feature so that clients don't need a separate code path for problems they discover @@ -75,21 +72,13 @@ (** {2 Debugging} *) type reason = Clause of clause | External of string - type var_info = { - mutable value : var_value; - mutable reason : reason option; - mutable level : int; - mutable undo : (lit -> unit) list; - obj : User.t; - } val string_of_clause : clause -> string val string_of_reason : reason -> string val string_of_value : var_value -> string - val string_of_var : var_info -> string - val name_lit : sat_problem -> lit -> string - val string_of_lits : sat_problem -> lit list -> string - val lit_value : sat_problem -> lit -> var_value - val get_varinfo_for_lit : sat_problem -> lit -> var_info - val explain_reason : sat_problem -> lit -> string + val name_lit : lit -> string + val string_of_lits : lit list -> string + val lit_value : lit -> var_value + val get_user_data_for_lit : lit -> User.t + val explain_reason : lit -> string end diff -Nru zeroinstall-injector-2.6.1/ocaml/support/_tags zeroinstall-injector-2.7/ocaml/support/_tags --- zeroinstall-injector-2.6.1/ocaml/support/_tags 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/_tags 2014-05-25 09:29:17.000000000 +0000 @@ -1,4 +1,4 @@ true: for-pack(Support) - or : mypp + or or : mypp or : syntax(camlp4o), package(lwt.syntax) "windows.cma": dllib(-lwindows) diff -Nru zeroinstall-injector-2.6.1/ocaml/support/utils.ml zeroinstall-injector-2.7/ocaml/support/utils.ml --- zeroinstall-injector-2.6.1/ocaml/support/utils.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/utils.ml 2014-05-25 09:29:17.000000000 +0000 @@ -71,7 +71,7 @@ let makedirs (system:system) path mode = let rec loop path = - match system#lstat path with + match system#stat path with | Some info -> if info.Unix.st_kind = Unix.S_DIR then () else raise_safe "Not a directory: %s" path @@ -551,3 +551,9 @@ log_warning ~ex "Unhandled error from Lwt thread"; Lwt.fail ex ) ) + +let with_switch fn = + let switch = Lwt_switch.create () in + Lwt.finalize + (fun () -> fn switch) + (fun () -> Lwt_switch.turn_off switch) diff -Nru zeroinstall-injector-2.6.1/ocaml/support/utils.mli zeroinstall-injector-2.7/ocaml/support/utils.mli --- zeroinstall-injector-2.6.1/ocaml/support/utils.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/support/utils.mli 2014-05-25 09:29:17.000000000 +0000 @@ -126,3 +126,6 @@ (** Don't wait for the result of this Lwt thread. * If it throws an exception, log it. *) val async : (unit -> unit Lwt.t) -> unit + +(** Create a switch, run [fn switch], then finally turn it off. *) +val with_switch : (Lwt_switch.t -> 'a Lwt.t) -> 'a Lwt.t diff -Nru zeroinstall-injector-2.6.1/ocaml/_tags zeroinstall-injector-2.7/ocaml/_tags --- zeroinstall-injector-2.6.1/ocaml/_tags 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/_tags 2014-05-25 09:29:17.000000000 +0000 @@ -1,5 +1,5 @@ false: profile -true: debug, annot, package(yojson,xmlm,str,lwt,lwt.unix,lwt.react,lwt.preemptive,extlib,curl,ssl,dynlink), thread +true: debug, bin_annot, package(yojson,xmlm,str,lwt,lwt.unix,lwt.react,lwt.preemptive,extlib,curl,dynlink), thread : linkall : package(oUnit) or or : syntax(camlp4o), package(lwt.syntax) @@ -10,4 +10,5 @@ "support": for-pack(Support) "zeroinstall": for-pack(Zeroinstall) "gui_gtk": for-pack(Gui_gtk) - or <**/*.native> or <**/*.byte>: linkdep_win(windows.o), package(unix), link(utils.o) +: link_crypto + or <**/*.native> or <**/*.byte>: linkdep_win(0install.exe.o), linkdep_win(windows.o), package(unix), link(utils.o) diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/fake_system.ml zeroinstall-injector-2.7/ocaml/tests/fake_system.ml --- zeroinstall-injector-2.6.1/ocaml/tests/fake_system.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/fake_system.ml 2014-05-25 09:29:17.000000000 +0000 @@ -268,7 +268,7 @@ method getcwd = match tmpdir with - | None -> "/root" + | None -> if on_windows then "c:\\root" else "/root" | Some _ -> real_system#getcwd method chdir path = @@ -360,7 +360,6 @@ let forward_to_real_log = ref true let real_log = !Support.Logging.handler -let () = Support.Logging.threshold := Support.Logging.Debug class null_ui = object (_ : #Zeroinstall.Ui.ui_handler as 'a) @@ -372,22 +371,29 @@ let null_ui = new null_ui +(* Pools need to be released after each test *) +let download_pools = Queue.create () +let release () = + Queue.iter (fun x -> x#release) download_pools; + Queue.clear download_pools + let make_tools config = let distro = Zeroinstall.Distro_impls.generic_distribution config in let trust_db = new Zeroinstall.Trust.trust_db config in let download_pool = Zeroinstall.Downloader.make_pool ~max_downloads_per_site:2 in + Queue.add download_pool download_pools; object method config = config method distro = distro method trust_db = trust_db method download_pool = download_pool - method downloader = download_pool ignore - method make_fetcher watcher = new Zeroinstall.Fetch.fetcher config trust_db distro download_pool watcher + method downloader = download_pool#with_monitor ignore + method make_fetcher watcher = Zeroinstall.Fetch.make config trust_db distro download_pool watcher method ui = (null_ui :> Zeroinstall.Ui.ui_handler) end let fake_log = - object (_ : #Support.Logging.handler) + object val mutable record = [] method reset = @@ -409,7 +415,7 @@ else ( prerr_endline "(showing full log)"; let dump (ex, level, msg) = - real_log#handle ?ex level msg in + real_log ?ex level msg in List.iter dump @@ List.rev record; ) @@ -418,13 +424,13 @@ if not (List.exists (fun (_ex, _lvl, msg) -> Str.string_match re msg 0) record) then raise_safe "Expected log message matching '%s'" expected - method handle ?ex level msg = - if !forward_to_real_log && level > Support.Logging.Info then real_log#handle ?ex level msg; - if false then prerr_endline @@ "LOG: " ^ msg; - record <- (ex, level, msg) :: record + method record x = record <- x :: record end -let () = Support.Logging.handler := (fake_log :> Support.Logging.handler) +let () = Support.Logging.handler := fun ?ex level msg -> + if !forward_to_real_log && level > Support.Logging.Info then real_log ?ex level msg; + if false then prerr_endline @@ "LOG: " ^ msg; + fake_log#record (ex, level, msg) let collect_logging fn = forward_to_real_log := false; @@ -469,6 +475,7 @@ system#putenv "HOME" home; if on_windows then ( system#add_file (src_dir +/ "0install-runenv.exe") (build_dir +/ "0install-runenv.exe"); + system#putenv "PATH" (Sys.getenv "PATH"); ) else ( system#putenv "PATH" @@ (home +/ "bin") ^ ":" ^ (Sys.getenv "PATH"); system#add_file test_0install (build_dir +/ "0install"); diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/server.ml zeroinstall-injector-2.7/ocaml/tests/server.ml --- zeroinstall-injector-2.6.1/ocaml/tests/server.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/server.ml 2014-05-25 09:29:17.000000000 +0000 @@ -35,6 +35,9 @@ | `Unexpected | `Give404 ] +(* Old versions of Curl escape dots *) +let re_escaped_dot = Str.regexp_string "%2E" + let start_server system = let () = log_info "start_server" in let server_socket = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in @@ -57,6 +60,7 @@ port in let handle_request path to_client = + let path = path |> Str.global_replace re_escaped_dot "." in log_info "Handling request for '%s'" path; request_log := path :: !request_log; diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/solves.xml zeroinstall-injector-2.7/ocaml/tests/solves.xml --- zeroinstall-injector-2.6.1/ocaml/tests/solves.xml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/solves.xml 2014-05-25 09:29:17.000000000 +0000 @@ -766,6 +766,31 @@ + + > + OptionalMissing + optional command dependency on a missing interface + + + + + + + + + + + + + + + + + + + + + @@ -816,5 +841,34 @@ + + + + prog + unit-tests need self + + + + + + + + + + + + + + + + + + + + + + + + diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_0install.ml zeroinstall-injector-2.7/ocaml/tests/test_0install.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_0install.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_0install.ml 2014-05-25 09:29:17.000000000 +0000 @@ -591,6 +591,17 @@ let iface_config = FC.load_iface_config config binary_iface in assert_equal 0 @@ List.length iface_config.FC.extra_feeds; + let tmp_feed, ch = Filename.open_temp_file "0install-" "-test" in + feed_dir +/ "Source.xml" |> fake_system#with_open_in [Open_binary] (fun source_ch -> + U.copy_channel source_ch ch; + ); + close_out ch; + let out = run ["add-feed"; binary_iface; tmp_feed] in + assert_str_equal "" out; + Unix.unlink tmp_feed; + let out = run ["remove-feed"; binary_iface; tmp_feed] in + assert_str_equal "" out; + (* todo: move to download tests *) (* with open('Source.xml') as stream: source_feed = stream.read() diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_distro.ml zeroinstall-injector-2.7/ocaml/tests/test_distro.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_distro.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_distro.ml 2014-05-25 09:29:17.000000000 +0000 @@ -82,6 +82,7 @@ ); "arch2">:: Fake_system.with_fake_config (fun (config, _fake_system) -> + skip_if (Sys.os_type = "Win32") "Paths get messed up on Windows"; let arch_db = Test_0install.feed_dir +/ "arch" in let distro = Distro_impls.ArchLinux.arch_distribution ~arch_db config in @@ -95,6 +96,7 @@ ); "slack">:: Fake_system.with_fake_config (fun (config, _fake_system) -> + skip_if (Sys.os_type = "Win32") "Paths get messed up on Windows"; let slackdir = Test_0install.feed_dir +/ "slack" in let packages_dir = slackdir +/ "packages" in let distro = Distro_impls.Slackware.slack_distribution ~packages_dir config in @@ -110,6 +112,7 @@ ); "gentoo">:: Fake_system.with_fake_config (fun (config, _fake_system) -> + skip_if (Sys.os_type = "Win32") "Paths get messed up on Windows"; let pkgdir = Test_0install.feed_dir +/ "gentoo" in let distro = Distro_impls.Gentoo.gentoo_distribution ~pkgdir config in @@ -142,6 +145,7 @@ ); "ports">:: Fake_system.with_fake_config (fun (config, _fake_system) -> + skip_if (Sys.os_type = "Win32") "Paths get messed up on Windows"; let pkg_db = Test_0install.feed_dir +/ "ports" in let distro = Distro_impls.Ports.ports_distribution ~pkg_db config in @@ -153,6 +157,7 @@ ); "mac-ports">:: Fake_system.with_fake_config (fun (config, fake_system) -> + skip_if (Sys.os_type = "Win32") "Paths get messed up on Windows"; fake_system#set_spawn_handler (Some Fake_system.real_spawn_handler); let pkgdir = Test_0install.feed_dir +/ "macports" in let old_path = Unix.getenv "PATH" in @@ -175,7 +180,9 @@ let (config, fake_system) = Fake_system.get_fake_config (Some tmpdir) in let system = (fake_system :> system) in - let python_path = Support.Utils.find_in_path_ex Fake_system.real_system "python" in + let python_path = + Support.Utils.find_in_path Fake_system.real_system "python" + |? lazy (skip_if true "Python not installed"; assert false) in fake_system#add_file python_path python_path; fake_system#set_spawn_handler (Some Fake_system.real_spawn_handler); @@ -203,7 +210,9 @@ let feed = F.parse system root None in let impls = distro#get_impls_for_feed feed in - let host_gobject = find_host impls in + let host_gobject = + try impls |> StringMap.bindings |> List.find is_host |> snd + with Not_found -> skip_if true "No host python-gobject found"; assert false in let () = match host_gobject.props.requires with | [ {dep_importance = Dep_restricts; dep_iface = "http://repo.roscidus.com/python/python"; dep_restrictions = [_]; _ } ] -> () @@ -215,6 +224,7 @@ ); "rpm">:: Fake_system.with_fake_config (fun (config, fake_system) -> + skip_if (Sys.os_type = "Win32") "Paths get messed up on Windows"; let rpmdir = Test_0install.feed_dir +/ "rpm" in let old_path = Unix.getenv "PATH" in Unix.putenv "PATH" (rpmdir ^ ":" ^ old_path); @@ -258,10 +268,16 @@ let impls = to_impl_list @@ rpm#get_impls_for_feed feed in assert_equal 1 (List.length impls); + (* Check escaping works *) + let feed = get_feed "" in + let impls = to_impl_list @@ rpm#get_impls_for_feed feed in + assert_equal 1 (List.length impls); + Unix.putenv "PATH" old_path; ); "debian">:: Fake_system.with_fake_config (fun (config, fake_system) -> + skip_if (Sys.os_type = "Win32") "Paths get messed up on Windows"; let xml = "\n\ \n\ diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_download.ml zeroinstall-injector-2.7/ocaml/tests/test_download.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_download.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_download.ml 2014-05-25 09:29:17.000000000 +0000 @@ -330,7 +330,7 @@ let out = Fake_system.collect_logging (fun () -> run_0install fake_system ["download"; "http://example.com:8000/Hello.xml"; "--xml"] ) in - Fake_system.fake_log#assert_contains "Primary download failed; trying mirror URL 'http://roscidus.com/0mirror/archive/http%3A%23%23example.com%3A8000%23HelloWorld.tgz'"; + Fake_system.fake_log#assert_contains "Primary download failed; trying mirror URL 'http://roscidus.com/0mirror/archive/http%3A%23%23example\\(.\\|%2E\\)com%3A8000%23HelloWorld\\(.\\|%2E\\)tgz'"; let sels = parse_sels out in let sel = StringMap.find_safe "http://example.com:8000/Hello.xml" sels in assert (fake_system#file_exists (expect (get_sel_path config sel) +/ "HelloWorld" +/ "main")) @@ -400,7 +400,7 @@ (* The original archive: *) ".*http://example.com:8000/HelloWorld.tgz"; (* Mirror of original archive: *) - ".*http://roscidus.com/0mirror/archive/http%3A%23%23example.com%3A8000%23HelloWorld.tgz"; + ".*http://roscidus.com/0mirror/archive/http%3A%23%23example\\(.\\|%2E\\)com%3A8000%23HelloWorld\\(.\\|%2E\\)tgz"; (* Mirror of implementation: *) ".*http://roscidus.com/0mirror/feeds/http/example.com:8000/Hello.xml/impl/sha1=3ce644dc725f1d21cfcf02562c76f375944b266a" ] |> List.iter Fake_system.fake_log#assert_contains @@ -418,7 +418,7 @@ ) in Fake_system.fake_log#assert_contains "Primary download failed; trying mirror URL \ - 'http://roscidus.com/0mirror/archive/http%3A%23%23example.com%3A8000%23HelloWorld.tgz'..."; + 'http://roscidus.com/0mirror/archive/http%3A%23%23example\\(.\\|%2E\\)com%3A8000%23HelloWorld\\(.\\|%2E\\)tgz'..."; assert (fake_system#file_exists (path +/ "HelloWorld" +/ "main")) ); diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_driver.ml zeroinstall-injector-2.7/ocaml/tests/test_driver.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_driver.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_driver.ml 2014-05-25 09:29:17.000000000 +0000 @@ -248,8 +248,8 @@ let (ready, result, _fp) = Driver.solve_with_downloads config distro fetcher ~watcher:Fake_system.null_ui#watcher reqs ~force:false ~update_local:false |> Lwt_main.run in assert (ready = true); - let get_ids result = - ZI.map (Selections.as_xml result#get_selections) "selection" ~f:(fun sel -> ZI.get_attribute "id" sel) in + let get_ids result = Selections.as_xml result#get_selections + |> ZI.map ~name:"selection" (ZI.get_attribute "id") in Fake_system.equal_str_lists ["sha1=3ce644dc725f1d21cfcf02562c76f375944b266a"] @@ get_ids result; diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_feed_cache.ml zeroinstall-injector-2.7/ocaml/tests/test_feed_cache.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_feed_cache.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_feed_cache.ml 2014-05-25 09:29:17.000000000 +0000 @@ -58,7 +58,7 @@ trust_db#trust_key "92429807C9853C0744A68B9AAE07828059A53CC1" ~domain:"foo"; let download_pool = Zeroinstall.Downloader.make_pool ~max_downloads_per_site:2 in let distro = Zeroinstall.Distro_impls.generic_distribution config in - let fetcher = new Zeroinstall.Fetch.fetcher config trust_db distro download_pool Fake_system.null_ui in + let fetcher = Zeroinstall.Fetch.make config trust_db distro download_pool Fake_system.null_ui in let foo_signed_xml = U.read_file config.system (Fake_system.tests_dir +/ "foo.xml") in (* Unsigned *) @@ -89,7 +89,7 @@ (* Updated *) let foo_signed_xml_new = U.read_file config.system (Fake_system.tests_dir +/ "foo-new.xml") in - let dryrun_fetcher = new Zeroinstall.Fetch.fetcher {config with dry_run = true} trust_db distro download_pool Fake_system.null_ui in + let dryrun_fetcher = Zeroinstall.Fetch.make {config with dry_run = true} trust_db distro download_pool Fake_system.null_ui in let out = Fake_system.capture_stdout (fun () -> dryrun_fetcher#import_feed feed_url foo_signed_xml_new |> Lwt_main.run; ) in diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_feed.ml zeroinstall-injector-2.7/ocaml/tests/test_feed.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_feed.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_feed.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,6 +5,7 @@ open Support.Common open OUnit open Zeroinstall.General +open Zeroinstall module Q = Support.Qdom module U = Support.Utils @@ -161,15 +162,15 @@ | _ -> assert false ); - let env = Hashtbl.create 10 in + let env = Env.create [| |] in let impls = StringMap.singleton "http://example.com/" ((), Some "/impl") in let check ?old binding = begin match old with - | None -> Hashtbl.remove env "PATH" - | Some old -> Hashtbl.replace env "PATH" old end; + | None -> Env.unset env "PATH" + | Some old -> Env.put env "PATH" old end; B.do_env_binding env impls "http://example.com/" binding; - Hashtbl.find env "PATH" in + Env.get_exn env "PATH" in Fake_system.assert_str_equal "/impl/bin:/bin:/usr/bin" @@ check b0; Fake_system.assert_str_equal "/impl/bin:current" @@ check b0 ~old:"current"; @@ -187,11 +188,11 @@ } in let check ?impl ?old binding = - let env = Hashtbl.create 1 in + let env = Env.create [| |] in let impls = StringMap.singleton "http://example.com/" ((), impl) in - old |> if_some (Hashtbl.replace env binding.B.var_name); + old |> if_some (Env.put env binding.B.var_name); B.do_env_binding env impls "http://example.com/" binding; - Hashtbl.find env binding.B.var_name in + Env.get_exn env binding.B.var_name in Fake_system.assert_str_equal "/impl/lib:/usr/lib" @@ check prepend ~impl:"/impl" ~old:"/usr/lib"; Fake_system.assert_str_equal "/impl/lib" @@ check prepend ~impl:"/impl"; diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_fetch.ml zeroinstall-injector-2.7/ocaml/tests/test_fetch.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_fetch.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_fetch.ml 2014-05-25 09:29:17.000000000 +0000 @@ -47,7 +47,8 @@ let make_dl_tester () = let log = ref [] in let download_pool = D.make_pool ~max_downloads_per_site:2 in - let downloader = download_pool Fake_system.null_ui#monitor in + Queue.add download_pool Fake_system.download_pools; + let downloader = download_pool#with_monitor Fake_system.null_ui#monitor in let waiting = Hashtbl.create 10 in (* Intercept the download and return a new blocker *) @@ -282,7 +283,9 @@ "abort">:: (fun () -> Lwt_main.run ( - let downloader = D.make_pool ~max_downloads_per_site:2 (fun dl -> U.async dl.D.cancel) in + let pool = D.make_pool ~max_downloads_per_site:2 in + Queue.add pool Fake_system.download_pools; + let downloader = pool#with_monitor (fun dl -> U.async dl.D.cancel) in (* Intercept the download and return a new blocker *) let handle_download ?if_slow:_ ?size:_ ?modification_time:_ _ch url = diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_manifest.ml zeroinstall-injector-2.7/ocaml/tests/test_manifest.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_manifest.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_manifest.ml 2014-05-25 09:29:17.000000000 +0000 @@ -26,6 +26,7 @@ ); "old-sha">:: Fake_system.with_fake_config (fun (config, _fake_system) -> + skip_if on_windows "No symlinks"; let system = config.system in let home = U.getenv_ex config.system "HOME" in let mydir = home +/ "MyDir" in @@ -44,6 +45,7 @@ ); "new-sha1">:: Fake_system.with_fake_config (fun (config, _fake_system) -> + skip_if on_windows "No symlinks"; let system = config.system in let home = U.getenv_ex config.system "HOME" in let mydir = home +/ "MyDir" in @@ -77,6 +79,7 @@ ); "new-sha256">:: Fake_system.with_fake_config (fun (config, _fake_system) -> + skip_if on_windows "No symlinks"; let system = config.system in let home = U.getenv_ex config.system "HOME" in let mydir = home +/ "MyDir" in diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test.ml zeroinstall-injector-2.7/ocaml/tests/test.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test.ml 2014-05-25 09:29:17.000000000 +0000 @@ -48,6 +48,11 @@ equal_str_lists ~msg:"PORT-2" ["/mnt/0install/cache"] bd.cache; equal_str_lists ~msg:"PORT-3" ["/mnt/0install/data"] bd.data +let as_list flags = + let lst = ref [] in + Support.Argparse.iter_options flags (fun v -> lst := v :: !lst); + List.rev !lst + let test_option_parsing () = Support.Logging.threshold := Support.Logging.Warning; @@ -96,7 +101,12 @@ let _, flags, args = p_full ["run"; "-wgdb"; "foo"] in equal_str_lists ["run"; "foo"] args; - assert_equal [("-w", `Wrapper "gdb")] flags; + assert_equal [`Wrapper "gdb"] (as_list flags); + begin try + Support.Argparse.iter_options flags (fun _ -> raise_safe "Error!"); + assert false + with Safe_exception ("Error!", ctx) -> + assert_str_equal "... processing option '-w'" (List.hd !ctx) end; let v = fake_system#collect_output (fun () -> ( try ignore @@ p ["-c"; "--version"]; assert false; @@ -106,15 +116,15 @@ let _, flags, args = p_full ["--version"; "1.2"; "run"; "foo"] in equal_str_lists ["run"; "foo"] args; - assert_equal [("--version", `RequireVersion "1.2")] flags; + assert_equal [`RequireVersion "1.2"] (as_list flags); let _, flags, args = p_full ["digest"; "-m"; "archive.tgz"] in equal_str_lists ["digest"; "archive.tgz"] args; - assert_equal [("-m", `ShowManifest)] flags; + assert_equal [`ShowManifest] (as_list flags); let _, flags, args = p_full ["run"; "-m"; "main"; "app"] in equal_str_lists ["run"; "app"] args; - assert_equal [("-m", `MainExecutable "main")] flags + assert_equal [`MainExecutable "main"] (as_list flags) let test_run_real tmpdir = Unix.putenv "ZEROINSTALL_PORTABLE_BASE" tmpdir; @@ -261,6 +271,7 @@ let async_exception = ref None let show_log_on_failure fn () = + Support.Logging.threshold := Support.Logging.Debug; async_exception := None; Zeroinstall.Downloader.interceptor := None; Fake_system.forward_to_real_log := true; @@ -269,6 +280,8 @@ try Fake_system.fake_log#reset; fn (); + Fake_system.release (); + (* Gc.full_major (); *) !async_exception |> if_some (fun ex -> raise ex) with ex -> if U.starts_with (Printexc.to_string ex) "OUnitTest.Skip" then () diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_selections.ml zeroinstall-injector-2.7/ocaml/tests/test_selections.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_selections.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_selections.ml 2014-05-25 09:29:17.000000000 +0000 @@ -31,7 +31,7 @@ let old_sels = {old_sels with Q.child_nodes = old_sels.Q.child_nodes |> List.map (fun sel -> if sel |> ZI.get_attribute "interface" = "http://foo/Source.xml" then - {sel with Q.attrs = Q.AttrMap.add ("http://namespace", "foo") ("foo", "bar") sel.Q.attrs} + {sel with Q.attrs = Q.AttrMap.add ("http://namespace", "foo") ~prefix:"foo" "bar" sel.Q.attrs} else sel ) } diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_solver.ml zeroinstall-injector-2.7/ocaml/tests/test_solver.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_solver.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_solver.ml 2014-05-25 09:29:17.000000000 +0000 @@ -35,13 +35,23 @@ let set_of_attrs elem : string list = let attrs = ref [] in - elem |> Q.iter_attrs (fun (ns, name) value -> + elem.Q.attrs |> Q.AttrMap.iter_values (fun (ns, name) value -> match ns with | "" -> attrs := Printf.sprintf "%s=%s" name value :: !attrs | ns -> attrs := Printf.sprintf "{%s}%s=%s" ns name value :: !attrs ); List.sort compare !attrs +let rec fixup_for_windows elem = + let attrs = elem.Q.attrs |> Q.AttrMap.map (fun value -> + if U.starts_with value "/root/" then "c:\\root\\" ^ U.string_tail value 6 + else if value = "/root" then "c:\\root" + else value + ) in {elem with Q. + attrs; + child_nodes = elem.Q.child_nodes |> List.map fixup_for_windows; + } + let xml_diff exp actual = let open Support.Qdom in let p = Printf.printf in @@ -77,10 +87,9 @@ let rec make_all_downloable node = let open Support.Qdom in if ZI.tag node = Some "implementation" then ( - let attrs = [ - ("size", "100"); - ("href", "http://example.com/download.tgz"); - ] |> Q.attrs_of_list in + let attrs = Q.AttrMap.empty + |> Q.AttrMap.add_no_ns "size" "100" + |> Q.AttrMap.add_no_ns "href" "http://example.com/download.tgz" in let archive = ZI.make ~attrs "archive" in {node with child_nodes = archive :: node.child_nodes} ) else ( @@ -198,6 +207,9 @@ | _ -> Support.Qdom.raise_elem "Unexpected element" child in ZI.iter process test_elem; + (* To test the ... part, we can't log at debug level. *) + Support.Logging.threshold := Support.Logging.Info; + let (ready, result) = Zeroinstall.Solver.solve_for config (feed_provider :> Feed_provider.feed_provider) !reqs in if ready && !fails then assert_failure "Expected solve to fail, but it didn't!"; if not ready && not (!fails) then ( @@ -726,5 +738,6 @@ "solver">::: let root = Support.Qdom.parse_file Fake_system.real_system "tests/solves.xml" in + let root = if on_windows then fixup_for_windows root else root in List.map make_solver_test root.Support.Qdom.child_nodes ] diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_stores.ml zeroinstall-injector-2.7/ocaml/tests/test_stores.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_stores.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_stores.ml 2014-05-25 09:29:17.000000000 +0000 @@ -39,6 +39,8 @@ ); "check-system-store">:: Fake_system.with_fake_config (fun (config, fake_system) -> + skip_if (Sys.os_type = "Unix" && Unix.geteuid () = 0) "Doesn't work when unit-tests are run as root"; + let home = U.getenv_ex fake_system "HOME" in let system_store = home +/ "system_store" in config.stores <- [List.hd config.stores; system_store]; diff -Nru zeroinstall-injector-2.6.1/ocaml/tests/test_versions.ml zeroinstall-injector-2.7/ocaml/tests/test_versions.ml --- zeroinstall-injector-2.6.1/ocaml/tests/test_versions.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/tests/test_versions.ml 2014-05-25 09:29:17.000000000 +0000 @@ -164,6 +164,7 @@ check "93-28.2.2" "93u-28.2.2"; check "7-pre3-2.1.1-3" "7~u3-2.1.1-3"; (* Debian snapshot *) check "7-pre3-2.1.1-pre1-1-2" "7~u3-2.1.1~pre1-1ubuntu2"; + check "0.6.0.9999999999999999" "0.6.0.1206569328141510525648634803928199668821045408958"; assert_equal None (Versions.try_cleanup_distro_version "cvs"); ); diff -Nru zeroinstall-injector-2.6.1/ocaml/utils.c zeroinstall-injector-2.7/ocaml/utils.c --- zeroinstall-injector-2.6.1/ocaml/utils.c 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/utils.c 2014-05-25 09:29:17.000000000 +0000 @@ -13,7 +13,9 @@ #include #include +#ifndef HAVE_SHA #include +#endif #include #ifndef _WIN32 @@ -31,6 +33,13 @@ #include #endif +#ifdef WIN32 +#include +#include +#endif + +#ifndef HAVE_SHA +/* No ocaml-sha; use openssl instead */ #define Ctx_val(v) (*((EVP_MD_CTX**)Data_custom_val(v))) static void finalize_ctx(value block) @@ -50,15 +59,6 @@ custom_compare_ext_default }; -/* Based on OCaml's unix_utimes function. */ -CAMLprim value ocaml_set_mtime(value path, value mtime) { - struct utimbuf times; - times.actime = Double_val(mtime); - times.modtime = Double_val(mtime); - if (utime(String_val(path), ×) == -1) uerror("utimes", path); - return Val_unit; -} - CAMLprim value ocaml_EVP_MD_CTX_init(value v_alg) { CAMLparam1(v_alg); @@ -113,6 +113,43 @@ CAMLreturn(result); } +#endif + +/* Based on OCaml's unix_utimes function. */ +CAMLprim value ocaml_set_mtime(value path, value mtime) { +#ifdef _WIN32 + FILETIME win_time; + + /* Convert seconds since Unix epoch to 100-nano-second intervals since Jan 1, 1601. */ + uint64_t seconds_since_epoch = Double_val(mtime); + uint64_t seconds_since_1601 = seconds_since_epoch + 11644470000ULL; + uint64_t hundred_nanos_since_1601 = seconds_since_1601 * 10000000ULL; + + win_time.dwLowDateTime = hundred_nanos_since_1601; + win_time.dwHighDateTime = hundred_nanos_since_1601 >> 32; + + /* Based on PERL's code. + * FILE_FLAG_BACKUP_SEMANTICS means it's OK to open directories. */ + HANDLE handle; + handle = CreateFileA(String_val(path), GENERIC_READ | GENERIC_WRITE, + FILE_SHARE_READ | FILE_SHARE_DELETE, NULL, + OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); + if (handle != INVALID_HANDLE_VALUE) { + int ok = SetFileTime(handle, NULL, NULL, &win_time); + CloseHandle(handle); + if (ok) + return Val_unit; + } + + /* On error, fall through to the POSIX code to get the expected error message. */ +#endif + + struct utimbuf times; + times.actime = Double_val(mtime); + times.modtime = Double_val(mtime); + if (utime(String_val(path), ×) == -1) uerror("utimes", path); + return Val_unit; +} /* Based on code in extunix (LGPL-2.1) */ CAMLprim value ocaml_0install_uname(value v_unit) { diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/about.ml zeroinstall-injector-2.7/ocaml/zeroinstall/about.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/about.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/about.ml 2014-05-25 09:29:17.000000000 +0000 @@ -4,6 +4,6 @@ (** Information about this software *) -let version = "2.6.1" +let version = "2.7" let parsed_version = Versions.parse_version version diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/apps.mli zeroinstall-injector-2.7/ocaml/zeroinstall/apps.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/apps.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/apps.mli 2014-05-25 09:29:17.000000000 +0000 @@ -17,15 +17,15 @@ (** Create a new app with these requirements. * You should call [set_selections] immediately after this. *) -val create_app : config -> string -> Requirements.requirements -> app +val create_app : config -> string -> Requirements.t -> app (** Remove this app and any shell command created with [integrate_shell]. *) val destroy : config -> app -> unit val lookup_app : config -> string -> app option -val get_requirements : system -> app -> Requirements.requirements -val set_requirements : config -> app -> Requirements.requirements -> unit +val get_requirements : system -> app -> Requirements.t +val set_requirements : config -> app -> Requirements.t -> unit (** Get the dates of the available snapshots, starting with the most recent. * Used by the "0install whatchanged" command. *) diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/archive.ml zeroinstall-injector-2.7/ocaml/zeroinstall/archive.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/archive.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/archive.ml 2014-05-25 09:29:17.000000000 +0000 @@ -67,7 +67,14 @@ (** Run a command in a subprocess. If it returns an error code, generate an exception containing its stdout and stderr. *) let run_command ?cwd system args = (* Some zip archives are missing timezone information; force consistent results *) - let child_env = Array.append system#environment [| "TZ=GMT" |] in + let child_env = Array.append system#environment [| + (* Some zip archives lack time-zone information. Make sure all systems see the same time. *) + "TZ=GMT"; + + (* Stop OS X extracting extended attributes: *) + "COPYFILE_DISABLE=true"; (* Leopard *) + "COPY_EXTENDED_ATTRIBUTES_DISABLE=true"; (* Tiger *) + |] in (* todo: use pola-run if available, once it supports fchmod *) let command = make_command system args in diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/archive.mli zeroinstall-injector-2.7/ocaml/zeroinstall/archive.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/archive.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/archive.mli 2014-05-25 09:29:17.000000000 +0000 @@ -21,4 +21,4 @@ *) val unpack_over : ?extract:Support.Common.filepath -> General.config -> archive:Support.Common.filepath -> tmpdir:Support.Common.filepath -> destdir:Support.Common.filepath -> - mime_type:string -> unit Lwt.t + mime_type:mime_type -> unit Lwt.t diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/binding.ml zeroinstall-injector-2.7/ocaml/zeroinstall/binding.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/binding.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/binding.ml 2014-05-25 09:29:17.000000000 +0000 @@ -108,7 +108,7 @@ | Append -> log_info "%s=...%s%s" name separator value; old ^ separator ^ value in - match Env.find_opt name env with + match Env.get env name with | Some v -> add_to v (* add to current value of variable *) | None -> match default with | Some d -> add_to d (* or to the specified default *) @@ -119,7 +119,7 @@ value let do_env_binding env impls iface {var_name; mode; source} = - let add value = Env.putenv var_name (calc_new_value var_name mode value env) env in + let add value = Env.put env var_name (calc_new_value var_name mode value env) in match source with | Value v -> add v | InsertPath i -> match StringMap.find_safe iface impls with @@ -128,4 +128,4 @@ let prepend name value separator env = let mode = Add {pos = Prepend; default = None; separator} in - Env.putenv name (calc_new_value name mode value env) env + Env.put env name (calc_new_value name mode value env) diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/command.ml zeroinstall-injector-2.7/ocaml/zeroinstall/command.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/command.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/command.ml 2014-05-25 09:29:17.000000000 +0000 @@ -33,7 +33,7 @@ let expand s = match (Str.matched_group 1 s) with | "$" -> "$" | "" | "{}" -> Q.raise_elem "Empty variable name in template '%s' in" template arg - | m -> Env.find (remove_braces m) env in + | m -> Env.get_exn env (remove_braces m) in Str.global_substitute re_template expand template (* Return a list of string arguments by expanding and children of [elem] *) @@ -47,18 +47,16 @@ and expand_foreach node env = let item_from = ZI.get_attribute "item-from" node in let separator = default path_sep (ZI.get_attribute_opt "separator" node) in - match Env.find_opt item_from env with + match Env.get env item_from with | None -> [] | Some source -> let rec loop = function | [] -> [] | x::xs -> - let old = Env.find_opt "item" env in - let () = Env.putenv "item" x env in + let old = Env.get env "item" in + Env.put env "item" x; let new_args = get_args_loop node in - let () = match old with - | None -> () - | Some v -> Env.putenv "item" v env in + old |> if_some (Env.put env "item"); new_args @ (loop xs) in loop (Str.split_delim (Str.regexp_string separator) source) in get_args_loop elem diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/curl_threading.ml zeroinstall-injector-2.7/ocaml/zeroinstall/curl_threading.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/curl_threading.ml 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/curl_threading.ml 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,31 @@ +(* Copyright (C) 2014, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** Use Lwt if possible, or native threads if not. + * Native threads require us to initialise openssl for threading, which gives us a run-time dependency on it. + * Since openssl has poor ABI compatibility, this makes the 0install binary less portable. *) + +IFDEF HAVE_OCURL_LWT THEN +let init () = () +let run_in_main fn = fn () +let detach fn = fn () +let perform connection when_done = + Lwt.bind (Curl_lwt.perform connection) (function + | Curl.CURLE_OK -> Lwt.return (when_done ()) + | code -> raise Curl.(CurlException (code, errno code, strerror code)) + ) +let catch f g = Lwt.catch f (fun ex -> Lwt.return (g ex)) +ELSE +let init () = + Lwt_preemptive.init 0 100 (Support.Common.log_warning "%s"); + (* from dx-ocaml *) + Ssl.init ~thread_safe:true () (* Performs incantations to ensure thread-safety of OpenSSL *) + +let run_in_main fn = Support.Lwt_preemptive_copy.run_in_main (fun () -> Lwt.return (fn ())) +let detach fn = Lwt_preemptive.detach fn () +let perform connection when_done = Curl.perform connection; when_done () +let catch f g = + try f () + with ex -> g ex +ENDIF diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/dbus.ml zeroinstall-injector-2.7/ocaml/zeroinstall/dbus.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/dbus.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/dbus.ml 2014-05-25 09:29:17.000000000 +0000 @@ -50,8 +50,13 @@ ELSE -let session ?switch:_ () = Lwt.return None -let system ?switch:_ () = Lwt.return None +let session ?switch:_ () = + log_debug "Compiled without D-BUS support"; + Lwt.return None + +let system ?switch:_ () = + log_debug "Compiled without D-BUS support"; + Lwt.return None let no_dbus _ = raise_safe "No D-BUS!" diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/default_ui.ml zeroinstall-injector-2.7/ocaml/zeroinstall/default_ui.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/default_ui.ml 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/default_ui.ml 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,27 @@ +(* Copyright (C) 2013, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** High-level helper functions *) + +open General +open Support.Common + +let make_ui config use_gui : Ui.ui_handler = + let use_gui = + match use_gui, config.dry_run with + | Yes, true -> raise_safe "Can't use GUI with --dry-run" + | (Maybe|No), true -> No + | use_gui, false -> use_gui in + + let make_no_gui () = + if config.system#isatty Unix.stderr then + (new Console.console_ui :> Ui.ui_handler) + else + (new Console.batch_ui :> Ui.ui_handler) in + + match use_gui with + | No -> make_no_gui () + | Yes | Maybe -> + (* [try_get_gui] will throw if use_gui is [Yes] and the GUI isn't available *) + Gui.try_get_gui config ~use_gui |? lazy (make_no_gui ()) diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/default_ui.mli zeroinstall-injector-2.7/ocaml/zeroinstall/default_ui.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/default_ui.mli 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/default_ui.mli 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,15 @@ +(* Copyright (C) 2013, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** High-level helper functions *) + +(** Create a UI appropriate for the current environment and user options. + * This will be a graphical UI if [Gui.try_get_gui] returns one and we're not in dry-run mode. + * Otherwise, it will be an interactive console UI if stderr is a tty. + * Otherwise, it will be a batch UI (no progress display). + *) +val make_ui : + General.config -> + Support.Common.yes_no_maybe -> + Ui.ui_handler diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/diagnostics.ml zeroinstall-injector-2.7/ocaml/zeroinstall/diagnostics.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/diagnostics.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/diagnostics.ml 2014-05-25 09:29:17.000000000 +0000 @@ -10,7 +10,6 @@ module FeedAttr = Constants.FeedAttr module U = Support.Utils -module S = Solver.S module SelMap = Map.Make ( struct @@ -81,7 +80,7 @@ let () = try ListLabels.iter rejected ~f:(fun (impl, problem) -> - if !i = 5 then (add "..."; raise Exit); + if !i = 5 && not Support.Logging.(will_log Debug) then (add "..."; raise Exit); add "%s (%s): %s" (name_impl impl) (format_version impl) (describe_problem impl problem); i := !i + 1 ); @@ -116,8 +115,8 @@ impl_provider. As we explore the example selections, we further filter the candidates. [candidates] is the result from the impl_provider. [impl] is the selected implementation, or [None] if we chose [dummy_impl]. - [lit] is the SAT literal, which can be used to produce diagnostics as a last resort. *) -class component candidates (lit:S.lit) (selected_impl:Feed.generic_implementation option) = + [diagnostics] can be used to produce diagnostics as a last resort. *) +class component candidates (diagnostics:Solver.diagnostics) (selected_impl:Feed.generic_implementation option) = let {Impl_provider.impls = orig_good; Impl_provider.rejects = orig_bad; Impl_provider.replacement} = candidates in (* orig_good is all the implementations passed to the SAT solver (these are the ones with a compatible OS, CPU, etc). They are sorted most desirable first. *) @@ -152,7 +151,7 @@ bad <- List.map (fun impl -> (impl, reason)) good @ bad; good <- [] - method lit = lit + method diagnostics = diagnostics method replacement = replacement method impl = selected_impl method notes = List.rev notes @@ -248,9 +247,9 @@ (* For each of our remaining unrejected impls, check whether a dependency prevented its selection. *) component#filter_impls (get_dependency_problem report) -let reject_if_unselected sat _key component = +let reject_if_unselected _key component = if component#impl = None then ( - component#reject_all (`DiagnosticsFailure (S.explain_reason sat component#lit)); + component#reject_all (`DiagnosticsFailure (Solver.explain component#diagnostics)); component#note NoCandidates; ) @@ -300,24 +299,26 @@ SelMap.iter filter report let get_failure_report (result:Solver.result) : component SelMap.t = - let (sat, impl_provider, impl_cache, root_req) = result#get_details in + let impl_provider = result#impl_provider in + let impls = result#implementations in + let root_req = result#requirements in let report = - let get_selected map ((iface, source) as key, candidates) = - match candidates#get_selected with + let get_selected map ((iface, source) as key, selected_candidate) = + match selected_candidate with | None -> map (* Not part of the (dummy) solution *) - | Some (lit, impl) -> + | Some (diagnostics, impl) -> let impl = if impl.Feed.parsed_version = Versions.dummy then None else Some impl in let impl_candidates = impl_provider#get_implementations iface ~source in - let component = new component impl_candidates lit impl in + let component = new component impl_candidates diagnostics impl in SelMap.add key component map in - List.fold_left get_selected SelMap.empty impl_cache#get_items in + List.fold_left get_selected SelMap.empty impls in process_root_req report root_req; examine_extra_restrictions report impl_provider#extra_restrictions; check_machine_groups report; SelMap.iter (examine_selection report) report; - SelMap.iter (reject_if_unselected sat) report; + SelMap.iter reject_if_unselected report; report diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/diagnostics.mli zeroinstall-injector-2.7/ocaml/zeroinstall/diagnostics.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/diagnostics.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/diagnostics.mli 2014-05-25 09:29:17.000000000 +0000 @@ -12,4 +12,4 @@ (** Run a solve with a single implementation as the only choice for an interface. If no solution is possible, explain why not. If a solution is possible, explain why it isn't the preferred solution. *) -val justify_decision : General.config -> Feed_provider.feed_provider -> Requirements.requirements -> General.iface_uri -> Feed_url.global_id -> string +val justify_decision : General.config -> Feed_provider.feed_provider -> Requirements.t -> General.iface_uri -> Feed_url.global_id -> string diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/distro_cache.ml zeroinstall-injector-2.7/ocaml/zeroinstall/distro_cache.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/distro_cache.ml 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/distro_cache.ml 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,139 @@ +(* Copyright (C) 2014, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** A simple cache for storing key-value pairs on disk. Distributions may wish to use this to record the + version(s) of each distribution package currently installed. *) + +open Support.Common +open General + +module U = Support.Utils +module Basedir = Support.Basedir + +type package_name = string +type machine = string option +type entry = Versions.parsed_version * machine + +type cache_data = { + mutable mtime : float; + mutable size : int; + contents : (package_name, entry list) Hashtbl.t; +} + +let re_invalid = Str.regexp ".*[\t\n]" + +let validate_key k = + assert (not (Str.string_match re_invalid k 0)) + +class cache (config:General.config) ~(cache_leaf:string) (source:filepath) = + let warned_missing = ref false in + let re_metadata_sep = U.re_equals + and re_key_value_sep = U.re_tab in + + let add_entry ch package_name (version, machine) = + validate_key package_name; + Printf.fprintf ch "%s\t%s\t%s\n" package_name (Versions.format_version version) (default "*" machine) in + + object (self) + (* The status of the cache when we loaded it. *) + val data = { mtime = 0.0; size = -1; contents = Hashtbl.create 10 } + + val cache_path = Basedir.save_path config.system (config_site +/ config_prog) config.basedirs.Basedir.cache +/ cache_leaf + + (** Reload the values from disk (even if they're out-of-date). *) + method private load_cache = + data.mtime <- -1.0; + data.size <- -1; + Hashtbl.clear data.contents; + + if Sys.file_exists cache_path then ( + try + cache_path |> config.system#with_open_in [Open_rdonly; Open_text] (fun ch -> + let headers = ref true in + while !headers do + match input_line ch with + | "" -> headers := false + | line -> + (* log_info "Cache header: %s" line; *) + match U.split_pair re_metadata_sep line with + | ("mtime", mtime) -> data.mtime <- float_of_string mtime + | ("size", size) -> data.size <- U.safe_int_of_string size + | _ -> () + done; + + try + while true do + let line = input_line ch in + let key, value = U.split_pair re_key_value_sep line in + let prev = try Hashtbl.find data.contents key with Not_found -> [] in + if value = "-" then ( + Hashtbl.replace data.contents key prev (* Ensure empty list is in the table *) + ) else ( + let version, machine = U.split_pair U.re_tab value in + Hashtbl.replace data.contents key @@ (Versions.parse_version version, Arch.none_if_star machine) :: prev + ) + done + with End_of_file -> () + ) + with ex -> + log_warning ~ex "Failed to load cache file '%s' (maybe corrupted; try deleting it)" cache_path + ) + + (** Add some entries to the cache. *) + method private put key values = + try + Hashtbl.replace data.contents key values; + cache_path |> config.system#with_open_out [Open_append; Open_creat] ~mode:0o644 (fun ch -> + if values = [] then ( + validate_key key; + Printf.fprintf ch "%s\t-\n" key (* Cache negative results too *) + ) else ( + values |> List.iter (add_entry ch key) + ) + ) + with Safe_exception _ as ex -> reraise_with_context ex "... writing cache %s" cache_path + + (** Check cache is still up-to-date (i.e. that [source] hasn't changed). Clear it if not. *) + method private ensure_valid = + match config.system#stat source with + | None -> + if not !warned_missing then ( + log_warning "Package database '%s' missing!" source; + warned_missing := true + ) + | Some info -> + let flush () = + cache_path |> config.system#atomic_write [Open_wronly; Open_binary] ~mode:0o644 (fun ch -> + let mtime = Int64.of_float info.Unix.st_mtime |> Int64.to_string in + Printf.fprintf ch "mtime=%s\nsize=%d\n\n" mtime info.Unix.st_size; + self#regenerate_cache (add_entry ch) + ); + self#load_cache in + if data.mtime <> info.Unix.st_mtime then ( + if data.mtime <> -1.0 then + log_info "Modification time of %s has changed; invalidating cache" source; + flush () + ) else if data.size <> info.Unix.st_size then ( + log_info "Size of %s has changed; invalidating cache" source; + flush () + ) + + method private regenerate_cache _add = () + + method get ?if_missing (key:package_name) : (entry list * Distro.quick_test option) = + self#ensure_valid; + let entries = + try Hashtbl.find data.contents key + with Not_found -> + match if_missing with + | None -> [] + | Some if_missing -> + let result = if_missing key in + self#put key result; + result in + let quick_test_file = Some (source, Distro.UnchangedSince data.mtime) in + (entries, quick_test_file) + + initializer self#load_cache + end diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/distro_cache.mli zeroinstall-injector-2.7/ocaml/zeroinstall/distro_cache.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/distro_cache.mli 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/distro_cache.mli 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,29 @@ +(* Copyright (C) 2014, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** A simple cache for storing key-value pairs on disk. Distributions may wish to use this to record the + version(s) of each distribution package currently installed. *) + +open Support.Common + +type package_name = string +type machine = string option +type entry = Versions.parsed_version * machine + +(* [new cache config ~cache_leaf source] creates a new cache backed by [cache_leaf]. + * Whenever [source] changes, everything in the cache is assumed to be invalid. *) +class cache : General.config -> cache_leaf:string -> filepath -> + object + (** Look up an item in the cache. + * @param if_missing called if given and no entries are found. Whatever it returns is cached. *) + method get : + ?if_missing:(package_name -> entry list) -> + package_name -> entry list * Distro.quick_test option + + (** The cache is being regenerated from scratch. If you want to + * pre-populate the cache, do it here by calling the provided function once + * for each entry. Otherwise, you can populate it lazily using [get + * ~if_missing]. *) + method private regenerate_cache : (package_name -> entry -> unit) -> unit + end diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/distro_impls.ml zeroinstall-injector-2.7/ocaml/zeroinstall/distro_impls.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/distro_impls.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/distro_impls.ml 2014-05-25 09:29:17.000000000 +0000 @@ -32,157 +32,10 @@ | Problem ex -> log_debug ~ex "Failed to read directory '%s'" path | Success items -> items |> Array.iter fn -(** A simple cache for storing key-value pairs on disk. Distributions may wish to use this to record the - version(s) of each distribution package currently installed. *) -module Cache = - struct - type cache_format = Old | New - type package_name = string - type machine = string option - type entry = Versions.parsed_version * machine - - type cache_data = { - mutable mtime : float; - mutable size : int; - mutable rev : int; - contents : (package_name, entry list) Hashtbl.t; - } - - let re_colon_space = Str.regexp_string ": " - - (* Manage the cache named [cache_leaf]. Whenever [source] changes, everything in the cache is assumed to be invalid. - Note: [format_version] doesn't make much sense. If the format changes, just use a different [cache_leaf], - otherwise you'll be fighting with other versions of 0install. - The [old_format] used different separator characters. - *) - class cache (config:General.config) (cache_leaf:string) (source:filepath) (format_version:int) (cache_format:cache_format) = - let warned_missing = ref false in - let re_metadata_sep = match cache_format with Old -> re_colon_space | New -> U.re_equals - and re_key_value_sep = match cache_format with Old -> U.re_tab | New -> U.re_equals in - - object (self) - (* The status of the cache when we loaded it. *) - val data = { mtime = 0.0; size = -1; rev = -1; contents = Hashtbl.create 10 } - - val cache_path = Basedir.save_path config.system (config_site +/ config_prog) config.basedirs.Basedir.cache +/ cache_leaf - - (** Reload the values from disk (even if they're out-of-date). *) - method private load_cache = - data.mtime <- -1.0; - data.size <- -1; - data.rev <- -1; - Hashtbl.clear data.contents; - - if Sys.file_exists cache_path then ( - try - cache_path |> config.system#with_open_in [Open_rdonly; Open_text] (fun ch -> - let headers = ref true in - while !headers do - match input_line ch with - | "" -> headers := false - | line -> - (* log_info "Cache header: %s" line; *) - match Utils.split_pair re_metadata_sep line, cache_format with - | ("mtime", mtime), _ -> data.mtime <- float_of_string mtime - | ("size", size), _ -> data.size <- U.safe_int_of_string size - | ("version", rev), Old -> data.rev <- U.safe_int_of_string rev - | ("format", rev), New -> data.rev <- U.safe_int_of_string rev - | _ -> () - done; - - try - while true do - let line = input_line ch in - let key, value = Utils.split_pair re_key_value_sep line in - let prev = try Hashtbl.find data.contents key with Not_found -> [] in - if value = "-" then ( - Hashtbl.replace data.contents key prev (* Ensure empty list is in the table *) - ) else ( - let version, machine = Utils.split_pair U.re_tab value in - Hashtbl.replace data.contents key @@ (Versions.parse_version version, Arch.none_if_star machine) :: prev - ) - done - with End_of_file -> () - ) - with ex -> - log_warning ~ex "Failed to load cache file '%s' (maybe corrupted; try deleting it)" cache_path - ) - - (** Add some entries to the cache. - * Warning: adding the empty list has no effect. In particular, future calls to [get] will still call [if_missing]. - * So if you want to record the fact that a package is not installed, you see need to add an entry for it (e.g. [["-"]]). *) - method private put key values = - try - Hashtbl.replace data.contents key values; - cache_path |> config.system#with_open_out [Open_append; Open_creat] ~mode:0o644 (fun ch -> - if values = [] then ( - output_string ch @@ Printf.sprintf "%s=-\n" key (* Cache negative results too *) - ) else ( - values |> List.iter (fun (version, machine) -> - output_string ch @@ Printf.sprintf "%s=%s\t%s\n" key (Versions.format_version version) (default "*" machine) - ) - ) - ) - with Safe_exception _ as ex -> reraise_with_context ex "... writing cache %s" cache_path - - (** Check cache is still up-to-date (i.e. that [source] hasn't changed). Clear it if not. *) - method private ensure_valid = - match config.system#stat source with - | None -> - if not !warned_missing then ( - log_warning "Package database '%s' missing!" source; - warned_missing := true - ) - | Some info -> - let flush () = - cache_path |> config.system#atomic_write [Open_wronly; Open_binary] ~mode:0o644 (fun ch -> - let mtime = Int64.of_float info.Unix.st_mtime |> Int64.to_string in - begin match cache_format with - | Old -> Printf.fprintf ch "mtime: %s\nsize: %d\nversion: %d\n\n" mtime info.Unix.st_size format_version - | New -> Printf.fprintf ch "mtime=%s\nsize=%d\nformat=%d\n\n" mtime info.Unix.st_size format_version end; - self#regenerate_cache ch - ); - self#load_cache in - if data.mtime <> info.Unix.st_mtime then ( - if data.mtime <> -1.0 then - log_info "Modification time of %s has changed; invalidating cache" source; - flush () - ) else if data.size <> info.Unix.st_size then ( - log_info "Size of %s has changed; invalidating cache" source; - flush () - ) else if data.rev <> format_version then ( - log_info "Format of cache %s has changed; invalidating cache" cache_path; - flush () - ) - - (** The cache is being regenerated. The header has been written (to a temporary file). If you want to - * pre-populate the cache, do it here. Otherwise, you can populate it lazily using [get ~if_missing]. *) - method private regenerate_cache _ch = () - - (** Look up an item in the cache. - * @param if_missing called if given and no entries are found *) - method get ?if_missing (key:package_name) : (entry list * quick_test option) = - self#ensure_valid; - let entries = - try Hashtbl.find data.contents key - with Not_found -> - match if_missing with - | None -> [] - | Some if_missing -> - let result = if_missing key in - self#put key result; - result in - let quick_test_file = Some (source, UnchangedSince data.mtime) in - (entries, quick_test_file) - - initializer self#load_cache - end - end - (** Lookup [elem]'s package in the cache. Generate the ID(s) for the cached implementations and check that one of them matches the [id] attribute on [elem]. Returns [false] if the cache is out-of-date. *) -let check_cache id_prefix elem (cache:Cache.cache) = +let check_cache id_prefix elem (cache:Distro_cache.cache) = match ZI.get_attribute_opt "package" elem with | None -> Qdom.log_elem Support.Logging.Warning "Missing 'package' attribute" elem; @@ -220,7 +73,8 @@ (* Check to see whether we could get a newer version using apt-get *) lwt result = try_lwt - lwt out = Lwt_process.pread ~stderr:`Dev_null (U.make_command system ["apt-cache"; "show"; "--no-all-versions"; "--"; package]) in + let stderr = if Support.Logging.will_log Support.Logging.Debug then None else Some `Dev_null in + lwt out = Lwt_process.pread ?stderr (U.make_command system ["apt-cache"; "--no-all-versions"; "show"; "--"; package]) in let machine = ref None in let version = ref None in let size = ref None in @@ -302,7 +156,11 @@ val distro_name = "Debian" val id_prefix = "package:deb" - val cache = new Cache.cache config "dpkg-status.cache" status_file 2 Cache.New + val cache = new Distro_cache.cache config ~cache_leaf:"dpkg-status2.cache" status_file + + (* If we added apt_cache results AND package kit is unavailable, this is set + * so that we include them in the results. Otherwise, we just take the PackageKit results. *) + val mutable use_apt_cache_results = false method! is_installed elem = check_cache id_prefix elem cache || super#is_installed elem @@ -311,14 +169,17 @@ (* Add any PackageKit candidates *) super#get_package_impls query; - (* Add apt-cache candidates (there won't be any if we used PackageKit) *) let package_name = query.package_name in - let entry = try Hashtbl.find apt_cache package_name with Not_found -> None in - entry |> if_some (fun {version; machine; size = _} -> - let version = Versions.parse_version version in - let machine = Arch.none_if_star machine in - let package_state = `uninstalled Feed.({distro_size = None; distro_install_info = ("apt-get install", package_name)}) in - self#add_package_implementation ~package_state ~version ~machine ~quick_test:None ~distro_name query + + (* Add apt-cache candidates (only if we're not using PackageKit) *) + if use_apt_cache_results then ( + let entry = try Hashtbl.find apt_cache package_name with Not_found -> None in + entry |> if_some (fun {version; machine; size = _} -> + let version = Versions.parse_version version in + let machine = Arch.none_if_star machine in + let package_state = `uninstalled Feed.({distro_size = None; distro_install_info = ("apt-get install", package_name)}) in + self#add_package_implementation ~package_state ~version ~machine ~quick_test:None ~distro_name query + ) ); (* Add installed packages by querying dpkg. *) @@ -331,14 +192,23 @@ match Distro.get_matching_package_impls self feed with | [] -> Lwt.return () | matches -> - lwt available = packagekit#is_available in - if available then ( - let package_names = matches |> List.map (fun (elem, _props) -> ZI.get_attribute "package" elem) in + let package_names = matches |> List.map (fun (elem, _props) -> (ZI.get_attribute "package" elem)) in + + (* Check apt-cache to see whether we have the pacakges. If PackageKit isn't available, we'll use these + * results directly. If it is available, we'll use these results to filter the PackageKit query, because + * it doesn't like queries for missing packages (it tends to abort the query early and miss some results). *) + lwt () = query_apt_cache package_names + and pkgkit_available = packagekit#is_available in + + if pkgkit_available then ( let hint = Feed_url.format_url feed.Feed.url in - packagekit#check_for_candidates ~ui ~hint package_names + package_names + |> List.filter (Hashtbl.mem apt_cache) + |> packagekit#check_for_candidates ~ui ~hint ) else ( (* No PackageKit. Use apt-cache directly. *) - query_apt_cache (matches |> List.map (fun (elem, _props) -> (ZI.get_attribute "package" elem))) + use_apt_cache_results <- true; + Lwt.return () ) method! private add_package_implementation ?id ?main query ~version ~machine ~quick_test ~package_state ~distro_name = @@ -393,8 +263,8 @@ val id_prefix = "package:rpm" val cache = object - inherit Cache.cache config "rpm-status.cache" rpm_db_packages 2 Cache.Old - method! private regenerate_cache ch = + inherit Distro_cache.cache config ~cache_leaf:"rpm-status3.cache" rpm_db_packages + method! private regenerate_cache add_entry = ["rpm"; "-qa"; "--qf=%{NAME}\t%{VERSION}-%{RELEASE}\t%{ARCH}\n"] |> U.check_output config.system (fun from_rpm -> try @@ -403,9 +273,9 @@ match Str.bounded_split_delim U.re_tab line 3 with | ["gpg-pubkey"; _; _] -> () | [package; version; rpmarch] -> - let zi_arch = Support.System.canonical_machine (trim rpmarch) in + let zi_arch = Support.System.canonical_machine (trim rpmarch) |> Arch.none_if_star in try_cleanup_distro_version_warn version package |> if_some (fun clean_version -> - Printf.fprintf ch "%s\t%s\t%s\n" package (Versions.format_version clean_version) zi_arch + add_entry package (clean_version, zi_arch) ) | _ -> log_warning "Invalid output from 'rpm': %s" line done @@ -618,9 +488,9 @@ val id_prefix = "package:macports" val cache = object - inherit Cache.cache config "macports-status.cache" macports_db 2 Cache.Old + inherit Distro_cache.cache config ~cache_leaf:"macports-status2.cache" macports_db - method! private regenerate_cache to_cache = + method! private regenerate_cache add_entry = ["port"; "-v"; "installed"] |> U.check_output config.system (fun ch -> try while true do @@ -640,10 +510,10 @@ let archs = Str.matched_group 3 extra in Str.split U.re_space archs |> List.iter (fun arch -> let zi_arch = Support.System.canonical_machine arch in - Printf.fprintf to_cache "%s\t%s\t%s\n" package (Versions.format_version version) zi_arch + add_entry package (version, Arch.none_if_star zi_arch) ) ) else ( - Printf.fprintf to_cache "%s\t%s\t*\n" package (Versions.format_version version) + add_entry package (version, None) ) ) ) else log_debug "Failed to match version '%s'" version @@ -804,8 +674,8 @@ val cache = object - inherit Cache.cache config "cygcheck-status.cache" cygwin_log 2 Cache.Old - method! private regenerate_cache ch = + inherit Distro_cache.cache config ~cache_leaf:"cygcheck-status2.cache" cygwin_log + method! private regenerate_cache add_entry = ["cygcheck"; "-c"; "-d"] |> U.check_output config.system (fun from_cyg -> try while true do @@ -815,9 +685,8 @@ match U.split_pair re_whitespace line with | ("Package", "Version") -> () | (package, version) -> - let zi_arch = "*" in try_cleanup_distro_version_warn version package |> if_some (fun clean_version -> - Printf.fprintf ch "%s\t%s\t%s\n" package (Versions.format_version clean_version) zi_arch + add_entry package (clean_version, None) ) done with End_of_file -> () diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/distro.ml zeroinstall-injector-2.7/ocaml/zeroinstall/distro.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/distro.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/distro.ml 2014-05-25 09:29:17.000000000 +0000 @@ -151,11 +151,11 @@ Lazy.force python_info |> List.map (fun ((path, version), _) -> let id = "package:host:python:" ^ version in let run = ZI.make "command" - ~attrs:(Q.attrs_of_list [ - ("name", "run"); - ("path", path); - ]) in - let commands = StringMap.singleton "run" Feed.({command_qdom = run; command_requires = []}) in + ~attrs:( + Q.AttrMap.singleton "name" "run" + |> Q.AttrMap.add_no_ns "path" path + ) in + let commands = StringMap.singleton "run" Feed.({command_qdom = run; command_requires = []; command_bindings = []}) in (id, make_host_impl path version ~commands url id) ) | `remote_feed "http://repo.roscidus.com/python/python-gobject" as url -> @@ -170,7 +170,7 @@ let fixup_main distro_get_correct_main impl = let open Feed in - match get_command_opt "run" impl.props.commands with + match get_command_opt "run" impl with | None -> () | Some run -> match distro_get_correct_main impl run with diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/downloader.ml zeroinstall-injector-2.7/ocaml/zeroinstall/downloader.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/downloader.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/downloader.ml 2014-05-25 09:29:17.000000000 +0000 @@ -29,20 +29,18 @@ not finished let init = lazy ( - Lwt_preemptive.init 0 100 (log_warning "%s"); - (* from dx-ocaml *) - Ssl.init ~thread_safe:true (); (* Performs incantations to ensure thread-safety of OpenSSL *) + Curl_threading.init (); Curl.(global_init CURLINIT_GLOBALALL); ) let interceptor = ref None (* (for unit-tests) *) (** Download the contents of [url] into [ch]. - * This runs in a separate (real) thread. *) + * This runs in a separate (either Lwt or native) thread. *) let download_no_follow ~cancelled ?size ?modification_time ?(start_offset=Int64.zero) ~progress connection ch url = let skip_bytes = ref (Int64.to_int start_offset) in let error_buffer = ref "" in - try + Curl_threading.catch (fun () -> let redirect = ref None in let check_header header = if U.starts_with header "Location:" then ( @@ -83,8 +81,8 @@ Curl.set_url connection url; Curl.set_headerfunction connection check_header; Curl.set_progressfunction connection (fun dltotal dlnow _ultotal _ulnow -> - Support.Lwt_preemptive_copy.run_in_main (fun () -> - if !cancelled then Lwt.return true (* Don't override the finished=true signal *) + Curl_threading.run_in_main (fun () -> + if !cancelled then true (* Don't override the finished=true signal *) else ( let dlnow = Int64.of_float dlnow in begin match size with @@ -92,58 +90,68 @@ | None -> let total = if dltotal = 0.0 then None else Some (Int64.of_float dltotal) in progress (dlnow, total, false) end; - Lwt.return false (* (continue download) *) + false (* (continue download) *) ) ) ); Curl.set_noprogress connection false; (* progress = true *) - Curl.perform connection; + Curl_threading.perform connection (fun () -> + let actual_size = Curl.get_sizedownload connection in - let actual_size = Curl.get_sizedownload connection in + (* Curl.cleanup connection; - leave it open for the next request *) - (* Curl.cleanup connection; - leave it open for the next request *) - - match !redirect with - | Some target -> - (* ocurl is missing CURLINFO_REDIRECT_URL, so we have to do this manually *) - let target = Support.Urlparse.join_url url target in - log_info "Redirect from '%s' to '%s'" url target; - `redirect target - | None -> - if modification_time <> None && actual_size = 0.0 then ( - raise Unmodified (* ocurl is missing CURLINFO_CONDITION_UNMET *) - ) else ( - size |> if_some (fun expected -> - let expected = Int64.to_float expected in - if expected <> actual_size then - raise_safe "Downloaded archive has incorrect size.\n\ - URL: %s\n\ - Expected: %.0f bytes\n\ - Received: %.0f bytes" url expected actual_size - ); - log_info "Download '%s' completed successfully (%.0f bytes)" url actual_size; - `success - ) - with Curl.CurlException _ as ex -> - if !cancelled then `aborted_by_user - else ( - log_info ~ex "Curl error: %s" !error_buffer; - let msg = Printf.sprintf "Error downloading '%s': %s" url !error_buffer in - `network_failure msg + match !redirect with + | Some target -> + (* ocurl is missing CURLINFO_REDIRECT_URL, so we have to do this manually *) + let target = Support.Urlparse.join_url url target in + log_info "Redirect from '%s' to '%s'" url target; + `redirect target + | None -> + if modification_time <> None && actual_size = 0.0 then ( + raise Unmodified (* ocurl is missing CURLINFO_CONDITION_UNMET *) + ) else ( + size |> if_some (fun expected -> + let expected = Int64.to_float expected in + if expected <> actual_size then + raise_safe "Downloaded archive has incorrect size.\n\ + URL: %s\n\ + Expected: %.0f bytes\n\ + Received: %.0f bytes" url expected actual_size + ); + log_info "Download '%s' completed successfully (%.0f bytes)" url actual_size; + `success + ) ) + ) + (function + | Curl.CurlException _ as ex -> + if !cancelled then `aborted_by_user + else ( + log_info ~ex "Curl error: %s" !error_buffer; + let msg = Printf.sprintf "Error downloading '%s': %s" url !error_buffer in + `network_failure msg + ) + | ex -> raise ex + ) (** Rate-limits downloads within a site. * [domain] is e.g. "http://site:port" - the URL before the path *) let make_site max_downloads_per_site = + let connections = Queue.create () in + let create_connection () = let connection = Curl.init () in Curl.set_nosignal connection true; (* Can't use DNS timeouts when multi-threaded *) Curl.set_failonerror connection true; Curl.set_followlocation connection false; - Lwt.return connection in + let r = ref (Some connection) in + Queue.add r connections; + Lwt.return r in + + let validate c = Lwt.return (!c <> None) in - let pool = Lwt_pool.create max_downloads_per_site create_connection in + let pool = Lwt_pool.create max_downloads_per_site create_connection ~validate in object method schedule_download ~cancelled ?if_slow ?size ?modification_time ?start_offset ~progress ch url = @@ -152,25 +160,37 @@ raise_safe "Invalid scheme in URL '%s'" url ); - Lwt_pool.use pool (fun connection -> - match !interceptor with - | Some interceptor -> - interceptor ?if_slow ?size ?modification_time ch url - | None -> - let timeout = if_slow |> pipe_some (fun if_slow -> - let timeout = Lwt_timeout.create 5 (fun () -> Lazy.force if_slow) in - Lwt_timeout.start timeout; - Some timeout; - ) in - - let download () = download_no_follow ~cancelled ?modification_time ?size ?start_offset ~progress connection ch url in - - try_lwt - Lwt_preemptive.detach download () - finally - timeout |> if_some Lwt_timeout.stop; - Lwt.return () + Lwt_pool.use pool (fun r -> + match !r with + | None -> failwith "Attempt to use a freed connection!" + | Some connection -> + match !interceptor with + | Some interceptor -> + interceptor ?if_slow ?size ?modification_time ch url + | None -> + let timeout = if_slow |> pipe_some (fun if_slow -> + let timeout = Lwt_timeout.create 5 (fun () -> Lazy.force if_slow) in + Lwt_timeout.start timeout; + Some timeout; + ) in + + let download () = download_no_follow ~cancelled ?modification_time ?size ?start_offset ~progress connection ch url in + + try_lwt + Curl_threading.detach download + finally + timeout |> if_some Lwt_timeout.stop; + Lwt.return () ) + + (** Clean up all Curl connections. Call this before discarding the site. *) + method release = + let cleanup r = + match !r with + | None -> log_warning "Attempt to cleanup an already-cleaned connection!" + | Some c -> Curl.cleanup c; r := None in + Queue.iter cleanup connections; + Queue.clear connections end type downloader = @@ -185,88 +205,120 @@ type monitor = download -> unit -type download_pool = monitor -> downloader +class type download_pool = + object + method with_monitor : monitor -> downloader + method release : unit + end + +(** Empty the file and reset the FD to the start. + * On Windows, we have to close and reopen the file to do this. *) +let truncate_to_empty tmpfile ch = + flush !ch; + if Sys.os_type = "Win32" then ( + close_out !ch; + ch := open_out_gen [Open_wronly; Open_trunc; Open_binary] 0o700 tmpfile; + Unix.set_close_on_exec (Unix.descr_of_out_channel !ch); + ) else ( + Unix.ftruncate (Unix.descr_of_out_channel !ch) 0; + seek_out !ch 0 + ) let make_pool ~max_downloads_per_site : download_pool = let () = Lazy.force init in let sites = Hashtbl.create 10 in - fun monitor -> - object - (** Download url to a new temporary file and return its name. - * @param switch delete the temporary file when this is turned off - * @param if_slow is forced if the download is taking a long time (excluding queuing time) - * @param modification_time raise [Unmodified] if file hasn't changed since this time - * @hint a tag to attach to the download (used by the GUI to associate downloads with feeds) - *) - method download : 'a. - switch:Lwt_switch.t -> - ?modification_time:float -> - ?if_slow:(unit Lazy.t) -> - ?size:Int64.t -> - ?start_offset:Int64.t -> - ?hint:([< Feed_url.parsed_feed_url] as 'a) -> - string -> download_result Lwt.t = - fun ~switch ?modification_time ?if_slow ?size ?start_offset ?hint url -> - let hint = hint |> pipe_some (fun feed -> Some (Feed_url.format_url feed)) in - log_debug "Download URL '%s'... (for %s)" url (default "no feed" hint); - - let progress, set_progress = Lwt_react.S.create (Int64.zero, size, false) in - - let cancelled = ref false in - - let tmpfile, ch = Filename.open_temp_file ~mode:[Open_binary] "0install-" "-download" in - Lwt_switch.add_hook (Some switch) (fun () -> Unix.unlink tmpfile |> Lwt.return); - - let rec loop redirs_left url = - let site = - let domain, _ = Support.Urlparse.split_path url in - try Hashtbl.find sites domain - with Not_found -> - let site = make_site max_downloads_per_site in - Hashtbl.add sites domain site; - site in - match_lwt site#schedule_download ~cancelled ?if_slow ?size ?modification_time ?start_offset ~progress:set_progress ch url with - | `success -> - close_out ch; - `tmpfile tmpfile |> Lwt.return - | (`network_failure _ | `aborted_by_user) as result -> - close_out ch; - Lwt.return result - | `redirect target -> - flush ch; - Unix.ftruncate (Unix.descr_of_out_channel ch) 0; - seek_out ch 0; - if target = url then raise_safe "Redirection loop getting '%s'" url - else if redirs_left > 0 then loop (redirs_left - 1) target - else raise_safe "Too many redirections (next: %s)" target in - - (* Cancelling: - * ocurl is missing OPENSOCKETFUNCTION, but we can get close by setting a flag so that it - * aborts on the next write. In any case, we don't wait for the thread exit, as it may be - * blocked on a DNS lookup, etc. *) - let task, waker = Lwt.task () in - let cancel () = - log_info "Cancelling download %s" url; - cancelled := true; - Lwt.cancel task; - Lwt.return () in - monitor {cancel; url; progress; hint}; - - U.async (fun () -> - try_lwt - lwt result = loop 10 url in - Lwt.wakeup waker result; + object + method with_monitor monitor = + object + (** Download url to a new temporary file and return its name. + * @param switch delete the temporary file when this is turned off + * @param if_slow is forced if the download is taking a long time (excluding queuing time) + * @param modification_time raise [Unmodified] if file hasn't changed since this time + * @hint a tag to attach to the download (used by the GUI to associate downloads with feeds) + *) + method download : 'a. + switch:Lwt_switch.t -> + ?modification_time:float -> + ?if_slow:(unit Lazy.t) -> + ?size:Int64.t -> + ?start_offset:Int64.t -> + ?hint:([< Feed_url.parsed_feed_url] as 'a) -> + string -> download_result Lwt.t = + fun ~switch ?modification_time ?if_slow ?size ?start_offset ?hint url -> + let hint = hint |> pipe_some (fun feed -> Some (Feed_url.format_url feed)) in + log_debug "Download URL '%s'... (for %s)" url (default "no feed" hint); + + let progress, set_progress = Lwt_react.S.create (Int64.zero, size, false) in + + let cancelled = ref false in + + let tmpfile, ch = Filename.open_temp_file ~mode:[Open_binary] "0install-" "-download" in + Unix.set_close_on_exec (Unix.descr_of_out_channel ch); + let ch = ref ch in + Lwt_switch.add_hook (Some switch) (fun () -> + try_lwt + close_out !ch; (* For Windows: ensure file is closed before unlinking *) + Unix.unlink tmpfile; + Lwt.return () + with ex -> + log_warning ~ex "Failed to delete temporary file for download of '%s'" url; + Lwt.return () + ); + + let rec loop redirs_left url = + let site = + let domain, _ = Support.Urlparse.split_path url in + try Hashtbl.find sites domain + with Not_found -> + let site = make_site max_downloads_per_site in + Hashtbl.add sites domain site; + site in + match_lwt site#schedule_download ~cancelled ?if_slow ?size ?modification_time ?start_offset ~progress:set_progress !ch url with + | `success -> + close_out !ch; + `tmpfile tmpfile |> Lwt.return + | (`network_failure _ | `aborted_by_user) as result -> + close_out !ch; + Lwt.return result + | `redirect target -> + truncate_to_empty tmpfile ch; + if target = url then raise_safe "Redirection loop getting '%s'" url + else if redirs_left > 0 then loop (redirs_left - 1) target + else raise_safe "Too many redirections (next: %s)" target in + + (* Cancelling: + * ocurl is missing OPENSOCKETFUNCTION, but we can get close by setting a flag so that it + * aborts on the next write. In any case, we don't wait for the thread exit, as it may be + * blocked on a DNS lookup, etc. *) + let task, waker = Lwt.task () in + let cancel () = + log_info "Cancelling download %s" url; + cancelled := true; + Lwt.cancel task; + Lwt.return () in + monitor {cancel; url; progress; hint}; + + U.async (fun () -> + try_lwt + lwt result = loop 10 url in + Lwt.wakeup waker result; + Lwt.return () + with ex -> + log_info ~ex "Download failed"; + close_out !ch; + Lwt.wakeup_exn waker ex; Lwt.return () + ); + + try_lwt task + with Lwt.Canceled -> `aborted_by_user |> Lwt.return + finally + let (sofar, total, _) = Lwt_react.S.value progress in + set_progress (sofar, total, true); Lwt.return () - with ex -> - log_info ~ex "Download failed"; - Lwt.wakeup_exn waker ex; Lwt.return () - ); + end - try_lwt task - with Lwt.Canceled -> `aborted_by_user |> Lwt.return - finally - let (sofar, total, _) = Lwt_react.S.value progress in - set_progress (sofar, total, true); - Lwt.return () - end + method release = + Hashtbl.iter (fun _ site -> site#release) sites; + Hashtbl.clear sites + end diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/downloader.mli zeroinstall-injector-2.7/ocaml/zeroinstall/downloader.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/downloader.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/downloader.mli 2014-05-25 09:29:17.000000000 +0000 @@ -23,6 +23,7 @@ val is_in_progress : download -> bool +(* For use by unit-tests *) val interceptor : (?if_slow:unit Lazy.t -> ?size:Int64.t -> @@ -44,6 +45,10 @@ ?hint:([< Feed_url.parsed_feed_url] as 'b) -> string -> download_result Lwt.t > -type download_pool = monitor -> downloader +class type download_pool = + object + method with_monitor : monitor -> downloader + method release : unit + end val make_pool : max_downloads_per_site:int -> download_pool diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/driver.mli zeroinstall-injector-2.7/ocaml/zeroinstall/driver.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/driver.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/driver.mli 2014-05-25 09:29:17.000000000 +0000 @@ -11,7 +11,7 @@ * Returns None if we need to refresh feeds or download any implementations. *) val quick_solve : < config : General.config; distro : Distro.distribution; .. > -> - Requirements.requirements -> Selections.t option + Requirements.t -> Selections.t option (** Run the solver, then download any feeds that are missing or that need to be updated. Each time a new feed is imported into the cache, the solver is run @@ -29,7 +29,7 @@ val solve_with_downloads : General.config -> Distro.distribution -> Fetch.fetcher -> watcher:#Progress.watcher -> - Requirements.requirements -> + Requirements.t -> force:bool -> update_local:bool -> (bool * Solver.result * Feed_provider.feed_provider) Lwt.t @@ -38,7 +38,7 @@ * If the mirror replies first, but the primary succeeds, we return the primary. *) val download_and_import_feed : Fetch.fetcher -> - [ `remote_feed of General.feed_url ] -> + Feed_url.remote_feed -> [ `aborted_by_user | `no_update | `success of Support.Qdom.element ] Lwt.t diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/env.ml zeroinstall-injector-2.7/ocaml/zeroinstall/env.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/env.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/env.ml 2014-05-25 09:29:17.000000000 +0000 @@ -6,30 +6,27 @@ open Support.Common -type env = (string, string) Hashtbl.t +type t = (varname, string) Hashtbl.t -let copy_current_env system : env = +let create arr = let env = Hashtbl.create 1000 in - let parse_env line = + arr |> Array.iter (fun line -> match Str.bounded_split_delim Support.Utils.re_equals line 2 with | [key; value] -> Hashtbl.replace env key value | _ -> failwith (Printf.sprintf "Invalid environment mapping '%s'" line) - in - - Array.iter parse_env system#environment; + ); env -let putenv name value env = - (* Printf.fprintf stderr "Adding: %s=%s\n" name value; *) - Hashtbl.replace env name value +let put = Hashtbl.replace +let unset = Hashtbl.remove -let find name env = +let get_exn env name = try Hashtbl.find env name with Not_found -> raise_safe "Environment variable '%s' not set" name -let find_opt name env = +let get env name = try Some (Hashtbl.find env name) with Not_found -> None diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/env.mli zeroinstall-injector-2.7/ocaml/zeroinstall/env.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/env.mli 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/env.mli 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,16 @@ +(* Copyright (C) 2013, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** Environment variables (generic support code) *) + +open Support.Common + +type t + +val create : string array -> t +val put : t -> varname -> string -> unit +val get : t -> varname -> string option +val get_exn : t -> varname -> string +val unset : t -> varname -> unit +val to_array : t -> string array diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/exec.ml zeroinstall-injector-2.7/ocaml/zeroinstall/exec.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/exec.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/exec.ml 2014-05-25 09:29:17.000000000 +0000 @@ -31,7 +31,7 @@ method setenv name command_argv env = let open Yojson.Basic in let json :json = `List (List.map (fun a -> `String a) command_argv) in - Env.putenv ("zeroinstall-runenv-" ^ name) (to_string json) env + Env.put env ("zeroinstall-runenv-" ^ name) (to_string json) end (** If abspath_0install is a native binary, we can avoid starting a shell here. *) @@ -91,7 +91,7 @@ let () = match exec_type with | Binding.InPath -> Binding.prepend "PATH" exec_dir path_sep env - | Binding.InVar -> Env.putenv name exec_path env in + | Binding.InVar -> Env.put env name exec_path in builder#setenv name command_argv env @@ -111,7 +111,7 @@ !map let get_exec_args config ?main sels args = - let env = Env.copy_current_env config.system in + let env = Env.create config.system#environment in let impls = make_selection_map config.system config.stores sels in let bindings = Binding.collect_bindings impls sels in let launcher_builder = get_launcher_builder config in diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed_cache.ml zeroinstall-injector-2.7/ocaml/zeroinstall/feed_cache.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed_cache.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/feed_cache.ml 2014-05-25 09:29:17.000000000 +0000 @@ -148,26 +148,26 @@ match feed_import.Feed.feed_type with | Feed.Distro_packages | Feed.Feed_import -> None | Feed.User_registered | Feed.Site_packages -> - let attrs = ref [(IfaceConfigAttr.src, Feed_url.format_url feed_import.Feed.feed_src)] in + let attrs = ref (Q.AttrMap.singleton IfaceConfigAttr.src (Feed_url.format_url feed_import.Feed.feed_src)) in if feed_import.Feed.feed_type = Feed.Site_packages then - attrs := (IfaceConfigAttr.is_site_package, "True") :: !attrs; + attrs := !attrs |> Q.AttrMap.add_no_ns IfaceConfigAttr.is_site_package "True"; begin match feed_import.Feed.feed_os, feed_import.Feed.feed_machine with | None, None -> () | os, machine -> let arch = Arch.format_arch os machine in - attrs := (IfaceConfigAttr.arch, arch) :: !attrs end; - Some (ZI.make ~attrs:(Q.attrs_of_list !attrs) "feed") + attrs := !attrs |> Q.AttrMap.add_no_ns IfaceConfigAttr.arch arch end; + Some (ZI.make ~attrs:!attrs "feed") let save_iface_config config uri iface_config = let config_dir = Basedir.save_path config.system config_injector_interfaces config.basedirs.Basedir.config in - let attrs = ref [(FeedAttr.uri, uri)] in + let attrs = ref (Q.AttrMap.singleton FeedAttr.uri uri) in iface_config.stability_policy |> if_some (fun policy -> - attrs := (IfaceConfigAttr.stability_policy, Feed.format_stability policy) :: !attrs + attrs := !attrs |> Q.AttrMap.add_no_ns IfaceConfigAttr.stability_policy (Feed.format_stability policy) ); let child_nodes = iface_config.extra_feeds |> U.filter_map add_import_elem in - let root = ZI.make ~attrs:(Q.attrs_of_list !attrs) ~child_nodes "interface-preferences" in + let root = ZI.make ~attrs:!attrs ~child_nodes "interface-preferences" in config_dir +/ Escape.pretty uri |> config.system#atomic_write [Open_wronly; Open_binary] ~mode:0o644 (fun ch -> Q.output (`Channel ch |> Xmlm.make_output) root; diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed_cache.mli zeroinstall-injector-2.7/ocaml/zeroinstall/feed_cache.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed_cache.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/feed_cache.mli 2014-05-25 09:29:17.000000000 +0000 @@ -15,8 +15,8 @@ (** Load a cached feed. * As a convenience, this will also load local feeds. *) val get_cached_feed : config -> [< Feed_url.non_distro_feed] -> Feed.feed option -val get_cached_feed_path : config -> [`remote_feed of feed_url] -> filepath option -val get_save_cache_path : config -> [`remote_feed of feed_url] -> filepath +val get_cached_feed_path : config -> Feed_url.remote_feed -> filepath option +val get_save_cache_path : config -> Feed_url.remote_feed -> filepath val get_cached_icon_path : config -> [< Feed_url.non_distro_feed] -> filepath option @@ -27,15 +27,15 @@ (** Check whether feed [url] is stale. * Returns false if it's stale but last-check-attempt is recent *) -val is_stale : config -> [`remote_feed of feed_url] -> bool +val is_stale : config -> Feed_url.remote_feed -> bool (** Low-level part of [is_stale] that doesn't automatically load the feed overrides (needed to get [last_checked]). * Useful if you've already loaded them yourself (or confirmed they're missing) to avoid doing it twice. *) -val internal_is_stale : config -> [`remote_feed of feed_url] -> Feed.feed_overrides option -> bool +val internal_is_stale : config -> Feed_url.remote_feed -> Feed.feed_overrides option -> bool (** Touch a 'last-check-attempt' timestamp file for this feed. This prevents us from repeatedly trying to download a failing feed many times in a short period. *) -val mark_as_checking : config -> [`remote_feed of feed_url] -> unit +val mark_as_checking : config -> Feed_url.remote_feed -> unit -val get_last_check_attempt : config -> [`remote_feed of feed_url] -> float option +val get_last_check_attempt : config -> Feed_url.remote_feed -> float option diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed.ml zeroinstall-injector-2.7/ocaml/zeroinstall/feed.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/feed.ml 2014-05-25 09:29:17.000000000 +0000 @@ -58,11 +58,11 @@ and command = { mutable command_qdom : Q.element; command_requires : dependency list; - (* command_bindings : binding list; - not needed by solver; just copies the element *) + command_bindings : binding list; } and properties = { - attrs : (string * string) AttrMap.t; + attrs : AttrMap.t; requires : dependency list; bindings : binding list; commands : command StringMap.t; @@ -140,11 +140,13 @@ let value_testing = "testing" let make_command ?source_hint name ?(new_attr="path") path : command = - let attrs = [("name", name); (new_attr, path)] |> Q.attrs_of_list in + let attrs = AttrMap.singleton "name" name + |> AttrMap.add_no_ns new_attr path in let elem = ZI.make ?source_hint ~attrs "command" in { command_qdom = elem; command_requires = []; + command_bindings = []; } let make_distribtion_restriction distros = @@ -261,17 +263,21 @@ let parse_command local_dir elem : command = let deps = ref [] in + let bindings = ref [] in elem |> ZI.iter (fun child -> match ZI.tag child with | Some "requires" | Some "restricts" | Some "runner" -> deps := parse_dep local_dir child :: !deps + | Some b when Binding.is_binding b -> + bindings := child :: !bindings | _ -> () ); { command_qdom = elem; command_requires = !deps; + command_bindings = !bindings; } let rec filter_if_0install_version node = @@ -405,12 +411,7 @@ if !new_bindings <> [] then s := {!s with bindings = !s.bindings @ (List.rev !new_bindings)}; - let new_attrs = - let attrs = ref !s.attrs in - item.Q.attrs |> AttrMap.iter (fun name_pair value -> - attrs := !attrs |> AttrMap.add name_pair value - ); - !attrs in + let new_attrs = !s.attrs |> AttrMap.add_all item.Q.attrs in s := {!s with attrs = new_attrs; @@ -541,9 +542,9 @@ let is_source impl = impl.machine = Some "src" -let get_command_opt command_name commands = StringMap.find command_name commands +let get_command_opt command_name impl = StringMap.find command_name impl.props.commands -let get_command_ex impl command_name : command = +let get_command_ex command_name impl : command = StringMap.find command_name impl.props.commands |? lazy (Q.raise_elem "Command '%s' not found in" command_name impl.qdom) (** Load per-feed extra data (last-checked time and preferred stability. @@ -581,13 +582,12 @@ let attrs = match last_checked with | None -> AttrMap.empty - | Some last_checked -> - [("last-checked", (Printf.sprintf "%.0f" last_checked))] |> Q.attrs_of_list in + | Some last_checked -> AttrMap.singleton "last-checked" (Printf.sprintf "%.0f" last_checked) in let child_nodes = user_stability |> StringMap.map_bindings (fun id stability -> - ZI.make "implementation" ~attrs:(Q.attrs_of_list [ - (FeedAttr.id, id); - (FeedConfigAttr.user_stability, (format_stability stability)); - ]) + ZI.make "implementation" ~attrs:( + AttrMap.singleton FeedAttr.id id + |> AttrMap.add_no_ns FeedConfigAttr.user_stability (format_stability stability) + ) ) in let root = ZI.make ~attrs ~child_nodes "feed-preferences" in let url = Feed_url.format_url feed_url in @@ -644,9 +644,7 @@ let get_description = get_text "description" let get_feed_targets feed = - ZI.map feed.root "feed-for" ~f:(fun feed_for -> - ZI.get_attribute FeedAttr.interface feed_for - ) + feed.root |> ZI.map ~name:"feed-for" (ZI.get_attribute FeedAttr.interface) let make_user_import feed_src = { feed_src = (feed_src :> Feed_url.non_distro_feed); diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed.mli zeroinstall-injector-2.7/ocaml/zeroinstall/feed.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/feed.mli 2014-05-25 09:29:17.000000000 +0000 @@ -49,10 +49,10 @@ and command = { mutable command_qdom : Support.Qdom.element; (* Mutable because of distro's [fixup_main] *) command_requires : dependency list; - (* command_bindings : binding list; - not needed by solver; just copies the element *) + command_bindings : binding list; } and properties = { - attrs : (string * string) Support.Qdom.AttrMap.t; (* (prefix_hint, value) *) + attrs : Support.Qdom.AttrMap.t; requires : dependency list; bindings : binding list; commands : command Support.Common.StringMap.t; @@ -123,12 +123,12 @@ val get_implementations : feed -> generic_implementation list val is_source : _ implementation -> bool -val get_command_opt : string -> command Support.Common.StringMap.t -> command option -val get_command_ex : _ implementation -> string -> command +val get_command_opt : string -> _ implementation -> command option +val get_command_ex : string -> _ implementation -> command val load_feed_overrides : General.config -> [< Feed_url.parsed_feed_url] -> feed_overrides val save_feed_overrides : General.config -> [< Feed_url.parsed_feed_url] -> feed_overrides -> unit -val update_last_checked_time : General.config -> [< `remote_feed of General.feed_url] -> unit +val update_last_checked_time : General.config -> [< Feed_url.remote_feed] -> unit val get_langs : _ implementation -> Support.Locale.lang_spec list val is_available_locally : General.config -> _ implementation -> bool val is_retrievable_without_network : cache_impl -> bool @@ -138,7 +138,7 @@ (** The elements' interfaces *) val get_feed_targets : feed -> General.iface_uri list -val make_user_import : [<`local_feed of Support.Common.filepath | `remote_feed of General.feed_url] -> feed_import +val make_user_import : [< Feed_url.non_distro_feed] -> feed_import val get_category : feed -> string option val needs_terminal : feed -> bool diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed_provider.mli zeroinstall-injector-2.7/ocaml/zeroinstall/feed_provider.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed_provider.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/feed_provider.mli 2014-05-25 09:29:17.000000000 +0000 @@ -6,13 +6,13 @@ class type feed_provider = object - method forget_distro : Feed_url.FeedMap.key -> unit + method forget_distro : Feed_url.non_distro_feed -> unit method forget_user_feeds : General.iface_uri -> unit method get_distro_impls : Feed.feed -> Feed.distro_implementation Support.Common.StringMap.t * Feed.feed_overrides - method get_feed : Feed_url.FeedMap.key -> (Feed.feed * Feed.feed_overrides) option - method get_feeds_used : Feed_url.FeedMap.key list + method get_feed : Feed_url.non_distro_feed -> (Feed.feed * Feed.feed_overrides) option + method get_feeds_used : Feed_url.non_distro_feed list method get_iface_config : General.iface_uri -> Feed_cache.interface_config method have_stale_feeds : bool - method replace_feed : Feed_url.FeedMap.key -> Feed.feed -> unit - method was_used : Feed_url.FeedMap.key -> bool + method replace_feed : Feed_url.non_distro_feed -> Feed.feed -> unit + method was_used : Feed_url.non_distro_feed -> bool end diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed_url.ml zeroinstall-injector-2.7/ocaml/zeroinstall/feed_url.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed_url.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/feed_url.ml 2014-05-25 09:29:17.000000000 +0000 @@ -5,8 +5,10 @@ open Support.Common module U = Support.Utils -type non_distro_feed = [`local_feed of Support.Common.filepath | `remote_feed of string] -type parsed_feed_url = [`distribution_feed of non_distro_feed | non_distro_feed ] +type local_feed = [`local_feed of Support.Common.filepath] +type remote_feed = [`remote_feed of string] +type non_distro_feed = [local_feed | remote_feed] +type parsed_feed_url = [`distribution_feed of non_distro_feed | non_distro_feed] let parse_non_distro url = if U.path_is_absolute url then `local_feed url diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed_url.mli zeroinstall-injector-2.7/ocaml/zeroinstall/feed_url.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/feed_url.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/feed_url.mli 2014-05-25 09:29:17.000000000 +0000 @@ -4,8 +4,10 @@ (** Feed URLs *) -type non_distro_feed = [`local_feed of Support.Common.filepath | `remote_feed of string] -type parsed_feed_url = [`distribution_feed of non_distro_feed | non_distro_feed ] +type local_feed = [`local_feed of Support.Common.filepath] +type remote_feed = [`remote_feed of string] +type non_distro_feed = [local_feed | remote_feed] +type parsed_feed_url = [`distribution_feed of non_distro_feed | non_distro_feed] (** A globally-unique identifier for an implementation. *) type global_id = { @@ -20,7 +22,7 @@ val format_url : [< parsed_feed_url] -> General.feed_url (** Get the master feed for an interface URI. Internally, this is just [parse_non_distro]. *) -val master_feed_of_iface : General.iface_uri -> [>non_distro_feed] +val master_feed_of_iface : General.iface_uri -> [> non_distro_feed] module FeedSet : (Set.S with type elt = non_distro_feed) module FeedMap : (Map.S with type key = non_distro_feed) diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/fetch.ml zeroinstall-injector-2.7/ocaml/zeroinstall/fetch.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/fetch.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/fetch.ml 2014-05-25 09:29:17.000000000 +0000 @@ -18,8 +18,6 @@ | `problem of (string * fetch_feed_response Lwt.t option) (* Report a problem (but may still succeed later) *) | `no_update ] (* Use the previous version *) -let re_scheme_sep = Str.regexp_string "://" - let string_of_result = function | `aborted_by_user -> "Aborted by user" | `no_trusted_keys -> "Not signed with a trusted key" @@ -40,8 +38,6 @@ (* Don't bother trying the mirror if we have a replay attack *) `problem (string_of_result r, None) -let re_remote_feed = Str.regexp "^\\(https?\\)://\\([^/]*@\\)?\\([^/:]+\\)\\(:[^/]*\\)?/" - (** Wait for a set of tasks to complete. Return the exceptions produced by each, if any. *) let rec join_errors = function | [] -> Lwt.return [] @@ -51,28 +47,15 @@ lwt exs = join_errors xs in ex :: exs |> Lwt.return -let parse_key_info xml = - Empty.check_tag "key-lookup" xml; - xml.Q.child_nodes |> U.filter_map (fun child -> - match Empty.tag child with - | Some "item" -> - let msg = child.Q.last_text_inside in - if Empty.get_attribute_opt "vote" child = Some "good" then - Some (Progress.Good, msg) - else - Some (Progress.Bad, msg) - | _ -> None - ) - exception Aborted exception Try_mirror of string (* An error where we should try the mirror (i.e. a network problem) *) -class fetcher config trust_db (distro:Distro.distribution) (download_pool:Downloader.download_pool) (ui:#Progress.watcher) = - let downloader = download_pool ui#monitor in +class fetcher config (trust_db:Trust.trust_db) (distro:Distro.distribution) (download_pool:Downloader.download_pool) (ui:#Progress.watcher) = + let downloader = download_pool#with_monitor ui#monitor in let trust_dialog_lock = Lwt_mutex.create () in (* Only show one trust dialog at a time *) - let key_info_cache = Hashtbl.create 10 in + let key_info_provider = Key_info_provider.make config in let system = config.system in @@ -203,39 +186,6 @@ | Some _ -> save_new_xml () ) in - let fetch_key_info ~if_slow ~hint fingerprint : Progress.key_vote list Lwt.t = - try - let result = Hashtbl.find key_info_cache fingerprint in - match Lwt.state result with - | Lwt.Return _ | Lwt.Sleep -> result - | Lwt.Fail _ -> raise Not_found (* Retry *) - with Not_found -> - let result = - try_lwt - match config.key_info_server with - | None -> Lwt.return [] - | Some key_info_server -> - if config.dry_run then ( - Dry_run.log "asking %s about key %s" key_info_server fingerprint; - ); - let key_info_url = key_info_server ^ "/key/" ^ fingerprint in - let switch = Lwt_switch.create () in - try_lwt - match_lwt downloader#download ~switch ~if_slow ~hint key_info_url with - | `network_failure msg -> raise_safe "%s" msg - | `aborted_by_user -> raise Aborted - | `tmpfile tmpfile -> - let contents = U.read_file system tmpfile in - let root = `String (0, contents) |> Xmlm.make_input |> Q.parse_input (Some key_info_url) in - Lwt.return (parse_key_info root) - finally - Lwt_switch.turn_off switch - with Safe_exception (msg, _) as ex -> - log_info ~ex "Error fetching key info"; - Lwt.return [(Progress.Bad, "Error fetching key info: " ^ msg)] in - Hashtbl.add key_info_cache fingerprint result; - result in - (** We don't trust any of the signatures yet. Collect information about them and add the keys to the trust_db, possibly after confirming with the user. *) let confirm_keys feed sigs messages = @@ -261,8 +211,9 @@ let if_slow = lazy (Lwt.wakeup timeout_waker []) in (* Start downloading information about the keys... *) + let key_downloader ~switch url = downloader#download ~switch ~if_slow ~hint:feed url in let key_infos = valid_sigs |> List.map (fun {G.fingerprint; _} -> - (fingerprint, fetch_key_info ~if_slow ~hint:feed fingerprint) + (fingerprint, Key_info_provider.get key_info_provider ~download:key_downloader fingerprint) ) in log_info "Waiting for response from key-info server..."; @@ -364,55 +315,6 @@ | #non_mirror_case as result -> get_final_response result |> Lwt.return | `problem msg -> `problem (msg, None) |> Lwt.return in - let escape_slashes s = Str.global_replace U.re_slash "%23" s in - - (* The algorithm from 0mirror. *) - let get_feed_dir = function - | `remote_feed feed -> - if String.contains feed '#' then ( - raise_safe "Invalid URL '%s'" feed - ) else ( - let scheme, rest = U.split_pair re_scheme_sep feed in - if not (String.contains rest '/') then - raise_safe "Missing / in %s" feed; - let domain, rest = U.split_pair U.re_slash rest in - [scheme; domain; rest] |> List.iter (fun part -> - if part = "" || U.starts_with part "." then - raise_safe "Invalid URL '%s'" feed - ); - String.concat "/" ["feeds"; scheme; domain; escape_slashes rest] - ) in - - (* Don't bother trying the mirror for localhost URLs. *) - let can_try_mirror url = - if Str.string_match re_remote_feed url 0 then ( - let scheme = Str.matched_group 1 url in - let domain = Str.matched_group 3 url in - match scheme with - | "http" | "https" when domain <> "localhost" -> true - | _ -> false - ) else ( - log_warning "Failed to parse URL '%s'" url; - false - ) in - - let get_mirror_url mirror feed_url resource = - match feed_url with - | `local_feed _ | `distribution_feed _ -> None - | `remote_feed url as feed_url -> - if can_try_mirror url then - Some (mirror ^ "/" ^ (get_feed_dir feed_url) ^ "/" ^ resource) - else None in - - (** Get a recipe for the tar.bz2 of the implementation at the mirror. - * Note: This is just one way we try the mirror. Code elsewhere checks for mirrors of the individual archives. - * This is for a single archive containing the whole implementation. *) - let get_impl_mirror_recipe mirror impl = - let {Feed_url.feed; Feed_url.id} = Feed.get_id impl in - match get_mirror_url mirror feed ("impl/" ^ escape_slashes id) with - | None -> None - | Some url -> Some (Recipe.get_mirror_download url) in - let download_local_file feed size fn url = let size = size |? lazy (raise_safe "Missing size (BUG)!") in (* Only missing for mirror downloads, which are never local *) match feed with @@ -436,12 +338,7 @@ (* Remote file *) if config.dry_run then Dry_run.log "downloading %s" url; - let mirror_url = - match config.mirror with - | Some mirror when may_use_mirror && can_try_mirror url -> - let escaped = Str.global_replace (Str.regexp_string "/") "#" url |> Curl.escape in - Some (mirror ^ "/archive/" ^ escaped) - | _ -> None in + let mirror_url = if may_use_mirror then Mirror.for_archive config url else None in match_lwt downloader#download ~switch ?size ~start_offset ~hint:feed url with | `aborted_by_user -> raise Aborted | `tmpfile tmpfile -> lazy (fn tmpfile) |> Lwt.return @@ -601,17 +498,14 @@ | `success -> Lwt.return () | `aborted_by_user -> raise Aborted | `network_failure orig_msg -> - match config.mirror with - | None -> raise_safe "%s" orig_msg - | Some mirror -> - log_info "%s: trying implementation mirror at %s" orig_msg mirror; - let mirror_download = get_impl_mirror_recipe mirror impl |? lazy (raise_safe "%s" orig_msg) in - match_lwt download ~may_use_mirror:false mirror_download with - | `aborted_by_user -> raise Aborted - | `success -> Lwt.return () - | `network_failure mirror_msg -> - log_info "Error from mirror: %s" mirror_msg; - raise_safe "%s" orig_msg + let mirror_download = Mirror.for_impl config impl |? lazy (raise_safe "%s" orig_msg) in + log_info "%s: trying implementation mirror at %s" orig_msg (config.mirror |> default "-"); + match_lwt download ~may_use_mirror:false mirror_download with + | `aborted_by_user -> raise Aborted + | `success -> Lwt.return () + | `network_failure mirror_msg -> + log_info "Error from mirror: %s" mirror_msg; + raise_safe "%s" orig_msg with Safe_exception _ as ex -> let {Feed_url.feed; Feed_url.id} = Feed.get_id impl in let version = Feed.get_attr_ex FeedAttr.version impl in @@ -632,13 +526,9 @@ let primary = download_and_import_feed_internal ~mirror_used:None feed ~if_slow ~url:feed_url in let do_mirror_download () = try - match config.mirror with - | None -> None - | Some mirror -> - match get_mirror_url mirror feed "latest.xml" with - | None -> None - | Some mirror_url -> - Some (download_and_import_feed_internal ~mirror_used:(Some mirror) feed ~url:mirror_url) + Mirror.for_feed config feed |> pipe_some (fun mirror_url -> + Some (download_and_import_feed_internal ~mirror_used:config.mirror feed ~url:mirror_url) + ) with ex -> log_warning ~ex "Error getting mirror URL for '%s" feed_url; None in @@ -774,3 +664,74 @@ method ui = (ui :> Progress.watcher) end + +(** If [ZEROINSTALL_EXTERNAL_FETCHER] is set, we override [download_impls] to ask an + * external process to do the downloading and unpacking. This is needed on Windows + * because X bits need some special support that is implemented in .NET. *) +class external_fetcher command underlying = + let rec add_mime_types node = + match ZI.tag node with + | Some "recipe" -> + { node with Q.child_nodes = node.Q.child_nodes |> List.map add_mime_types } + | Some "archive" when ZI.get_attribute_opt "type" node = None -> + let mime_type = ZI.get_attribute "href" node |> Archive.type_from_url in + { node with Q.attrs = node.Q.attrs |> Q.AttrMap.add_no_ns "type" mime_type } + | _ -> node in + + object (_ : #fetcher) + method import_feed = underlying#import_feed + method download_icon = underlying#download_icon + method download_and_import_feed = underlying#download_and_import_feed + method ui = underlying#ui + + method download_impls impls = + try_lwt + let child_nodes = impls |> List.map (function + | { qdom; Feed.impl_type = `cache_impl { Feed.digests; _}; _} -> + let attrs = ref Q.AttrMap.empty in + digests |> List.iter (fun (name, value) -> + attrs := !attrs |> Q.AttrMap.add_no_ns name value + ); + let manifest_digest = ZI.make ~attrs:!attrs "manifest-digest" in + let child_nodes = qdom.Q.child_nodes |> List.map add_mime_types in + { qdom with + Q.child_nodes = manifest_digest :: child_nodes + } + | impl -> impl.Feed.qdom + ) in + let root = ZI.make ~child_nodes "interface" in + + (* Crazy Lwt API to split a command into words and search in PATH *) + let lwt_command = ("", [| "\000" ^ command |]) in + + log_info "Running external fetcher: %s" command; + let child = Lwt_process.open_process_full lwt_command in + + (* .NET helper API wants an XML document with no line-breaks. Multi-line fields + * aren't used for anything here, so just replace with spaces. *) + let msg = Q.to_utf8 root |> String.map (function '\n' -> ' ' | x -> x) in + log_debug "Sending XML to fetcher process:\n%s" msg; + lwt () = (Lwt_io.write child#stdin (msg ^ "\n") >> Lwt_io.close child#stdin) + and output = Lwt_io.read child#stdout + and errors = Lwt_io.read child#stderr in + + log_debug "External fetch process complete"; + + try_lwt + lwt status = child#close in + Support.System.check_exit_status status; + Lwt.return `success + with Safe_exception _ as ex -> + reraise_with_context ex "stdout: %s\nstderr: %s" output errors + with Safe_exception _ as ex -> + reraise_with_context ex "... downloading with external fetcher '%s'" command + + end + +let make config trust_db distro download_pool ui = + let fetcher = new fetcher config trust_db distro download_pool ui in + match config.system#getenv "ZEROINSTALL_EXTERNAL_FETCHER" with + | None -> fetcher + | Some command -> + try new external_fetcher command fetcher + with Safe_exception _ as ex -> reraise_with_context ex "... handling $ZEROINSTALL_EXTERNAL_FETCHER" diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/fetch.mli zeroinstall-injector-2.7/ocaml/zeroinstall/fetch.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/fetch.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/fetch.mli 2014-05-25 09:29:17.000000000 +0000 @@ -8,17 +8,20 @@ | `problem of (string * fetch_feed_response Lwt.t option) (* Report a problem (but may still succeed later) *) | `no_update ] (* Use the previous version *) -class fetcher : General.config -> Trust.trust_db -> Distro.distribution -> Downloader.download_pool -> #Progress.watcher -> +class type fetcher = object - method download_and_import_feed : [ `remote_feed of General.feed_url ] -> fetch_feed_response Lwt.t + method download_and_import_feed : Feed_url.remote_feed -> fetch_feed_response Lwt.t method download_impls : Feed.generic_implementation list -> [ `success | `aborted_by_user ] Lwt.t (** [import_feed url xml] checks the signature on [xml] and imports it into the cache if trusted. * If not trusted, it confirms with the user first, downloading any missing keys first. *) - method import_feed : [`remote_feed of General.feed_url] -> string -> unit Lwt.t + method import_feed : Feed_url.remote_feed -> string -> unit Lwt.t (** Download the icon and add it to the disk cache as the icon for the given feed. *) method download_icon : Feed_url.non_distro_feed -> string -> unit Lwt.t method ui : Progress.watcher end + +(** Create a fetcher for this platform. *) +val make : General.config -> Trust.trust_db -> Distro.distribution -> Downloader.download_pool -> #Progress.watcher -> fetcher diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/gui.ml zeroinstall-injector-2.7/ocaml/zeroinstall/gui.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/gui.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/gui.ml 2014-05-25 09:29:17.000000000 +0000 @@ -127,29 +127,14 @@ let bad_impls = List.map (fun (i, prob) -> (i, Some prob)) candidates.rejects in let all_impls = List.sort by_version @@ good_impls @ bad_impls in - let selected_impl = - if selected_impl.F.parsed_version = Versions.dummy then None else Some selected_impl in - Some (selected_impl, all_impls) in - let get_selected ~source = - match results#impl_cache#peek (iface, source) with - | None -> None - | Some candidates -> - match candidates#get_selected with - | None -> None - | Some (_lit, impl) -> Some impl in (* Also true for [dummy_impl] *) - - match get_selected ~source:true with - | Some source_impl -> make_list ~source:true source_impl + match results#get_selected ~source:true iface with + | Some _ as source_impl -> make_list ~source:true source_impl | None -> - match get_selected ~source:false with - | Some bin_impl -> make_list ~source:false bin_impl - | None -> - (* We didn't look at this interface at all, so no information will be cached. - * There's a risk of deadlock if we try to fetch distro candidates in the callback, so - * we return nothing, which will cause the GUI to shade the dialog. *) - None + match results#get_selected ~source:false iface with + | Some _ as bin_impl -> make_list ~source:false bin_impl + | None -> make_list ~source:false None (** Download an icon for this feed and add it to the icon cache. If the feed has no icon do nothing. *) diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/gui.mli zeroinstall-injector-2.7/ocaml/zeroinstall/gui.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/gui.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/gui.mli 2014-05-25 09:29:17.000000000 +0000 @@ -23,9 +23,10 @@ val add_remote_feed : General.config -> Fetch.fetcher -> - General.iface_uri -> [`remote_feed of General.feed_url] -> unit Lwt.t + General.iface_uri -> Feed_url.remote_feed -> unit Lwt.t + (** Add a local feed to an interface. *) -val add_feed : General.config -> General.iface_uri -> [`local_feed of Support.Common.filepath] -> unit +val add_feed : General.config -> General.iface_uri -> Feed_url.local_feed -> unit val remove_feed : General.config -> General.iface_uri -> Feed_url.non_distro_feed -> unit val compile : General.config -> Feed_provider.feed_provider -> General.iface_uri -> autocompile:bool -> unit Lwt.t diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/helpers.ml zeroinstall-injector-2.7/ocaml/zeroinstall/helpers.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/helpers.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/helpers.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,38 +0,0 @@ -(* Copyright (C) 2013, Thomas Leonard - * See the README file for details, or visit http://0install.net. - *) - -(** High-level helper functions *) - -open General -open Support.Common -module Basedir = Support.Basedir -module FeedAttr = Constants.FeedAttr -module R = Requirements -module U = Support.Utils -module Q = Support.Qdom - -type select_mode = [ - | `Select_only (* only download feeds, not archives; display "Select" in GUI *) - | `Download_only (* download archives too; refresh if stale feeds; display "Download" in GUI *) - | `Select_for_run (* download archives; update stale in background; display "Run" in GUI *) -] - -let make_ui config use_gui : Ui.ui_handler = - let use_gui = - match use_gui, config.dry_run with - | Yes, true -> raise_safe "Can't use GUI with --dry-run" - | (Maybe|No), true -> No - | use_gui, false -> use_gui in - - let make_no_gui () = - if config.system#isatty Unix.stderr then - (new Console.console_ui :> Ui.ui_handler) - else - (new Console.batch_ui :> Ui.ui_handler) in - - match use_gui with - | No -> make_no_gui () - | Yes | Maybe -> - (* [try_get_gui] will throw if use_gui is [Yes] and the GUI isn't available *) - Gui.try_get_gui config ~use_gui |? lazy (make_no_gui ()) diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/helpers.mli zeroinstall-injector-2.7/ocaml/zeroinstall/helpers.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/helpers.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/helpers.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -(* Copyright (C) 2013, Thomas Leonard - * See the README file for details, or visit http://0install.net. - *) - -(** High-level helper functions *) - -type select_mode = [ - | `Select_only (* only download feeds, not archives; display "Select" in GUI *) - | `Download_only (* download archives too; refresh if stale feeds; display "Download" in GUI *) - | `Select_for_run (* download archives; update stale in background; display "Run" in GUI *) -] - -(** Create a UI appropriate for the current environment and user options. - * This will be a graphical UI if [Gui.try_get_gui] returns one and we're not in dry-run mode. - * Otherwise, it will be an interactive console UI if stderr is a tty. - * Otherwise, it will be a batch UI (no progress display). - *) -val make_ui : - General.config -> - Support.Common.yes_no_maybe -> - Ui.ui_handler diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/impl_provider.mli zeroinstall-injector-2.7/ocaml/zeroinstall/impl_provider.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/impl_provider.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/impl_provider.mli 2014-05-25 09:29:17.000000000 +0000 @@ -63,9 +63,7 @@ class default_impl_provider : General.config -> Feed_provider.feed_provider -> scope_filter -> object - method extra_restrictions : Feed.restriction Support.Common.StringMap.t - method get_implementations : General.iface_uri -> source:bool -> candidates - method is_dep_needed : Feed.dependency -> bool + inherit impl_provider method set_watch_iface : General.iface_uri -> unit method get_watched_compare : (Feed.generic_implementation -> Feed.generic_implementation -> int * preferred_reason) option diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/json_connection.ml zeroinstall-injector-2.7/ocaml/zeroinstall/json_connection.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/json_connection.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/json_connection.ml 2014-05-25 09:29:17.000000000 +0000 @@ -49,8 +49,7 @@ [ J.json | `WithXML of (J.json * Support.Qdom.element) ] -class json_connection ~from_peer ~to_peer = - let handlers = ref StringMap.empty in +class json_connection ~from_peer ~to_peer handle_request = let finished, finish = Lwt.wait () in let send_json ?xml request : unit Lwt.t = @@ -83,12 +82,12 @@ let handle_invoke ticket op args () = let xml = ref None in + lwt handle_request = handle_request in lwt response = try_lwt lwt return_value = - let cb = StringMap.find op !handlers |? lazy (raise_safe "No handler for JSON op '%s' (received from peer)" op) in try_lwt - match_lwt cb args with + match_lwt handle_request (op, args) with | `WithXML (json, attached_xml) -> xml := Some attached_xml; Lwt.return json @@ -104,28 +103,31 @@ let () = async (fun () -> try_lwt - let finished = ref false in - while_lwt not !finished do - lwt request = read_chunk from_peer in - begin match request with - | None -> log_debug "handle_messages: channel closed, so stopping handler"; finished := true - | Some (`List [`String "invoke"; `String ticket; `String op; `List args]) -> - async @@ handle_invoke ticket op args; - | Some (`List [`String "return"; `String ticket; `String success; result]) -> - let resolver = - try Hashtbl.find pending_replies ticket - with Not_found -> raise_safe "Unknown ticket ID: %s" ticket in - Hashtbl.remove pending_replies ticket; - begin match success with - | "ok" -> Lwt.wakeup resolver result; - | "fail" -> Lwt.wakeup_exn resolver (Safe_exception (J.Util.to_string result, ref [])) - | _ -> raise_safe "Invalid success type '%s' from peer:\n" success end; - | Some json -> raise_safe "Invalid JSON from peer:\n%s" (J.to_string json) end; - Lwt.return () - done - finally + lwt () = + let finished = ref false in + while_lwt not !finished do + lwt request = read_chunk from_peer in + begin match request with + | None -> log_debug "handle_messages: channel closed, so stopping handler"; finished := true + | Some (`List [`String "invoke"; `String ticket; `String op; `List args]) -> + async @@ handle_invoke ticket op args; + | Some (`List [`String "return"; `String ticket; `String success; result]) -> + let resolver = + try Hashtbl.find pending_replies ticket + with Not_found -> raise_safe "Unknown ticket ID: %s" ticket in + Hashtbl.remove pending_replies ticket; + begin match success with + | "ok" -> Lwt.wakeup resolver result; + | "fail" -> Lwt.wakeup_exn resolver (Safe_exception (J.Util.to_string result, ref [])) + | _ -> raise_safe "Invalid success type '%s' from peer:\n" success end; + | Some json -> raise_safe "Invalid JSON from peer:\n%s" (J.to_string json) end; + Lwt.return () + done in Lwt.wakeup finish (); Lwt.return () + with ex -> + Lwt.wakeup_exn finish ex; + Lwt.return () ) in object @@ -144,8 +146,5 @@ method notify ?xml op args = send_json ?xml (`List [`String "invoke"; `Null; `String op; `List args]) - method register_handler op (handler:J.json list -> json_with_xml Lwt.t) = - handlers := StringMap.add op handler !handlers - method run = finished end diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/key_info_provider.ml zeroinstall-injector-2.7/ocaml/zeroinstall/key_info_provider.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/key_info_provider.ml 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/key_info_provider.ml 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,60 @@ +(* Copyright (C) 2014, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +open General +open Support.Common + +module U = Support.Utils +module Q = Support.Qdom +module G = Support.Gpg +module KI = Empty (* Key info XML documents don't have a namespace. *) + +type t = (General.config * (G.fingerprint, Progress.key_vote list Lwt.t) Hashtbl.t) + +let make config = (config, Hashtbl.create 10) + +let parse_key_info xml = + xml |> KI.check_tag "key-lookup"; + xml |> KI.map ~name:"item" (fun child -> + let msg = child.Q.last_text_inside in + if KI.get_attribute_opt "vote" child = Some "good" then + (Progress.Good, msg) + else + (Progress.Bad, msg) + ) + +let get (config, cache) ~download fingerprint = + try Hashtbl.find cache fingerprint + with Not_found -> + let result = + try_lwt + match config.key_info_server with + | None -> Lwt.return [] + | Some key_info_server -> + if config.dry_run then ( + Dry_run.log "asking %s about key %s" key_info_server fingerprint; + ); + let key_info_url = key_info_server ^ "/key/" ^ fingerprint in + U.with_switch (fun switch -> + match_lwt download ~switch key_info_url with + | `network_failure msg -> + Hashtbl.remove cache fingerprint; + log_info "Error fetching key info: %s" msg; + [Progress.Bad, "Error fetching key info: " ^ msg] |> Lwt.return + | `aborted_by_user -> + Hashtbl.remove cache fingerprint; + [Progress.Bad, "Key lookup aborted by user"] |> Lwt.return + | `tmpfile tmpfile -> + Q.parse_file config.system ~name:key_info_url tmpfile + |> parse_key_info |> Lwt.return + ) + with ex -> + log_warning ~ex "Error fetching key info"; + Hashtbl.remove cache fingerprint; + Lwt.return [Progress.Bad, "Error fetching key info: " ^ (Printexc.to_string ex)] in + + (* Add the pending result immediately. + * If the lookup fails, we'll remove it later. *) + Hashtbl.add cache fingerprint result; + result diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/key_info_provider.mli zeroinstall-injector-2.7/ocaml/zeroinstall/key_info_provider.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/key_info_provider.mli 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/key_info_provider.mli 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,20 @@ +(* Copyright (C) 2014, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** Queries the configured key info server for advice about GPG keys. *) + +type t + +val make : General.config -> t + +(** [get provider downloader fingerprint] requests information about the given GPG key. + * If the info is in the cache, returns it immediately. + * If we are already fetching this information, returns the existing task. + * If the previous fetch failed, tries again. + * On error, returns a [Bad] response rather than raising an exception. *) +val get : + t -> + download:(switch:Lwt_switch.t -> string -> Downloader.download_result Lwt.t) -> + Support.Gpg.fingerprint -> + Progress.key_vote list Lwt.t diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/mirror.ml zeroinstall-injector-2.7/ocaml/zeroinstall/mirror.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/mirror.ml 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/mirror.ml 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,68 @@ +(* Copyright (C) 2014, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** Support functions for using mirror servers *) + +open Support.Common +open General + +module U = Support.Utils + +let escape_slashes s = Str.global_replace U.re_slash "%23" s +let re_scheme_sep = Str.regexp_string "://" +let re_remote_feed = Str.regexp "^\\(https?\\)://\\([^/]*@\\)?\\([^/:]+\\)\\(:[^/]*\\)?/" + +(* The algorithm from 0mirror. *) +let get_feed_dir (`remote_feed feed) = + if String.contains feed '#' then ( + raise_safe "Invalid URL '%s'" feed + ) else ( + let scheme, rest = U.split_pair re_scheme_sep feed in + if not (String.contains rest '/') then + raise_safe "Missing / in %s" feed; + let domain, rest = U.split_pair U.re_slash rest in + [scheme; domain; rest] |> List.iter (fun part -> + if part = "" || U.starts_with part "." then + raise_safe "Invalid URL '%s'" feed + ); + String.concat "/" ["feeds"; scheme; domain; escape_slashes rest] + ) + +(* Don't bother trying the mirror for localhost URLs. *) +let can_try_mirror url = + if Str.string_match re_remote_feed url 0 then ( + let scheme = Str.matched_group 1 url in + let domain = Str.matched_group 3 url in + match scheme with + | "http" | "https" when domain <> "localhost" -> true + | _ -> false + ) else ( + log_warning "Failed to parse URL '%s'" url; + false + ) + +let get_mirror_url mirror feed_url resource = + match feed_url with + | `local_feed _ | `distribution_feed _ -> None + | `remote_feed url as feed_url -> + if can_try_mirror url then + Some (mirror ^ "/" ^ (get_feed_dir feed_url) ^ "/" ^ resource) + else None + +let for_impl config impl = + config.mirror |> pipe_some (fun mirror -> + let {Feed_url.feed; id} = Feed.get_id impl in + get_mirror_url mirror feed ("impl/" ^ escape_slashes id) + |> pipe_some (fun url -> Some (Recipe.get_mirror_download url)) + ) + +let for_archive config url = + match config.mirror with + | Some mirror when can_try_mirror url -> + let escaped = Str.global_replace (Str.regexp_string "/") "#" url |> Curl.escape in + Some (mirror ^ "/archive/" ^ escaped) + | _ -> None + +let for_feed config feed = + config.mirror |> pipe_some (fun mirror -> get_mirror_url mirror feed "latest.xml") diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/mirror.mli zeroinstall-injector-2.7/ocaml/zeroinstall/mirror.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/mirror.mli 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/mirror.mli 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,17 @@ +(* Copyright (C) 2014, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** Support functions for using mirror servers *) + +(** Get a recipe for the tar.bz2 of the implementation at the mirror. + * @return a recipe for a single archive containing the whole implementation. + * Note: This is just one way we try the mirror. You can also use [for_archive] + * to check for mirrored copies of individual archives. *) +val for_impl : General.config -> _ Feed.implementation -> Recipe.t option + +(** Return the URL to check for a mirror of an archive URL. *) +val for_archive : General.config -> string -> string option + +(** Return the URL to check for a mirror of a feed. *) +val for_feed : General.config -> Feed_url.remote_feed -> string option diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/packagekit.ml zeroinstall-injector-2.7/ocaml/zeroinstall/packagekit.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/packagekit.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/packagekit.ml 2014-05-25 09:29:17.000000000 +0000 @@ -265,7 +265,9 @@ let packagekit = ref (fun config -> let proxy = lazy ( match_lwt Dbus.system () with - | None -> Lwt.return None + | None -> + log_debug "Can't connect to system D-BUS; PackageKit support disabled"; + Lwt.return None | Some bus -> let proxy = Dbus.OBus_proxy.make ~peer:(Dbus.OBus_peer.make ~connection:bus ~name:"org.freedesktop.PackageKit") diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/progress.mli zeroinstall-injector-2.7/ocaml/zeroinstall/progress.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/progress.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/progress.mli 2014-05-25 09:29:17.000000000 +0000 @@ -22,7 +22,7 @@ (** Ask the user to confirm they trust at least one of the signatures on this feed. * @param key_info a list of fingerprints and their (eventual) votes * Return the list of fingerprints the user wants to trust. *) - method confirm_keys : [`remote_feed of General.feed_url] -> (Support.Gpg.fingerprint * key_vote list Lwt.t) list -> Support.Gpg.fingerprint list Lwt.t + method confirm_keys : Feed_url.remote_feed -> (Support.Gpg.fingerprint * key_vote list Lwt.t) list -> Support.Gpg.fingerprint list Lwt.t (** Display a confirmation request *) method confirm : string -> [`ok | `cancel] Lwt.t diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/recipe.ml zeroinstall-injector-2.7/ocaml/zeroinstall/recipe.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/recipe.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/recipe.ml 2014-05-25 09:29:17.000000000 +0000 @@ -40,7 +40,7 @@ | RenameStep of rename | RemoveStep of remove -type recipe = recipe_step list +type t = recipe_step list let attr_href = "href" let attr_size = "size" diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/recipe.mli zeroinstall-injector-2.7/ocaml/zeroinstall/recipe.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/recipe.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/recipe.mli 2014-05-25 09:29:17.000000000 +0000 @@ -35,12 +35,12 @@ | RenameStep of rename | RemoveStep of remove -type recipe = recipe_step list +type t = recipe_step list val is_retrieval_method : Support.Qdom.element -> bool -val parse_retrieval_method : Support.Qdom.element -> recipe option +val parse_retrieval_method : Support.Qdom.element -> t option -val recipe_requires_network : recipe -> bool -val get_download_size : recipe -> Int64.t +val recipe_requires_network : t -> bool +val get_download_size : t -> Int64.t -val get_mirror_download : string -> recipe +val get_mirror_download : string -> t diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/requirements.ml zeroinstall-injector-2.7/ocaml/zeroinstall/requirements.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/requirements.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/requirements.ml 2014-05-25 09:29:17.000000000 +0000 @@ -7,7 +7,7 @@ open General open Support.Common -type requirements = { +type t = { interface_uri : iface_uri; command : string option; source : bool; diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/selections.ml zeroinstall-injector-2.7/ocaml/zeroinstall/selections.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/selections.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/selections.ml 2014-05-25 09:29:17.000000000 +0000 @@ -58,7 +58,7 @@ in ZI.fold_left ~f:add_selection StringMap.empty sels "selection" let get_runner elem = - match ZI.map ~f:(fun a -> a) elem "runner" with + match elem |> ZI.map ~name:"runner" (fun a -> a) with | [] -> None | [runner] -> Some runner | _ -> Q.raise_elem "Multiple s in" elem diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/selections.mli zeroinstall-injector-2.7/ocaml/zeroinstall/selections.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/selections.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/selections.mli 2014-05-25 09:29:17.000000000 +0000 @@ -20,7 +20,7 @@ (** {2 Selections documents} *) -(** Note: takes ownership of the XML; don't use it after calling this *) +(** Load a selections document. *) val create : Support.Qdom.element -> t (** Create a [selections] value from a file (parse + create). *) diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/solver.ml zeroinstall-injector-2.7/ocaml/zeroinstall/solver.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/solver.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/solver.ml 2014-05-25 09:29:17.000000000 +0000 @@ -18,10 +18,12 @@ | ImplElem of Feed.generic_implementation | CommandElem of Feed.command | MachineGroup of string + | Interface of iface_uri (* True if this interface is selected *) let to_string = function | ImplElem impl -> (Versions.format_version impl.Feed.parsed_version) ^ " - " ^ Qdom.show_with_loc impl.Feed.qdom | CommandElem command -> Qdom.show_with_loc command.Feed.command_qdom | MachineGroup name -> name + | Interface iface -> iface end module S = Support.Sat.MakeSAT(SolverData) @@ -48,7 +50,7 @@ class type candidates = object method get_clause : S.at_most_one_clause option - method get_vars : S.var list + method get_vars : S.lit list method get_state : decision_state end @@ -61,7 +63,7 @@ machine = None; stability = Testing; props = { - attrs = Qdom.AttrMap.empty; + attrs = AttrMap.empty; requires = []; commands = StringMap.empty; (* (not used; we can provide any command) *) bindings = []; @@ -74,9 +76,10 @@ let dummy_command = { Feed.command_qdom = ZI.make "dummy-command"; Feed.command_requires = []; + Feed.command_bindings = []; } -class impl_candidates sat (clause : S.at_most_one_clause option) (vars : (S.var * Feed.generic_implementation) list) = +class impl_candidates (clause : S.at_most_one_clause option) (vars : (S.lit * Feed.generic_implementation) list) = object (_ : #candidates) method get_clause = clause @@ -106,7 +109,7 @@ match S.get_selected clause with | None -> None | Some lit -> - match (S.get_varinfo_for_lit sat lit).S.obj with + match S.get_user_data_for_lit lit with | SolverData.ImplElem impl -> Some (lit, impl) | _ -> assert false @@ -117,7 +120,7 @@ match S.get_selected clause with | Some lit -> (* We've already chosen which to use. Follow dependencies. *) - let impl = match (S.get_varinfo_for_lit sat lit).S.obj with + let impl = match S.get_user_data_for_lit lit with | SolverData.ImplElem impl -> impl | _ -> assert false in Selected impl.Feed.props.Feed.requires @@ -132,7 +135,7 @@ end (** Holds all the commands with a given name within an interface. *) -class command_candidates sat (clause : S.at_most_one_clause option) (vars : (S.var * Feed.command) list) = +class command_candidates (clause : S.at_most_one_clause option) (vars : (S.lit * Feed.command) list) = object (_ : #candidates) method get_clause = clause @@ -146,7 +149,7 @@ match S.get_selected clause with | Some lit -> (* We've already chosen which to use. Follow dependencies. *) - let command = match (S.get_varinfo_for_lit sat lit).S.obj with + let command = match S.get_user_data_for_lit lit with | SolverData.CommandElem command -> command | _ -> assert false in Selected command.Feed.command_requires @@ -156,98 +159,131 @@ | None -> Unselected (* No remaining candidates, and none was chosen. *) end -(** To avoid adding the same implementations and commands more than once, we - cache them. *) -type search_key = - | ReqCommand of (string * iface_uri * bool) - | ReqIface of (iface_uri * bool) +module type CACHE_ENTRY = + sig + type t + type value + val compare : t -> t -> int + end -class ['a, 'b] cache = - object - val table : ('a, 'b) Hashtbl.t = Hashtbl.create 100 - val mutable make : 'a -> ('b * (unit -> unit)) = fun _ -> failwith "set_maker not called!" +module CommandIfaceEntry = + struct + type t = (string * iface_uri * bool) + type value = command_candidates + let compare = compare + end + +module IfaceEntry = + struct + type t = (iface_uri * bool) + type value = impl_candidates + + (* Sort the interfaces by URI so we have a stable output. *) + let compare (ib, sb) (ia, sa) = + match compare ia ib with + | 0 -> compare sa sb + | x -> x + end - method set_maker maker = - make <- maker +module Cache(CacheEntry : CACHE_ENTRY) : + sig + (** The cache is used in [build_problem], while the clauses are still being added. *) + type t + + (** Once the problem is built, an immutable snapshot is taken. *) + type snapshot + + val create : unit -> t + + (** [lookup cache make key] will look up [key] in [cache]. + * If not found, create it with [value, process = make key], add [value] to the cache, + * and then call [process ()] on it. + * [make] must not be recursive (since the key hasn't been added yet), + * but [process] can be. In other words, [make] does whatever setup *must* + * be done before anyone can use this cache entry, while [process] does + * setup that can be done afterwards. *) + val lookup : t -> (CacheEntry.t -> (CacheEntry.value * (unit -> unit))) -> CacheEntry.t -> CacheEntry.value + + val snapshot : t -> snapshot + val get : CacheEntry.t -> snapshot -> CacheEntry.value option + val get_exn : CacheEntry.t -> snapshot -> CacheEntry.value + + (** The sorted bindings *) + val bindings : snapshot -> (CacheEntry.t * CacheEntry.value) list + end = struct + module M = Map.Make(CacheEntry) - (** Look up [key] in [cache]. If not found, create it with [make key], - add it to the cache, and then call [process key value] on it. - [make] must not be recursive (since the key hasn't been added yet), - but [process] can be. In other words, [make] does whatever setup *must* - be done before anyone can use this cache entry, which [process] does - setup that can be done afterwards. *) - method lookup (key:'a) : 'b = - try Hashtbl.find table key + type snapshot = CacheEntry.value M.t + type t = snapshot ref + + let create () = ref M.empty + + let lookup table make key = + try M.find key !table with Not_found -> - let (value, process) = make key in - Hashtbl.add table key value; + let value, process = make key in + table := M.add key value !table; process (); value - method peek (key:'a) : 'b option = - try Some (Hashtbl.find table key) + let snapshot table = !table + + let get key map = + try Some (M.find key map) with Not_found -> None - method get_items = - let r = ref [] in - Hashtbl.iter (fun k v -> - r := (k, v) :: !r; - ) table; - !r + let get_exn = M.find + let bindings = M.bindings end +module ImplCache = Cache(IfaceEntry) +module CommandCache = Cache(CommandIfaceEntry) + +type requirements = + | ReqCommand of CommandIfaceEntry.t + | ReqIface of IfaceEntry.t + class type result = object method get_selections : Selections.t - method impl_cache : ((General.iface_uri * bool), impl_candidates) cache + method get_selected : source:bool -> General.iface_uri -> Feed.generic_implementation option method impl_provider : Impl_provider.impl_provider - method get_details : (S.sat_problem * Impl_provider.impl_provider * - (General.iface_uri * bool, impl_candidates) cache * search_key) + method impl_provider : Impl_provider.impl_provider + method implementations : ((General.iface_uri * bool) * (S.lit * Feed.generic_implementation) option) list + method requirements : requirements end -(** Create a document from the result of a solve. *) -let get_selections dep_in_use root_req impl_cache command_cache = - let was_selected (_, candidates) = - match candidates#get_clause with - | None -> false - | Some clause -> S.get_selected clause <> None in - - let commands = List.filter was_selected @@ command_cache#get_items in - let impls = List.filter was_selected @@ impl_cache#get_items in +type diagnostics = S.lit +let explain = S.explain_reason +(** Create a document from the result of a solve. + * The use of Maps ensures that the inputs will be sorted, so we will have a stable output. + *) +let get_selections dep_in_use root_req impls commands = (* For each implementation, remember which commands we need. *) let commands_needed = Hashtbl.create 10 in let check_command ((command_name, iface, _source), _) = Hashtbl.add commands_needed iface command_name in List.iter check_command commands; - (* Sort the interfaces by URI so we have a stable output. *) - let cmp ((ib, sb), _cands) ((ia, sa), _cands) = - match compare ia ib with - | 0 -> compare sa sb - | x -> x in - let impls = List.sort cmp impls in - let selections = impls |> U.filter_map (fun ((iface, _source), impls) -> match impls#get_selected with | None -> None (* This interface wasn't used *) | Some (_lit, impl) -> - let attrs = ref impl.Feed.props.Feed.attrs in - let set_attr name value = - attrs := AttrMap.add_no_ns name value !attrs in - - attrs := AttrMap.remove ("", FeedAttr.stability) !attrs; - - (* Replaced by *) - attrs := AttrMap.remove ("", FeedAttr.main) !attrs; - attrs := AttrMap.remove ("", FeedAttr.self_test) !attrs; - - if Some iface = AttrMap.get_no_ns FeedAttr.from_feed !attrs then ( - (* Don't bother writing from-feed attr if it's the same as the interface *) - attrs := AttrMap.remove ("", FeedAttr.from_feed) !attrs - ); + let attrs = Feed.(impl.props.attrs) + |> AttrMap.remove ("", FeedAttr.stability) - set_attr "interface" iface; + (* Replaced by *) + |> AttrMap.remove ("", FeedAttr.main) + |> AttrMap.remove ("", FeedAttr.self_test) + + |> AttrMap.add_no_ns "interface" iface in + + let attrs = + if Some iface = AttrMap.get_no_ns FeedAttr.from_feed attrs then ( + (* Don't bother writing from-feed attr if it's the same as the interface *) + AttrMap.remove ("", FeedAttr.from_feed) attrs + ) else attrs in let child_nodes = ref [] in if impl != dummy_impl then ( @@ -263,7 +299,7 @@ child_nodes := imported :: !child_nodes in let add_command name = - let command = Feed.get_command_ex impl name in + let command = Feed.get_command_ex name impl in let command_elem = command.Feed.command_qdom in let want_command_child elem = (* We'll add in just the dependencies we need later *) @@ -291,7 +327,7 @@ impl.Feed.qdom |> ZI.iter ~name:"manifest-digest" copy_elem; ); let sel = ZI.make - ~attrs:!attrs + ~attrs ~child_nodes:(List.rev !child_nodes) ~source_hint:impl.Feed.qdom "selection" in Some sel @@ -299,193 +335,221 @@ let root_attrs = match root_req with - | ReqCommand (command, iface, _source) -> [("command", command); ("interface", iface)] - | ReqIface (iface, _source) -> [("interface", iface)] in - ZI.make ~attrs:(Qdom.attrs_of_list root_attrs) ~child_nodes:(List.rev selections) "selections" - -(* [closest_match] is used internally. It adds a lowest-ranked - (but valid) implementation to every interface, so we can always - select something. Useful for diagnostics. *) -let do_solve (impl_provider:Impl_provider.impl_provider) root_req ~closest_match = - (* The basic plan is this: - 1. Scan the root interface and all dependencies recursively, building up a SAT problem. - 2. Solve the SAT problem. Whenever there are multiple options, try the most preferred one first. - 3. Create the selections XML from the results. - - All three involve recursively walking the tree in a similar way: - 1) we follow every dependency of every implementation (order not important) - 2) we follow every dependency of every selected implementation (better versions first) - 3) we follow every dependency of every selected implementation - - In all cases, a dependency may be on an or on a specific . - *) - - let sat = S.create () in - - (* For each (iface, command, source) we have a list of implementations (or commands). *) - let impl_cache = new cache in - let command_cache = new cache in + | ReqCommand (command, iface, _source) -> + AttrMap.singleton "interface" iface + |> AttrMap.add_no_ns "command" command + | ReqIface (iface, _source) -> + AttrMap.singleton "interface" iface in + ZI.make ~attrs:root_attrs ~child_nodes:(List.rev selections) "selections" + +(* Make each interface conflict with its replacement (if any). + * We do this at the end because if we didn't use the replacement feed, there's no need to conflict + * (avoids getting it added to feeds_used). *) +let add_replaced_by_conflicts sat impl_clauses = + List.iter (fun (source, clause, replacement) -> + ImplCache.get (replacement, source) impl_clauses + |> if_some (fun replacement_candidates -> + (* Our replacement was also added to [sat], so conflict with it. *) + let our_vars = clause#get_real_vars in + let replacements = replacement_candidates#get_real_vars in + if (our_vars <> [] && replacements <> []) then ( + (* Must select one implementation out of all candidates from both interfaces. + Dummy implementations don't conflict, though. *) + S.at_most_one sat (our_vars @ replacements) |> ignore + ) + ) + ) +(** On multi-arch systems, we can select 32-bit or 64-bit implementations, but not both in the same + * set of selections. Returns a function that should be called for each implementation to add this + * restriction. *) +let require_machine_groups sat = (* m64 is set if we select any 64-bit binary. mDef will be set if we select any binary that needs any other CPU architecture. Don't allow both to be set together. *) let machine_group_default = S.add_variable sat @@ SolverData.MachineGroup "mDef" in let machine_group_64 = S.add_variable sat @@ SolverData.MachineGroup "m64" in (* If we get to the end of the solve without deciding then nothing we selected cares about the type of CPU. The solver will set them both to false at the end. *) - ignore @@ S.at_most_one sat [machine_group_default; machine_group_64]; + S.at_most_one sat [machine_group_default; machine_group_64] |> ignore; + + (* If [impl] requires a particular machine group, add a constraint to the problem. *) + fun impl_var impl -> + impl.Feed.machine |> if_some (function + | "src" -> () + | machine -> + let group_var = + let open Arch in + match get_machine_group machine with + | Machine_group_default -> machine_group_default + | Machine_group_64 -> machine_group_64 in + S.implies sat ~reason:"machine group" impl_var [group_var]; + ) + +(** If this binding depends on a command (), add that to the problem. + * @param user_var indicates when this binding is used + * @param dep_iface the required interface this binding targets *) +let process_self_binding sat lookup_command user_var dep_iface binding = + Binding.parse_binding binding + |> pipe_some Binding.get_command + |> if_some (fun name -> + (* Note: we only call this for self-bindings, so we could be efficient by selecting the exact command here... *) + let candidates = lookup_command (name, dep_iface, false) in + S.implies sat ~reason:"binding on command" user_var candidates#get_vars + ) + +(* Process a dependency of [user_var]: + - find the candidate implementations/commands to satisfy it + - take just those that satisfy any restrictions in the dependency + - ensure that we don't pick an incompatbile version if we select [user_var] + - ensure that we do pick a compatible version if we select [user_var] (for "essential" dependencies only) *) +let process_dep sat lookup_impl lookup_command user_var dep = + (* Restrictions on the candidates *) + let meets_restriction impl r = impl.Feed.parsed_version = Versions.dummy || r#meets_restriction impl in + let meets_restrictions impl = List.for_all (meets_restriction impl) dep.Feed.dep_restrictions in + let candidates = lookup_impl (dep.Feed.dep_iface, false) in + let pass, fail = candidates#partition meets_restrictions in + + (* Dependencies on commands *) + dep.Feed.dep_required_commands |> List.iter (fun name -> + let candidates = lookup_command (name, dep.Feed.dep_iface, false) in - (* Insert dummy_impl if we're trying to diagnose a problem. *) - let maybe_add_dummy impls = - if closest_match then ( - impls @ [dummy_impl] + if dep.Feed.dep_importance = Feed.Dep_essential then ( + S.implies sat ~reason:"dep on command" user_var candidates#get_vars ) else ( - impls + (* An optional dependency is selected when any implementation of the target interface + * is selected. Force [dep_iface_selected] to be true in that case. We only need to test + * [pass] here, because we always avoid [fail] anyway. *) + let dep_iface_selected = S.add_variable sat (SolverData.Interface dep.Feed.dep_iface) in + S.at_most_one sat (S.neg dep_iface_selected :: pass) |> ignore; + + (* If user_var is selected, then either we don't select this interface, or we select + * a suitable command. *) + S.implies sat ~reason:"opt dep on command" user_var (S.neg dep_iface_selected :: candidates#get_vars) + ); + ); + + if dep.Feed.dep_importance = Feed.Dep_essential then ( + S.implies sat ~reason:"essential dep" user_var pass (* Must choose a suitable candidate *) + ) else ( + (* If [user_var] is selected, don't select an incompatible version of the optional dependency. + We don't need to do this explicitly in the [essential] case, because we must select a good + version and we can't select two. *) + S.at_most_one sat (user_var :: fail) |> ignore; + ) + +(* Add the implementations of an interface to the ImplCache (called the first time we visit it). *) +let make_impl_clause sat ~closest_match replacements impl_provider iface_uri ~source = + let {Impl_provider.replacement; impls; rejects = _} = impl_provider#get_implementations iface_uri ~source in + + (* Insert dummy_impl (last) if we're trying to diagnose a problem. *) + let impls = + if closest_match then impls @ [dummy_impl] + else impls in + + let impls = impls + |> List.map (fun impl -> + let var = S.add_variable sat (SolverData.ImplElem impl) in + (var, impl) ) in + let impl_clause = if impls <> [] then Some (S.at_most_one sat (List.map fst impls)) else None in + let clause = new impl_candidates impl_clause impls in - let dep_in_use dep = impl_provider#is_dep_needed dep in + (* If we have a , remember to add a conflict with our replacement *) + replacement |> if_some (fun replacement -> + if replacement = iface_uri then log_warning "Interface %s replaced-by itself!" iface_uri + else replacements := (source, clause, replacement) :: !replacements; + ); - (* Callbacks to run after building the problem. *) - let delayed = ref [] in + clause, impls - (* For each dependency of [user_var]: - - find the candidate implementations to satisfy it - - take just those that satisfy any restrictions in the dependency - - ensure that we don't pick an incompatbile version if we select [user_var] - - ensure that we do pick a compatible version if we select [user_var] (for "essential" dependencies only) - - if we require any commands, ensure we select them too - *) - let rec process_deps user_var deps = - ListLabels.iter deps ~f:(fun dep -> - if dep_in_use dep then ( - let essential = (dep.Feed.dep_importance = Feed.Dep_essential) in - - (* Dependencies on commands *) - let require_command name = - (* What about optional command dependencies? Looks like the Python doesn't handle that either... *) - let candidates = command_cache#lookup @@ (name, dep.Feed.dep_iface, false) in - S.implies sat ~reason:"dep on command" user_var (candidates#get_vars) in - List.iter require_command dep.Feed.dep_required_commands; - - (* Restrictions on the candidates *) - let meets_restriction impl r :bool = impl.Feed.parsed_version = Versions.dummy || r#meets_restriction impl in - let meets_restrictions impl = List.for_all (meets_restriction impl) dep.Feed.dep_restrictions in - let candidates = impl_cache#lookup @@ (dep.Feed.dep_iface, false) in - let (pass, fail) = candidates#partition meets_restrictions in - - if essential then ( - (* - if pass = [] then ( - let impl_str = SolverData.to_string (S.get_varinfo_for_lit sat user_var).S.obj in - log_warning "Discarding candidate '%s' because dep %s cannot be satisfied. %d/%d candidates pass the restrictions." - impl_str (Qdom.show_with_loc dep.Feed.dep_qdom) (List.length pass) (List.length fail) - ); - *) +(* Create a new CommandCache entry (called the first time we request this key). *) +let make_commands_clause sat lookup_impl process_self_bindings process_deps key = + let (command, iface, source) = key in + let impls = lookup_impl (iface, source) in + let commands = impls#get_commands command in + let make_provides_command (_impl, elem) = + (** [var] will be true iff this is selected. *) + let var = S.add_variable sat (SolverData.CommandElem elem) in + (var, elem) in + let vars = List.map make_provides_command commands in + let command_clause = if vars <> [] then Some (S.at_most_one sat @@ List.map fst vars) else None in + let data = new command_candidates command_clause vars in + + (data, fun () -> + let depend_on_impl (command_var, command) (impl_var, _command) = + (* For each command, require that we select the corresponding implementation. *) + S.implies sat ~reason:"impl for command" command_var [impl_var]; + (* Commands can depend on other commands in the same implementation *) + process_self_bindings command_var iface command.Feed.command_bindings; + (* Process command-specific dependencies *) + process_deps command_var command.Feed.command_requires; + in + List.iter2 depend_on_impl vars commands + ) - S.implies sat ~reason:"essential dep" user_var pass (* Must choose a suitable candidate *) - ) else ( - ListLabels.iter fail ~f:(fun bad_impl -> - (* If [user_var] is selected, don't select an incompatible version of the optional dependency. - We don't need to do this explicitly in the [essential] case, because we must select a good - version and we can't select two. *) - S.implies sat ~reason:"conflicting dep" user_var [S.neg bad_impl] - ) - ) - ) - ) +(** Starting from [root_req], explore all the feeds, commands and implementations we might need, adding + * all of them to [sat_problem]. *) +let build_problem impl_provider root_req sat ~closest_match = + (* For each (iface, command, source) we have a list of implementations (or commands). *) + let impl_cache = ImplCache.create () in + let command_cache = CommandCache.create () in - (* Add the implementations of an interface to the cache (called the first time we visit it). *) - and add_impls_to_cache (iface_uri, source) = - let {Impl_provider.replacement; Impl_provider.impls; Impl_provider.rejects = _} = - impl_provider#get_implementations iface_uri ~source in - (* log_warning "Adding %d impls for %s" (List.length impls) iface_uri; *) - let matching_impls = maybe_add_dummy @@ impls in - let pairs = List.map (fun impl -> (S.add_variable sat (SolverData.ImplElem impl), impl)) matching_impls in - let impl_clause = if List.length pairs > 0 then Some (S.at_most_one sat (List.map fst pairs)) else None in - let data = new impl_candidates sat impl_clause pairs in - (data, fun () -> - (* Conflict with our replacements *) - let () = - match replacement with - | None -> () - | Some replacement when replacement = iface_uri -> - log_warning "Interface %s replaced-by itself!" iface_uri - | Some replacement -> - let handle_replacement () = - let our_vars = data#get_real_vars in - match impl_cache#peek (replacement, source) with - | None -> () (* We didn't use it, so we can't conflict *) - | Some replacement_candidates -> - let replacements = replacement_candidates#get_real_vars in - if (our_vars <> [] && replacements <> []) then ( - (* Must select one implementation out of all candidates from both interfaces. - Dummy implementations don't conflict, though. *) - ignore @@ S.at_most_one sat (our_vars @ replacements) - ) in - (* Delay until the end. If we never use the replacement feed, no need to conflict - (avoids getting it added to feeds_used). *) - delayed := handle_replacement :: !delayed - in - - ListLabels.iter pairs ~f:(fun (impl_var, impl) -> - let () = - let open Arch in - match impl.Feed.machine with - | Some machine when machine <> "src" -> ( - let group_var = - match get_machine_group machine with - | Machine_group_default -> machine_group_default - | Machine_group_64 -> machine_group_64 in - S.implies sat ~reason:"machine group" impl_var [group_var]; - ) - | _ -> () in + let require_machine_group = require_machine_groups sat in - (* Process dependencies *) - process_deps impl_var impl.Feed.props.Feed.requires + (* Handle conflicts after building the problem. *) + let replacements = ref [] in + + let rec add_impls_to_cache (iface_uri, source) = + let clause, impls = make_impl_clause sat ~closest_match replacements impl_provider iface_uri ~source in + (clause, fun () -> + impls |> List.iter (fun (impl_var, impl) -> + require_machine_group impl_var impl; + process_self_bindings impl_var iface_uri Feed.(impl.props.bindings); + process_deps impl_var Feed.(impl.props.requires); ) ) + and add_commands_to_cache key = make_commands_clause sat lookup_impl process_self_bindings process_deps key + and lookup_impl key = ImplCache.lookup impl_cache add_impls_to_cache key + and lookup_command key = CommandCache.lookup command_cache add_commands_to_cache key + and process_self_bindings user_var dep_iface = List.iter (process_self_binding sat lookup_command user_var dep_iface) + and process_deps user_var = List.iter (fun dep -> + if impl_provider#is_dep_needed dep then process_dep sat lookup_impl lookup_command user_var dep + ) in - (* Initialise this cache entry (called the first time we request this key). *) - and add_commands_to_cache (command, iface, source) = - let impls = impl_cache#lookup @@ (iface, source) in - let commands = impls#get_commands command in - let make_provides_command (_impl, elem) = - (** [var] will be true iff this is selected. *) - let var = S.add_variable sat (SolverData.CommandElem elem) in - (var, elem) in - let vars = List.map make_provides_command commands in - let command_clause = if List.length vars > 0 then Some (S.at_most_one sat @@ List.map fst vars) else None in - let data = new command_candidates sat command_clause vars in - - let process_commands () = - let depend_on_impl (command_var, command) (impl_var, _command) = - (* For each command, require that we select the corresponding implementation. *) - S.implies sat ~reason:"impl for command" command_var [impl_var]; - (* Process command-specific dependencies *) - process_deps command_var command.Feed.command_requires; - in - List.iter2 depend_on_impl vars commands in - - (data, process_commands) in - - (* Can't work out how to set these in the constructor call, so do it here instead. *) - impl_cache#set_maker add_impls_to_cache; - command_cache#set_maker add_commands_to_cache; + (* This recursively builds the whole problem up. *) + begin match root_req with + | ReqIface r -> (lookup_impl r)#get_vars + | ReqCommand r -> (lookup_command r)#get_vars end + |> S.at_least_one sat ~reason:"need root"; (* Must get what we came for! *) + + (* All impl_candidates and command_candidates have now been added, so snapshot the cache. *) + let impl_clauses, command_clauses = ImplCache.snapshot impl_cache, CommandCache.snapshot command_cache in + add_replaced_by_conflicts sat impl_clauses !replacements; + impl_clauses, command_clauses - let lookup = function - | ReqIface r -> (impl_cache#lookup r :> candidates) - | ReqCommand r -> command_cache#lookup r in +let do_solve (impl_provider:Impl_provider.impl_provider) root_req ~closest_match = + (* The basic plan is this: + 1. Scan the root interface and all dependencies recursively, building up a SAT problem. + 2. Solve the SAT problem. Whenever there are multiple options, try the most preferred one first. + 3. Create the selections XML from the results. - (* This recursively builds the whole problem up. *) - let candidates = lookup root_req in - S.at_least_one sat ~reason:"need root" @@ candidates#get_vars; (* Must get what we came for! *) + All three involve recursively walking the tree in a similar way: + 1) we follow every dependency of every implementation (order not important) + 2) we follow every dependency of every selected implementation (better versions first) + 3) we follow every dependency of every selected implementation - (* Setup done; lock to prevent accidents *) - let locked _ = failwith "building done" in - impl_cache#set_maker locked; - command_cache#set_maker locked; + In all cases, a dependency may be on an or on a specific . + *) - (* Run all the callbacks *) - List.iter (fun fn -> fn ()) !delayed; + let sat = S.create () in + + let impl_clauses, command_clauses = build_problem impl_provider root_req sat ~closest_match in + + let lookup = function + | ReqIface r -> (ImplCache.get_exn r impl_clauses :> candidates) + | ReqCommand r -> (CommandCache.get_exn r command_clauses) in + + let dep_in_use dep = impl_provider#is_dep_needed dep in (* Run the solve *) @@ -494,15 +558,9 @@ Then try the most preferred implementation of it that hasn't been ruled out. *) let seen = Hashtbl.create 100 in let rec find_undecided req = - if Hashtbl.mem seen req then ( - None (* Break cycles *) - ) else ( + if Hashtbl.mem seen req then None (* Break cycles *) + else ( Hashtbl.add seen req true; -(* - let () = match req with - | ReqCommand (command, iface, _source) -> log_warning "check %s %s" iface command - | ReqIface (iface, _source) -> log_warning "check %s" iface in -*) let candidates = lookup req in match candidates#get_state with | Unselected -> None @@ -533,37 +591,44 @@ match req with | ReqCommand (_command, iface, source) -> find_undecided @@ ReqIface (iface, source) | ReqIface _ -> None (* We're not a *) - ) - in + ) in find_undecided root_req in - (* Build the results object *) - match S.run_solver sat decider with | None -> None | Some _solution -> + (* Build the results object *) Some ( object (_ : result) - method get_selections = get_selections dep_in_use root_req impl_cache command_cache |> Selections.create + method get_selections = + let was_selected (_, candidates) = + match candidates#get_clause with + | None -> false + | Some clause -> S.get_selected clause <> None in + + let commands = command_clauses |> CommandCache.bindings |> List.filter was_selected in + let impls = impl_clauses |> ImplCache.bindings |> List.filter was_selected in + get_selections dep_in_use root_req impls commands |> Selections.create + + method get_selected ~source iface = + ImplCache.get (iface, source) impl_clauses + |> pipe_some (fun candidates -> + match candidates#get_selected with + | Some (_lit, impl) when impl != dummy_impl -> Some impl + | _ -> None + ) - method impl_cache = impl_cache method impl_provider = impl_provider - method get_details = - if closest_match then - (sat, impl_provider, impl_cache, root_req) - else - failwith "Can't diagnostic details: solve didn't fail!" + method implementations = + impl_clauses |> ImplCache.bindings |> List.map (fun (key, impl_candidates) -> (key, impl_candidates#get_selected)) + + method requirements = root_req end ) let get_root_requirements config requirements = - let module R = Requirements in - let { - R.command; R.interface_uri; R.source; - R.extra_restrictions; R.os; R.cpu; - R.message = _; - } = requirements in + let { Requirements.command; interface_uri; source; extra_restrictions; os; cpu; message = _ } = requirements in (* This is for old feeds that have use='testing' instead of the newer 'test' command for giving test-only dependencies. *) @@ -592,7 +657,7 @@ let solve_for config feed_provider requirements = try - let (scope_filter, root_req) = get_root_requirements config requirements in + let scope_filter, root_req = get_root_requirements config requirements in let impl_provider = (new Impl_provider.default_impl_provider config feed_provider scope_filter :> Impl_provider.impl_provider) in match do_solve impl_provider root_req ~closest_match:false with diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/solver.mli zeroinstall-injector-2.7/ocaml/zeroinstall/solver.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/solver.mli 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/solver.mli 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,48 @@ +(* Copyright (C) 2014, Thomas Leonard + * See the README file for details, or visit http://0install.net. + *) + +(** Select a compatible set of components to run a program. *) + +open General + +(** We can either be trying to find an implementation, or a command within an implementation. + * The last component is [true] if we're looking for source. *) +type requirements = + | ReqCommand of (string * iface_uri * bool) + | ReqIface of (iface_uri * bool) + +(** Only exposed for unit-tests. *) +val dummy_impl : Feed.generic_implementation + +type diagnostics + +(** Request diagnostics-of-last-resort (fallback used when [Diagnostics] can't work out what's wrong). + * Gets a report from the underlying SAT solver. *) +val explain : diagnostics -> string + +class type result = + object + method get_selections : Selections.t + + (* The remaining methods are used to provide diagnostics *) + method get_selected : source:bool -> General.iface_uri -> Feed.generic_implementation option + method impl_provider : Impl_provider.impl_provider + method implementations : ((General.iface_uri * bool) * (diagnostics * Feed.generic_implementation) option) list + method requirements : requirements + end + +(** Convert [Requirements.t] to requirements for the solver. + * This looks at the host system to get some values (whether we have multi-arch support, default CPU and OS). *) +val get_root_requirements : General.config -> Requirements.t -> Impl_provider.scope_filter * requirements + +(** Find a set of implementations which satisfy these requirements. Consider using [solve_for] instead. + @param closest_match adds a lowest-ranked (but valid) implementation to every interface, so we can always + select something. Useful for diagnostics. + @return None if the solve fails (only happens if [closest_match] is false. *) +val do_solve : Impl_provider.impl_provider -> requirements -> closest_match:bool -> result option + +(** High-level solver interface. + * Runs [do_solve ~closest_match:false] and reports (true, results) on success. + * On failure, tries again with [~closest_match:true] and reports (false, results) for diagnostics. *) +val solve_for : General.config -> Feed_provider.feed_provider -> Requirements.t -> bool * result diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/stores.ml zeroinstall-injector-2.7/ocaml/zeroinstall/stores.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/stores.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/stores.ml 2014-05-25 09:29:17.000000000 +0000 @@ -62,8 +62,8 @@ | [key; value] when key = "sha1" || key = "sha1new" || key = "sha256" -> digests := [(key, value)] | _ -> () end; - elem |> ZI.iter ~name:"manifest-digest" ( - Q.iter_attrs (fun (ns, name) value -> + elem |> ZI.iter ~name:"manifest-digest" (fun manifest_digest -> + manifest_digest.Q.attrs |> Q.AttrMap.iter_values (fun (ns, name) value -> if ns = "" then digests := (name, value) :: !digests ) ); diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/_tags zeroinstall-injector-2.7/ocaml/zeroinstall/_tags --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/_tags 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/_tags 2014-05-25 09:29:17.000000000 +0000 @@ -1,3 +1,3 @@ true: for-pack(Zeroinstall) - or or or or or or or or or or or or : syntax(camlp4o), package(lwt.syntax) -: mypp + or or or or or or or or or or or or or : syntax(camlp4o), package(lwt.syntax) + or : mypp diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/trust.ml zeroinstall-injector-2.7/ocaml/zeroinstall/trust.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/trust.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/trust.ml 2014-05-25 09:29:17.000000000 +0000 @@ -61,11 +61,11 @@ ) else ( let key_elems = db |> StringMap.map_bindings (fun fingerprint domains -> let domain_elems = domains |> StringSet.elements |> List.map (fun domain -> - TRUST.make "domain" ~attrs:(Q.attrs_of_list [("value", domain)]) + TRUST.make "domain" ~attrs:(Q.AttrMap.singleton "value" domain) ) in TRUST.make "key" ~child_nodes:domain_elems - ~attrs:(Q.attrs_of_list [("fingerprint", fingerprint)]) + ~attrs:(Q.AttrMap.singleton "fingerprint" fingerprint) ) in let root = TRUST.make ~child_nodes:key_elems "trusted-keys" in diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/ui.mli zeroinstall-injector-2.7/ocaml/zeroinstall/ui.mli --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/ui.mli 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/ui.mli 2014-05-25 09:29:17.000000000 +0000 @@ -4,6 +4,12 @@ (** Common types for user interface callbacks *) +type select_mode = [ + | `Select_only (* only download feeds, not archives; display "Select" in GUI *) + | `Download_only (* download archives too; refresh if stale feeds; display "Download" in GUI *) + | `Select_for_run (* download archives; update stale in background; display "Run" in GUI *) +] + class type ui_handler = object (** Choose (and possibly download) a set of implementations. @@ -14,8 +20,8 @@ < config : General.config; distro : Distro.distribution; make_fetcher : Progress.watcher -> Fetch.fetcher; .. > -> ?test_callback:(Selections.t -> string Lwt.t) -> ?systray:bool -> - [`Download_only | `Select_for_run | `Select_only] -> - Requirements.requirements -> + select_mode -> + Requirements.t -> refresh:bool -> [`Aborted_by_user | `Success of Selections.t] Lwt.t diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall/versions.ml zeroinstall-injector-2.7/ocaml/zeroinstall/versions.ml --- zeroinstall-injector-2.6.1/ocaml/zeroinstall/versions.ml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall/versions.ml 2014-05-25 09:29:17.000000000 +0000 @@ -119,6 +119,11 @@ fun v -> v == dummy || List.exists (fun t -> t v) tests with Safe_exception _ as ex -> reraise_with_context ex "... parsing version expression '%s'" s +(** Any distribution-provided version number is capped to this. + * Prevents them wrapping around (very large numbers are usually hashes anyway). + * We use a special-looking decimal number to make it more obvious what has happened. *) +let version_limit = 9999999999999999L + let try_cleanup_distro_version version = let result' = ref [] in let stream = Stream.of_string version in @@ -134,6 +139,7 @@ let rec accept_more_digits v = match accept_digit () with | None -> v + | Some _ when v >= version_limit -> accept_more_digits version_limit | Some d -> Int64.add (Int64.mul v 10L) d |> accept_more_digits in let rec skip_lower () = diff -Nru zeroinstall-injector-2.6.1/ocaml/zeroinstall.mlpack zeroinstall-injector-2.7/ocaml/zeroinstall.mlpack --- zeroinstall-injector-2.6.1/ocaml/zeroinstall.mlpack 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ocaml/zeroinstall.mlpack 2014-05-25 09:29:17.000000000 +0000 @@ -7,9 +7,12 @@ Config Console Constants +Curl_threading Dbus +Default_ui Diagnostics Distro +Distro_cache Distro_impls Downloader Driver @@ -25,11 +28,12 @@ Fetch General Gui -Helpers Impl_provider Json_connection +Key_info_provider Launcher Manifest +Mirror Packagekit Packagekit_interfaces Progress diff -Nru zeroinstall-injector-2.6.1/README.md zeroinstall-injector-2.7/README.md --- zeroinstall-injector-2.6.1/README.md 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/README.md 2014-05-25 09:29:17.000000000 +0000 @@ -42,18 +42,21 @@ INSTALLATION ------------ -0install is written in a OCaml. You will need the OCaml build tools and some +0install is written in OCaml. You will need the OCaml build tools and some OCaml libraries to compile 0install. The easiest way to get the dependencies is using [OPAM](http://opam.ocamlpro.com/): $ opam sw 4.01.0 $ eval `opam config env` - $ opam install yojson xmlm ounit react lwt extlib ssl ocurl obus lablgtk + $ opam install yojson xmlm ounit react lwt extlib ocurl obus lablgtk sha -(obus and lablgtk are optional. obus is used on Linux to add support for D-BUS notifications, -installing native packages using PackageKit, and using NetworkManager to check -the network status before doing background updates. lablgtk provides a GTK GUI.) +Note: some of these are optional: + +- obus is used on Linux to add support for D-BUS notifications, installing + native packages using PackageKit, and using NetworkManager to check + the network status before doing background updates. +- lablgtk provides a GTK GUI. Alternatively, you can use your distribution's packages if you prefer (and if they are new enough). For example, on Debian: @@ -63,6 +66,13 @@ libextlib-ocaml-dev libcurl-ocaml-dev libssl-ocaml-dev \ libobus-ocaml-dev liblablgtk2-ocaml-dev liblwt-glib-ocaml-dev +On Fedora: + + $ su -c 'yum install gettext ocaml ocaml-findlib ocaml-yojson-devel \ + ocaml-biniou-devel ocaml-easy-format-devel ocaml-xmlm-devel ocaml-camlp4-devel \ + ocaml-lwt-devel ocaml-ounit-devel ocaml-extlib-devel ocaml-curl-devel \ + ocaml-obus-devel ocaml-lablgtk-devel openssl-devel' + Either way, build and install by running this command in the top-level directory: $ make && sudo make install @@ -85,48 +95,54 @@ A Windows binary of 0install is available at [0install.de](http://0install.de/?lang=en). -Warning: I know very little about Windows. These instructions are the result of many hours of random trial-and-error and Google searches. Please help improve things here if you can. +To install from source: + +1. Install [WODI](http://wodi.forge.ocamlcore.org/) (I used the 64-bit graphical installer). This gets you OCaml and a package manager for installing OCaml libraries. + + During the install, you should select and install these Cygwin packags: + - `make` + - `mingw64-x86_64-gcc-core` or `mingw64-i686-gcc-core` (for 64-bit or 32-bit WODI) + - `gnupg` -If you want to compile from source on Windows you'll need to install quite a few things manually: + If you don't get prompted, install [Cygwin](http://www.cygwin.com/) manually and use it to install the packages. -- [OCaml 4.0.1 Windows Installer](http://protz.github.io/ocaml-installer/) -- [Cygwin](http://www.cygwin.com/) and various of its packages: mingw64-i686-gcc-core, mingw-i686-headers and make, at least (make sure /cygdrive/c/MinGW/bin is in $PATH) -- [Xmlm](http://erratique.ch/software/xmlm) -- [Yojson] (http://mjambon.com/yojson.html) (and its dependencies: Cppo, Easy-format, Biniou) -- [Lwt](http://ocsigen.org/lwt/) (and its dependency React). You'll also need to apply [this EPIPE fix](https://github.com/ocsigen/lwt/issues/20) -- [extlib](http://code.google.com/p/ocaml-extlib/) - if you get "ocamlfind: extLib.lib: No such file or directory", modify install.ml to use the "Unix" extensions for "Win32" too. -- [openssl](http://www.openssl.org/) - 1. Use `cp -Lr openssl copy` to turn all symlinks into regular files. - 2. `perl Configure mingw shared --prefix=C:/OCaml` in `copy`. - 3. `cp -Lr copy copy2` to turn all symlinks into regular files again. - 4. `make` and `make install` inside `copy2`. -- [ocaml-ssl](http://sourceforge.net/projects/savonet/files/ocaml-ssl/) - use `./configure LDFLAGS=-LC:/OCaml/lib CFLAGS=-IC:/OCaml/include`. -- [libcurl](http://curl.haxx.se/download.html): - 1. Edit each Makefile.m32 to say `OPENSSL_PATH = c:/OCaml`. - 2. Build with `mingw32-make.exe mingw32-ssl`. - 3. Copy `lib/libcurl.a` to `c:/OCaml/lib`. -- [ocurl](http://sourceforge.net/projects/ocurl/) - these steps worked for me: - 1. There's no curl-config, so edit `configure` to use: - - CURLDIR=-Ic:/OCaml/lib - CURLFLAGS="-lcurl -ccopt -lssl -ccopt -lcrypto -ccopt -lwldap32" - CURLLIBS= - - CFLAGS="$CURLDIR -DCURL_STATICLIB -Ic:/OCaml/include" - 2. `./configure` - 3. Edit Makefile to set `FINDLIB = ocamlfind`. - 4. `curl.h` seems to redefine `interface`, so rename all ocurrances in `curl-helper.c` to `interface_`. - 5. `make` and `make install`. +2. Run "Wodi64 Cygwin". +3. Install the dependencies with: -Then, to build 0install under Cygwin: + godi_add godi-yojson godi-xmlm godi-react godi-lwt \ + godi-extlib godi-sha godi-curl godi-lablgtk2 godi-ounit + Notes: + - lablgtk2 is optional (only needed if you want the GTK GUI). + - ounit is optional (only needed to run the unit-tests during the build - these currently fail on Windows). + - There is no visible progress indicator while the packages are installing, but you should see the output of `ocamlfind list` getting longer. - cd ocaml - make ocaml +5. Change directory to the "ocaml" subdirectory of 0install and build: -This creates the executables build/ocaml/install.exe and build/ocaml/0install-runenv.exe. -If you'd like to make the top-level Makefile work on Windows so you can "make install", please + cd ocaml + make ocaml + +This creates the executables `build/ocaml/install.exe` and `build/ocaml/0install-runenv.exe`: + + $ ../build/ocaml/0install.exe --help + Usage: 0install.exe COMMAND [OPTIONS] + [...] + +If you'd like to make the top-level Makefile work on Windows so you can `make install`, please send a patch. +To run, you may need to copy these DLLs from /opt/wodi64/bin to the `build/ocaml` directory: + +- libcurl-4.dll +- libcares-2.dll +- zlib1.dll + +Note that the native OCaml code cannot currently cope with archives containing +executable files (with the Unix X bit set) - you'll get the error +`Incorrect manifest -- archive is corrupted`. When the OCaml version of 0install +is run under the .NET version, the .NET version sets the environment variable +`%ZEROINSTALL_EXTERNAL_FETCHER%` to a .NET helper process which does the +unpacking correctly. Patches to add native support are welcome. + TAB COMPLETION -------------- diff -Nru zeroinstall-injector-2.6.1/share/appdata/0install.appdata.xml zeroinstall-injector-2.7/share/appdata/0install.appdata.xml --- zeroinstall-injector-2.6.1/share/appdata/0install.appdata.xml 1970-01-01 00:00:00.000000000 +0000 +++ zeroinstall-injector-2.7/share/appdata/0install.appdata.xml 2014-05-25 09:29:17.000000000 +0000 @@ -0,0 +1,27 @@ + + + +0install.desktop +CC0-1.0 +LGPL-2.1+ +0install +Run or manage Zero Install programs + +

+ Zero Install is a decentralised cross-distribution software installation system. +

+

+ Features include full support for shared libraries (with a SAT solver for dependency resolution), + sharing between users, and integration with native platform package managers. +

+

+ It supports both binary and source packages, and works on Linux, OS X, Unix and Windows systems. + It is fully Open Source. +

+ + + http://0install.net/screens/0install-0desktop.png + +http://0install.net +zero-install-devel@lists.sourceforge.net + diff -Nru zeroinstall-injector-2.6.1/tests/rpm/rpm zeroinstall-injector-2.7/tests/rpm/rpm --- zeroinstall-injector-2.6.1/tests/rpm/rpm 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/tests/rpm/rpm 2014-05-25 09:29:17.000000000 +0000 @@ -3,4 +3,5 @@ ksh 93u-28.2.2 i586 yast2-update 2.15.23-21 i586 yast2-mail 2.15.23-2 noarch +poor=name 2 noarch EOF diff -Nru zeroinstall-injector-2.6.1/ZeroInstall.xml zeroinstall-injector-2.7/ZeroInstall.xml --- zeroinstall-injector-2.6.1/ZeroInstall.xml 2014-02-02 15:38:45.000000000 +0000 +++ zeroinstall-injector-2.7/ZeroInstall.xml 2014-05-25 09:29:17.000000000 +0000 @@ -45,6 +45,6 @@ - +