[PATCH] 80%-finished code to support http and ssh in package downloads

Joachim> If somebody wants to see that 80%-ready code nevertheless, I Joachim> can make it available, of course. SJT> Please do. Thanks! Stephen wanted it, you get it. As I've written, 80% finished; i.e., it does not run properly. ;-) This is posted here for discussion. All known problems or open issues in the code are tagged with `FIXME:'. I will send an other email to xemacs-beta with my view on requirements and about design decisions that I made. This shall enable a thread on the basic implementation. But first the list of open technical questions that need to be resolved and where I would be grateful for any opinions. Known errors: -- #'package-get-update-base definitively does not work. I don't know how this function is supposed to be used. I understand what it does, but don't know if I grok the call context good enough. -- Code has been changed recently, but not been tested. (It compiles without errors, but probably won't run. :-) Known issues / problems: -- User interface for site selection probably needs rework (see other email). -- Currently, the download site description has no leading / in directory names for ftp sites. I want to demand absolute paths for HTTP and SSH -- will that be a problem? -- Do we need a file-readable-p for all transport protocols? (IMO no.) -- Shall we really support environment variables in local package specifications; i.e., ? Currently, it is done for this very special case and not anywhere else. -- Index file handling is not good; the database is both fetched too often (in #'package-get-maybe-save-index) and not fetching is allowed (when 'package-get-remote is set). Missing: -- Update of site descriptions. -- Support for http and ssh ports. -- Support for (authenticated) http proxies. -- Better error checks if copy-file does not succeed. lisp/ChangeLog addition: 2005-10-26 Joachim Schrod <jschrod(a)acm.org&gt; * package-get.el: Replace all access functions to index and package files with calls to package-transport functions. * package-transport.el: New module that provides abstraction for package downloads, over several transport protocols. XEmacs 21.4 source patch: Diff command: cvs -q -f diff -u -N Files affected: lisp/package-transport.el lisp/package-get.el Index: lisp/package-get.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/package-get.el,v retrieving revision 1.39.2.9 diff -u -r1.39.2.9 package-get.el --- lisp/package-get.el 2004/06/28 01:19:56 1.39.2.9 +++ lisp/package-get.el 2005/10/26 00:23:54 ＠＠ -8,6 +8,7 ＠＠ ;; Heavy-Modifications: Greg Klanderman <greg(a)alphatech.com&gt; ;; Jan Vroonhof <vroonhof(a)math.ethz.ch&gt; ;; Steve Youngs <youngs(a)xemacs.org&gt; +;; Medium Modifications: Joachim Schrod <jschrod(a)acm.org&gt; ;; Keywords: internal ;; This file is part of XEmacs. ＠＠ -105,7 +106,7 ＠＠ ;;; Code: (require 'package-admin) -;; (require 'package-get-base) +(require 'package-transport) (defgroup package-tools nil "Tools to manipulate packages." ＠＠ -170,7 +171,7 ＠＠ :group 'package-get) ;;;###autoload -(defcustom package-get-package-index-file-location +(defcustom package-get-package-index-file-location (car (split-path (or (getenv "EMACSPACKAGEPATH") user-init-directory))) "*The directory where the package-index file can be found." :type 'directory ＠＠ -200,6 +201,9 ＠＠ ;;;###autoload (defcustom package-get-download-sites '( + ;; Test for http + ;; FIXME: Need to update the site descriptions! + ("http test site" "localhost" "/xemacs/packages" 'http) ;; Main XEmacs Site (ftp.xemacs.org) ("US (Main XEmacs Site)" "ftp.xemacs.org" "pub/xemacs/packages") ＠＠ -469,60 +473,58 ＠＠ (defun package-get-locate-file (file &optional nil-if-not-found no-remote) "Locate an existing FILE with respect to `package-get-remote'. -If FILE is an absolute path or is not found, simply return FILE. -If optional argument NIL-IF-NOT-FOUND is non-nil, return nil -if FILE can not be located. +Returns '(SITE FILE). +If FILE is an absolute path, always return FILE with a local SITE. +If optional argument NIL-IF-NOT-FOUND is non-nil, return nil if +FILE can not be located; otherwise return FILE with a local SITE. If NO-REMOTE is non-nil never search remote locations." (if (file-name-absolute-p file) - file - (let ((site package-get-remote) - (expanded nil)) - (when site - (unless (and no-remote (caar (list site))) - (let ((expn (package-get-remote-filename (car (list site)) file))) - (if (and expn (file-exists-p expn)) - (setq site nil - expanded expn))))) - (or expanded - (and (not nil-if-not-found) - file))))) + (list nil file) + (let ((site (if (and no-remote + (package-transport-remote-p package-get-remote)) + nil + package-get-remote))) + (if (package-transport-file-exists-p site file) + (list site file) + (and (not nil-if-not-found) + (list nil file)))))) (defun package-get-locate-index-file (no-remote) - "Locate the package-get index file. + "Locate the package-get index file. Returns '(SITE FILE). -Do not return remote paths if NO-REMOTE is non-nil. If the index +Do not return remote SITE if NO-REMOTE is non-nil. If the index file doesn't exist in `package-get-package-index-file-location', ask the user if one should be created using the index file in core as a template." (or (package-get-locate-file package-get-base-filename t no-remote) - (if (file-exists-p (expand-file-name package-get-base-filename - package-get-package-index-file-location)) - (expand-file-name package-get-base-filename - package-get-package-index-file-location) - (if (y-or-n-p (format "No index file, shall I create one in %s? " - package-get-package-index-file-location)) - (progn - (save-excursion - (set-buffer - (find-file-noselect (expand-file-name - package-get-base-filename - package-get-package-index-file-location))) - (let ((coding-system-for-write 'binary)) - (erase-buffer) - (insert-file-contents-literally - (locate-data-file package-get-base-filename)) - (save-buffer (current-buffer)) - (kill-buffer (current-buffer)))) - (expand-file-name package-get-base-filename + (let ((index-file (expand-file-name + package-get-base-filename + package-get-package-index-file-location))) + (if (file-exists-p index-file) + (list nil index-file) + (if (y-or-n-p (format "No index file, shall I create one in %s? " package-get-package-index-file-location)) - (error 'search-failed - "Can't locate a package index file."))))) + (progn + (save-excursion + (set-buffer (find-file-noselect index-file)) + (let ((coding-system-for-write 'binary)) + (erase-buffer) + (insert-file-contents-literally + (locate-data-file package-get-base-filename)) + (save-buffer (current-buffer)) + (kill-buffer (current-buffer)))) + (list nil index-file)) + (error 'search-failed + "Can't locate a package index file.")))))) (defun package-get-maybe-save-index (filename) "Offer to save the current buffer as the local package index file, if different." - (let ((location (package-get-locate-index-file t))) - (unless (and filename (equal filename location)) + (let* ((location-spec (package-get-locate-index-file t)) + (location (expand-file-name (second location-spec) + (cadar location-spec))) + (file (expand-file-name filename))) + (unless (and file (equal file location)) (unless (and location (equal (md5 (current-buffer)) (with-temp-buffer ＠＠ -533,42 +535,57 ＠＠ location user-init-directory)) (setq location (expand-file-name package-get-base-filename - package-get-package-index-file-location)) + user-init-directory)) (error 'file-error (format "%s is read-only" location)))) (when (y-or-n-p (concat "Update package index in " location "? ")) (let ((coding-system-for-write 'binary)) (write-file location))))))) + ;;;###autoload (defun package-get-update-base (&optional db-file force-current) "Update the package-get database file with entries from DB-FILE. +DB-FILE is NIL or '(SITE FILE). Unless FORCE-CURRENT is non-nil never try to update the database." + ;; FIXME: How is this function supposed to be used interactively? (interactive (let ((dflt (package-get-locate-index-file nil))) + ;; FIXME: This does not work at all. db-file ain't no filename + ;; any more. One could read a URI here and convert it to a + ;; transport file spec. In any case, #'read-file-name must not be + ;; used. (list (read-file-name "Load package-get database: " (file-name-directory dflt) dflt t (file-name-nondirectory dflt))))) - (setq db-file (expand-file-name (or db-file - (package-get-locate-index-file - (not force-current))))) - (if (not (file-exists-p db-file)) + (unless db-file + (setq db-file (package-get-locate-index-file (not force-current)))) + (if (not (apply #'package-transport-file-exists-p db-file)) (error 'file-error - (format "Package-get database file `%s' does not exist" db-file))) - (if (not (file-readable-p db-file)) + (format "Package-get database file `%s' does not exist" + (package-transport-uri db-file)))) + ;; FIXME: Maybe we don't want to check for readability and catch the copy + ;; failure instead? Then we have one method less to implement in + ;; package-transport-readable-p. + (if (not (apply #'package-transport-file-readable-p db-file)) (error 'file-error - (format "Package-get database file `%s' not readable" db-file))) + (format "Package-get database file `%s' not readable" + (package-transport-uri db-file)))) (let ((buf (get-buffer-create "*package database*"))) (unwind-protect (save-excursion (set-buffer buf) (erase-buffer buf) - (insert-file-contents-literally db-file) + ;; FIXME: Need to use package-transport-copy-file here. Or provide a + ;; package-transport-insert-file-contents-literally function. + ;; FIXME: Might it be that the index file gets fetched too often? + ;; How about usage of already fetched file? + (insert-file-contents-literally (second db-file)) (package-get-update-base-from-buffer buf) - (if (file-remote-p db-file) - (package-get-maybe-save-index db-file))) + (if (package-transport-remote-p (first db-file)) + (package-get-maybe-save-index (second db-file)))) (kill-buffer buf)))) ;; This is here because the `process-error' datum doesn't exist in ＠＠ -612,7 +629,7 ＠＠ (setq good-sig t)) (if good-sig (setq package-get-continue-update-base t) - (error 'process-error + (error 'process-error "GnuPG error. Package database not updated"))) (if (yes-or-no-p "Package Index is not PGP signed. Continue anyway? ") ＠＠ -967,7 +984,7 ＠＠ (when (memq item (package-get-info (caar pkgs) field)) (setq results (push (caar pkgs) results))) (setq pkgs (cdr pkgs))))) - (t + (t (error 'wrong-type-argument field))) (if (interactive-p) (if arg ＠＠ -1006,13 +1023,12 ＠＠ (latest (package-get-info-prop this-package 'version)) (installed (package-get-key package :version)) (found nil) - (search-dir package-get-remote) (base-filename (package-get-info-prop this-package 'filename)) (package-status t) filenames full-package-filename) (if (and (equal (package-get-info package 'category) "mule") (not (featurep 'mule))) - (error 'invalid-state + (error 'invalid-state "Mule packages can't be installed with a non-Mule XEmacs")) (if (null this-package) (if package-get-remote ＠＠ -1058,43 +1074,44 ＠＠ ;; and copy it into the staging directory. Then validate ;; the checksum. Finally, install the package. (catch 'done - (let (search-filenames host dir current-filename dest-filename) - ;; In each search directory ... - (when search-dir - (setq host (car search-dir) - dir (car (cdr search-dir)) - search-filenames filenames) + (let (search-filenames current-filename dest-filename) + ;; FIXME: That when might be superfluous. If package-get-remote is + ;; NIL, we interpret that as "local filename". Maybe we want that + ;; here?! + (when package-get-remote + (setq search-filenames filenames) ;; Look for one of the possible package filenames ... (while search-filenames (setq current-filename (car search-filenames) dest-filename (package-get-staging-dir current-filename)) (cond - ;; No host means look on the current system. - ((null host) + ;; Local package file can be used directly, no copy necessary. + ((package-transport-remote-p package-get-remote) (setq full-package-filename + ;; FIXME: Do we really want a substitute-in-file-name + ;; here? If yes, we need it as well at other places where + ;; we handle local files!! (substitute-in-file-name (expand-file-name current-filename - (file-name-as-directory dir))))) + (second package-get-remote))))) - ;; If it's already on the disk locally, and the size is - ;; correct + ;; If it's already on the disk locally, and the size is correct. ((and (file-exists-p dest-filename) (eq (nth 7 (file-attributes dest-filename)) (package-get-info package 'size))) (setq full-package-filename dest-filename)) ;; If the file exists on the remote system ... - ((file-exists-p (package-get-remote-filename - search-dir current-filename)) + ((package-transport-file-exists-p package-get-remote + current-filename) ;; Get it (setq full-package-filename dest-filename) (message "Retrieving package `%s' ..." current-filename) (sit-for 0) - (copy-file (package-get-remote-filename search-dir - current-filename) - full-package-filename t))) + (package-transport-copy-file package-get-remote current-filename + full-package-filename))) ;; If we found it, we're done. (if (and full-package-filename ＠＠ -1221,30 +1238,6 ＠＠ (nth 2 (efs-ftp-path filename))) filename)) (file-name-as-directory package-get-dir))) - -(defun package-get-remote-filename (search filename) - "Return FILENAME as a remote filename. -It first checks if FILENAME already is a remote filename. If it is -not, then it uses the (car search) as the remote site-name and the (cadr -search) as the remote-directory and concatenates filename. In other -words - site-name:remote-directory/filename. - -If (car search) is nil, (cadr search is interpreted as a local directory). -" - (if (file-remote-p filename) - filename - (let ((dir (cadr search))) - (concat (when (car search) - (concat - (if (string-match "＠" (car search)) - "/" - "/anonymous＠") - (car search) ":")) - (if (string-match "/$" dir) - dir - (concat dir "/")) - filename)))) (defun package-get-installedp (package version) "Determine if PACKAGE with VERSION has already been installed. Index: lisp/package-transport.el =================================================================== RCS file: package-transport.el diff -N package-transport.el --- /dev/null Wed Oct 26 02:23:48 2005 +++ package-transport.el Wed Oct 26 02:23:55 2005 ＠＠ -0,0 +1,447 ＠＠ +;; package-transport.el --- Download packages via various protocols. + +;; Copyright (C) 2003 Steve Youngs +;; Copyright (C) 2005 Joachim Schrod + +;; RCS: $Id: $ +;; Original Author: Steve Youngs <youngs(a)xemacs.org&gt; +;; Heavily Rewritten: Joachim Schrod <jschrod(a)acm.org&gt; +;; Maintainer: N.N. +;; Created: <2003-07-19> +;; Last-Modified: 25 Oct 05 +;; Homepage: http://www.xemacs.org/ +;; Keywords: package pui internal + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; 3. Neither the name of the author nor the names of any contributors +;; may be used to endorse or promote products derived from this +;; software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR +;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Commentary: +;; +;; This code provides the ability to download packages via several +;; protocols. Currently supported are: +;; file package depot is on a local file system +;; ftp package depot access via EFS +;; http package depot access via HTTP +;; ssh package depot access via ssh/scp +;; +;; This module provides functions package-transport-FUNCNAME, for +;; FUNCNAME being +;; - `file-exists-p' +;; - `file-readable-p' +;; - `copy-file' +;; All these functions have almost the same signature as FUNCNAME, +;; with an additional first argument that is a SITE clause in form +;; '(HOST DIRECTORY PROTOCOL). HOST and DIRECTORY are strings. +;; PROTOCOL is a symbol from the set named above and is optional; +;; it defaults to 'file if HOST is nil and 'ftp otherwise. The +;; SITE clause can also be nil, that's the same as '(nil "" file), +;; i.e., file is just a filename on the local file system. +;; +;; The specific semantics of the SITE clauses are explained below, +;; for each transport protocol. +;; +;; Further functions: +;; #'package-transport-remote-p tells if a SITE clause is remote +;; or not. +;; #'package-transport-uri creates a URI from a SITE clause and an +;; optional FILE. That URI is supposed to be used in user messages. +;; +;; This is all extremely PUI-centric, but some of it may be useful +;; elsewhere. What we have here is a set of tools that will enable +;; different transport (download) methods in PUI. +;; +;; The rationale behind this was that PUI was a little brain-damaged +;; in that before you could use it you had to already have some +;; packages pre-installed. Enabling different transport methods +;; directly in core XEmacs will overcome this. +;; +;; It is hoped that this library is "modular" enough so that adding +;; new transport methods should be a fairly painless task. +;; +;; To enable a new transport method: add METHOD specific defuns. +;; You should name these defuns `package-transport-METHOD-FUNCNAME', +;; for example: `package-transport-http-file-exists-p' for a HTTP +;; version of `file-exists-p' defun. + +;;; Todo: +;; +;; o Create a '(SITE FILE) specifier from a URI. + +;;; Code: + +;; Stuff common to all methods: +(defgroup package-transport nil + "Package download methods." +:prefix "package-transport-" +:group 'package-get) + + +;; Some convenience functions. + +(defun package-transport-protocol (site) + "Get protocol from SITE description." + (or (third site) + (if (first site) 'ftp 'file))) + +(defun package-transport-remote-p (site) + "Returns if a SITE description is remote or not. +All SITE descriptions that need special access methods are deemed +remote, even if they would access localhost. I.e., if this function +returns true, one can use normal Elisp functions to access the file +and use (second SITE) as the directory." + (eq (package-transport-protocol site) 'file)) + +(defun package-transport-uri (site &optional file) + "Return a URI that can be used in messages to the user." + (let ((host (first site)) + (dir (second site)) + (protocol (package-transport-protocol site))) + (concat protocol ":" + (if host (concat "//" host)) + dir "/" file))) + + +;; Dispatcher functions, since we have no defmethod. + +(defun package-transport-dispatch (method args) + (let ((protocol (package-transport-protocol (car args)))) + (apply (intern (format "package-transport-%s-%s" protocol method)) + args))) + +(defun package-transport-file-exists-p (site filename) + "Check if FILENAME exists on SITE. +SITE is a site description '(HOST DIR PROTOCOL); FILENAME is a string. +Read the doc string of `file-exists-p' for further description." + (package-transport-dispatch "file-exists-p" + (list site filename))) + +(defun package-transport-file-readable-p (site filename) + "Check if FILENAME is readable on SITE. +SITE is a site description '(HOST DIR PROTOCOL); FILENAME is a string. +Read the doc string of `file-readable-p' for further description." + (package-transport-dispatch "file-readable-p" + (list site filename))) + +;; Note: no KEEP-TIME argument. I don't think we need that. +(defun package-transport-copy-file (site src dest + &optional ok-if-already-exists) + "Copy file content of SRC to DEST. SRC is on SITE. +SITE is a site description '(HOST DIR PROTOCOL); SRC and DEST are strings. +Read the doc string of `copy-file' for further description." + (package-transport-dispatch "copy-file" + (list site src dest ok-if-already-exists))) + + +;; And now for the transport methods themselves. + +;;; File + +;; FIXME: Support DIRECTORY with and without leading "/". +(defun package-transport-file-filename (site filename) + (expand-file-name filename (concat "/" (second site)))) + +(defun package-transport-file-file-exists-p (site filename) + "Does a local file exist?" + (file-exists-p (package-transport-file-filename site filename))) + +(defun package-transport-file-file-readable-p (site filename) + "Is a local file readable?" + (file-readable-p (package-transport-file-filename site filename))) + +(defun package-transport-file-copy-file (site src dest + &optional ok-if-already-exists) + "Copy a local file." + (copy-file (package-transport-file-filename site src) dest + ok-if-already-exists)) + + +;;; HTTP + +;; FIXME: Implement fetching via proxy server, with authentication. +;; FIXME: Implement authentication. +;; FIXME: Implement support for other ports than 80. E.g., allow HOST +;; strings that are "HOSTNAME:PORT". + +;; I realise that most (all?) of this has already been done in Bill +;; Perry's 'URL' and 'W3' packages, but the whole point is to have it +;; in core so PUI will work in a virgin XEmacs installation. --SY. + +(defcustom package-transport-http-port 80 + "*The port to use for HTTP package transfers, defaults to '80'." +:type 'integer +:group 'package-transport) + +(defun package-transport-http-url (site filename) + (let ((host (or (first site) "localhost")) + (dir (second site))) + (concat "http://" host dir "/" filename))) + +;; A bit of eye candy. Kudos to Zappo for this. +(eval-and-compile + (condition-case nil + (require 'working) + (error + (progn + (eval-when-compile + (defvar msg) + (defvar dstr) + (defvar refl)) + (defmacro working-status-forms (message donestr &rest forms) + "Contain a block of code during which a working status is shown." + (list 'let (list (list 'msg message) (list 'dstr donestr) + '(ref1 0)) + (cons 'progn forms))) + (defun working-dynamic-status (&optional number &rest args) + "Called within the macro `working-status-forms', show the status." + (message "%s%s" (apply 'format msg args) + (format "... %c" (aref [ ?- ?/ ?| ?\\ ] (% ref1 4)))) + (setq ref1 (1+ ref1))) + (put 'working-status-forms 'lisp-indent-function 2))))) + +;; FIXME: Combine the protocol handling into an internal function that +;; just takes the HTTP command. +;; FIXME: Support DIRECTORY with and without leading "/". +(defun package-transport-http-file-exists-p (site filename) + "Check to see if a remote file exists over the HTTP protocol." + (let* ((host (first site)) + (path (concat (second site) "/" filename)) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (user-agent (concat "XEmacs " emacs-program-version)) + (http (open-network-stream "http-file-exists-proc" + " *http-proc-buf*" + host + package-transport-http-port)) + (pbuf (process-buffer http)) + (status nil)) + (process-send-string + http + (concat "HEAD /" path " HTTP/1.1\r\n" + "MIME-Version: 1.0\r\n" + "Connection: close\r\n" + ;; FIXME: But we don't speak SSL, do we? + "Extension: Security/Digest Security/SSL\r\n" + "Host: " host "\r\n" + "Accept: */*\r\n" + "User-Agent: " user-agent "\r\n\r\n")) + (working-status-forms (concat "Checking existence of: " path) "Done!" + (while (eq (process-status http) 'open) + (working-dynamic-status nil) + (sleep-for 0.05)) + (working-dynamic-status t)) + (setq status (with-temp-buffer + (erase-buffer) + (insert-buffer pbuf) + (goto-char (point-min)) + (re-search-forward "200 OK" nil t))) + (kill-buffer pbuf) + (when status + (setq status t)) + status)) + +(defalias 'package-transport-http-file-readable-p + 'package-transport-http-file-exists-p) + +;; FIXME: Support DIRECTORY with and without leading "/". +(defun package-transport-http-copy-file (site src dest + &optional ok-if-already-exists) + "Copy a remote file to the local machine via HTTP." + (and (file-exists-p 'dest) + (not ok-if-already-exists) + (not (y-or-n-p "Destination file exists, overwrite? ")) + (error 'file-already-exists dest)) + (let* ((host (first site)) + (path (concat (second site) "/" src)) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (user-agent (concat "XEmacs " emacs-program-version)) + (http (open-network-stream "http-copy-file-proc" + " *http-proc-buf*" + host + package-transport-http-port)) + (pbuf (process-buffer http))) + (process-send-string + http + (concat "GET /" path " HTTP/1.1\r\n" + "MIME-Version: 1.0\r\n" + "Connection: close\r\n" + ;; FIXME: But we don't speak SSL, do we? + "Extension: Security/Digest Security/SSL\r\n" + "Host: " host "\r\n" + "Accept: */*\r\n" + "User-Agent: " user-agent "\r\n\r\n")) + (working-status-forms (concat "Downloading " path) "Done!" + (while (eq (process-status http) 'open) + (working-dynamic-status nil) + (sleep-for 0.05)) + (working-dynamic-status t)) + (with-temp-buffer + (erase-buffer) + (insert-buffer pbuf) + (goto-char (point-min)) + (re-search-forward "^Content-Length: \\([0-9]+.*$\\)" nil t) + (let* ((file-length (string-to-int (match-string 1))) + (file-begin (progn + (goto-char (point-min)) + (re-search-forward "^Content-Encoding:" nil t) + (forward-line 2) + (point-at-bol)))) + (goto-char file-begin) + (forward-char file-length) + (narrow-to-region file-begin (point)) + (write-region (point-min) (point-max) dest))) + (kill-buffer pbuf))) + + +;;; FTP (using EFS) + +;; Because PUI was originally set up to use EFS we just have to +;; construct an appropriate file name and can call the core functions. + +;; FIXME: Support DIRECTORY with and without leading "/". +(defun package-transport-ftp-filename (site filename) + (concat "/" (or (first site) "localhost") + ":/" (second site) + "/" filename)) + +(defun package-transport-ftp-file-exists-p (site filename) + "Does a ftp file exist?" + (file-exists-p (package-transport-ftp-filename site filename))) + +(defun package-transport-ftp-file-readable-p (site filename) + "Is a ftp file readable?" + (file-readable-p (package-transport-ftp-filename site filename))) + +(defun package-transport-ftp-copy-file (site src dest + &optional ok-if-already-exists) + "Copy a ftp file." + (copy-file (package-transport-ftp-filename site src) dest + ok-if-already-exists)) + + + +;;; SSH (via scp) + +;; FIXME: The port and user stuff is not usable. These are +;; site-specific, not user preferences. But we want to support +;; something like this in HOST part of SITE clauses. + +;; I don't have access to anything other than GNU/Linux based system +;; so the SSH method probably isn't very portable outside of Unix +;; systems. --SY. +(defcustom package-transport-ssh-port 22 + "*The port to use for SSH package transfers." +:type 'integer +:group 'package-transport) + +(defcustom package-transport-ssh-user-name (user-login-name) + "*The default SSH user name to use for package retrieval via scp." +:type 'string +:group 'package-transport) + +;; FIXME: Combine the protocol handling into an internal function that +;; just takes the ssh command. +;; FIXME: Support DIRECTORY with and without leading "/"? +(defun package-transport-ssh-file-exists-p (site filename) + "A `file-remote-p' to use over SSH." + (let* ((host (first site)) + (path (concat (second site) "/" filename)) + (proc "ssh-file-exists-proc") + (pbuf " *ssh-file-exists-proc-buf*") + (status nil) + (ssh (start-process-shell-command + proc + pbuf + (concat "ssh " +; (if port +; (concat "-p " port " ") +; (concat "-p " (number-to-string package-transport-ssh-port) " ")) +; (if user +; (concat user "＠" host) +; (concat package-transport-ssh-user-name "＠" host)) + (or host "localhost") + ;; FIXME: What about spaces in path? + ;; FIXME: Why ls -l and not just test -e? + " 'ls -l " path "'")))) + (working-status-forms (concat "Checking existence of: " path) "Done!" + (while (eq (process-status ssh) 'run) + (working-dynamic-status nil) + (sleep-for 0.05)) + (working-dynamic-status t)) + (setq status (process-exit-status ssh)) + (kill-buffer pbuf) + (if (eq status 0) + (setq status t) + (setq status nil)) + status)) + +;; FIXME: For now; until we have decided if we need readable-p at all. +(defalias 'package-transport-ssh-file-readable-p + 'package-transport-ssh-file-exists-p) + +;; FIXME: Support DIRECTORY with and without leading "/"? +(defun package-transport-ssh-copy-file (site src dest + &optional ok-if-already-exists) + "Copy remote SRC to local DEST via SSH using 'scp'." + (and (file-exists-p 'dest) + (not ok-if-already-exists) + (not (y-or-n-p "Destination file exists, overwrite? ")) + (error 'file-already-exists dest)) + (let* ((host (first site)) + (path (concat (second site) "/" src)) + (proc "ssh-copy-file-proc") + (pbuf " *ssh-copy-file-proc-buf*") + (ssh (start-process-shell-command + proc + pbuf + (concat "scp -q " +; "-P " +; (or (number-to-string port) +; (number-to-string package-transport-ssh-port)) +; (if user +; (concat " " user "＠" host ":" path " ") +; (concat " " package-transport-ssh-user-name "＠" host ":" path " ")) + (or host "localhost") ":" path + dest)))) + (working-status-forms (concat "Downloading " path) "Done!" + (while (eq (process-status ssh) 'run) + (working-dynamic-status nil) + (sleep-for 0.05)) + (working-dynamic-status t)) + (kill-buffer pbuf))) + + +(provide 'package-transport) +;;; package-transport.el ends here + +;Local Variables: +;time-stamp-start: "Last-Modified:[ ]+\\\\?[\"<]+" +;time-stamp-end: "\\\\?[\">]" +;time-stamp-line-limit: 10 +;time-stamp-format: "%4y-%02m-%02d %02H:%02M:%02S (%u)" +;End: + Best, Joachim -- =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- Joachim Schrod Email: jschrod(a)acm.org Roedermark, Germany