mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
2001-04-17 Rob Browning <rlb@cs.utexas.edu>
* src/scm/utilities.scm (string-split): used to be string-split-on in qif-utils.scm * src/scm/qif-import/qif-utils.scm: move string-split-on to utilities.scm as string-split to better match string-join. * src/scm/qif-import/qif-to-gnc.scm (qif-import:qif-to-gnc): string-split-on -> string-split. * src/scm/qif-import/qif-dialog-utils.scm (qif-import:get-all-accts): string-split-on -> string-split. * src/scm/price-quotes.scm (yahoo-get-historical-quotes): new function - retrieve lists of historical quote information. * src/scm/bootstrap.scm.in (%load-path): add new guile-modules directory so we can use-modules from there. * src/guile/Makefile.am (CLEANFILES): add gnucash.c so it goes away on "make clean" in addition to "make distclean". * src/engine/gnc-pricedb.c: minor doc updates. * src/engine/gnc-pricedb.h: much more documentation. * lib/guile-www: new directory - contains guile-www CVS module. Used by new historical quote function. Several new files added. Installed to new install directory GNC_SHAREDIR/guile-modules such that it is available via (use-modules (www main)), etc. * lib/Makefile.am (SUBDIRS): add guile-www * configure.in (AC_OUTPUT): add lib/guile-www/Makefile git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@3988 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas
@@ -0,0 +1,4 @@
|
||||
Makefile
|
||||
config.cache
|
||||
config.log
|
||||
config.status
|
||||
@@ -0,0 +1,106 @@
|
||||
2001-02-04 Marius Vollmer <mvo@zagadka.ping.de>
|
||||
|
||||
* http.scm: Use (ice-9 rdelim) if `read-line' not defined. Thanks
|
||||
to Thien-Thi Nguyen.
|
||||
|
||||
2000-06-04 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
|
||||
|
||||
* main.scm (www:get): Pass url as single arg.
|
||||
(Thanks to Dale P. Smith.)
|
||||
|
||||
1998-07-27 Jim Blandy <jimb@red-bean.com>
|
||||
|
||||
* Test of EGCS repository access.
|
||||
|
||||
1997-12-24 Tim Pierce <twp@skepsis.com>
|
||||
|
||||
* cgi.scm (init-environment): Make server-software and
|
||||
server-protocol optional.
|
||||
|
||||
1997-12-22 Tim Pierce <twp@skepsis.com>
|
||||
|
||||
* cgi.scm (read-raw-form-data): Add `cgi-' to content-length.
|
||||
(parse-form): Change `url-decode' to `url:decode'.
|
||||
|
||||
Mon Oct 20 18:06:10 1997 Jim Blandy <jimb@totoro.red-bean.com>
|
||||
|
||||
* configure.in: Update version to 1.0b.
|
||||
configure: Regenerated.
|
||||
|
||||
* Makefile.in, aclocal.m4, configure: Regenerated w/automake 1.2c.
|
||||
|
||||
* url.scm (url:scheme, url:host, url:port, url:path): Move
|
||||
accessors up.
|
||||
(url:address): New accessor for "mailto:" URLs.
|
||||
(url:unknown): New accessor for unrecognized URL types.
|
||||
(url:user): New accessor for "ftp" URLs.
|
||||
(url:make, url:make-http, url:make-ftp, url:make-mailto): New
|
||||
constructors for URL objects.
|
||||
(url-regexp): Replaced by...
|
||||
(http-regexp, ftp-regexp, mailto-regexp): Separate regular
|
||||
expressions for different URL schemes.
|
||||
(url:parse): Use the above to handle ftp and mailto URLs, and also
|
||||
do something graceful with unrecognized garbage.
|
||||
(url:unparse): New function, for turning a parsed url into a
|
||||
string.
|
||||
|
||||
* http.scm (add-open-connection!, get-open-connection): Incomplete
|
||||
code replaced with dummy definitions, so we can give it to Mikael
|
||||
immediately.
|
||||
(http:request): Close the socket after we're done reading the
|
||||
body.
|
||||
|
||||
* http.scm (http:request): Reformatted for readability.
|
||||
|
||||
* http.scm (http:request): Don't expect a body in reply to a
|
||||
"HEAD" request, even though we do get a "content-length" header.
|
||||
|
||||
Tue Jun 17 17:27:04 1997 Tim Pierce <twpierce@bio-5.bsd.uchicago.edu>
|
||||
|
||||
* http.scm: (http:request): Force "/" onto the beginning of the
|
||||
"path" variable unconditionally. We must do this because of a
|
||||
stupid incompatibility between the URL RFC and HTTP RFC.
|
||||
|
||||
* http.scm: (parse-status-line): New function.
|
||||
(http:request): Use parse-status-line instead of
|
||||
separate-fields-discarding-char (which does not work when a status
|
||||
line contains more than two spaces).
|
||||
(separate-fields-discarding-char): Removed.
|
||||
|
||||
Tue Jun 17 01:45:59 1997 Tim Pierce <twp@twp.tezcat.com>
|
||||
|
||||
* http.scm (http:request): Change calling conventions to accept a
|
||||
method and a URL rather than a port and request string. Do some
|
||||
sanity checking on arguments.
|
||||
(http:get): Pass a single URL argument to http:request.
|
||||
(http:open): Permit port argument to be #f in addition to '().
|
||||
(display-with-crlf): Make port argument optional.
|
||||
(add-open-connection!): Braino fix (set! for setq).
|
||||
|
||||
* Makefile: New file. (Oops.)
|
||||
|
||||
Mon Jun 16 17:49:20 1997 Tim Pierce <twpierce@bio-5.bsd.uchicago.edu>
|
||||
|
||||
Release preparations.
|
||||
* Makefile.am, configure.in, install-sh, mkinstalldirs, missing:
|
||||
New files.
|
||||
* Makefile.in, configure, aclocal.m4: Generated, not re.
|
||||
* README: New file.
|
||||
|
||||
Sun Jun 15 00:50:22 1997 Tim Pierce <twp@twp.tezcat.com>
|
||||
|
||||
* http.scm: add some support for persistent connections.
|
||||
(http:connect): check get-open-connection before creating a new
|
||||
socket, and call add-open-connection! after creating one.
|
||||
(add-open-connection!): New function.
|
||||
(get-open-connection): New function.
|
||||
|
||||
Mon Jun 9 23:42:32 1997 Tim Pierce <twp@twp.tezcat.com>
|
||||
|
||||
New WWW module.
|
||||
* cgi.scm: New file.
|
||||
* http.scm: New file.
|
||||
* main.scm: New file.
|
||||
* url.scm: New file.
|
||||
* wwwcat: New file.
|
||||
|
||||
@@ -0,0 +1,5 @@
|
||||
|
||||
gncscmdir = ${GNC_SHAREDIR}/guile-modules/www
|
||||
gncscm_DATA = cgi.scm http.scm main.scm url.scm
|
||||
|
||||
EXTRA_DIST = README README.gnucash wwwcat
|
||||
@@ -0,0 +1,66 @@
|
||||
This is an alpha release of the Guile WWW library, version 1.0.
|
||||
|
||||
Roadmap:
|
||||
|
||||
The (www http) library includes some support for navigating HTTP
|
||||
connections. http:open, http:request and http:get may be used for
|
||||
opening connections and making HTTP requests; http:make-message,
|
||||
http:message-body and http:message-header may be used to
|
||||
manipulate HTTP messages. Support is planned for the full
|
||||
HTTP/1.1 protocol, including cookies and persistent connections.
|
||||
|
||||
(www url) provides url:parse for parsing a URL into its component
|
||||
parts, and the selector functions url:scheme, url:host, url:port
|
||||
and url:path for selecting individual components of a parsed URL.
|
||||
For individual components that may have been URL-encoded in
|
||||
transit, url:decode translates a string into its raw (unencoded)
|
||||
form.
|
||||
|
||||
(www cgi) provides some functions helpful in writing CGI scripts
|
||||
painlessly. The focus is on scripts to process interactive forms.
|
||||
cgi:init reads any form data and initializes a CGI environment.
|
||||
cgi:form-data? determines whether any form data has been returned
|
||||
by a browser for processing. cgi-value returns the value
|
||||
associated with a form variable, and cgi-names and cgi-values
|
||||
return all of the names and values present in the current form.
|
||||
|
||||
(www main) provides www:get, which decodes a URL and invokes the
|
||||
appropriate protocol handler for retrieving the desired object.
|
||||
It is intended to be a generic interface useful for retriving data
|
||||
named by any URL.
|
||||
|
||||
wwwcat is an example script of how www:get and other functions
|
||||
might be used by a Guile application.
|
||||
|
||||
A generic guide to hacking on Guile software follows.
|
||||
|
||||
Tim Pierce
|
||||
twp@tezcat.com
|
||||
|
||||
Hacking It Yourself ==================================================
|
||||
|
||||
As distributed, the Guile WWW library needs only a Unix system to build
|
||||
and install. However, its makefiles, configuration scripts, and a few
|
||||
other files are automatically generated, not written by hand. If you
|
||||
want to make changes to the system (which we encourage!) you will find
|
||||
it helpful to have the tools we use to develop it. They are the
|
||||
following:
|
||||
|
||||
Autoconf 2.12 --- a system for automatically generating `configure'
|
||||
scripts from templates which list the non-portable features a
|
||||
program would like to use. Available in
|
||||
"ftp://prep.ai.mit.edu/pub/gnu".
|
||||
|
||||
Automake 1.1p --- a system for automatically generating Makefiles that
|
||||
conform to the (rather Byzantine) GNU coding standards. The
|
||||
nice thing is that it takes care of hairy targets like 'make
|
||||
dist' and 'make distclean', and automatically generates
|
||||
Makefile dependencies. Available in
|
||||
"ftp://ftp.cygnus.com/pub/tromey".
|
||||
|
||||
libtool 0.9d --- a system for managing the zillion hairy options needed
|
||||
on various systems to produce shared libraries. Available in
|
||||
"ftp://alpha.gnu.ai.mit.edu/gnu".
|
||||
|
||||
You are lost in a little maze of automatically generated files, all
|
||||
different.
|
||||
@@ -0,0 +1,7 @@
|
||||
|
||||
This is a stripped down version of the guile-www CVS module. All of
|
||||
the automakery has been removed and it's been reconfigured to work
|
||||
with gnucash. In the long run, we'll probably switch to use whatever
|
||||
becomes the guile standard for www access.
|
||||
|
||||
|
||||
@@ -0,0 +1,185 @@
|
||||
;;;; cgi.scm: Common Gateway Interface support for WWW scripts.
|
||||
|
||||
(define-module (www cgi)
|
||||
:use-module (www url))
|
||||
|
||||
;;;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or modify
|
||||
;;;; it under the terms of the GNU General Public License as published by
|
||||
;;;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;;;; any later version.
|
||||
;;;;
|
||||
;;;; This program is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;;; GNU General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU General Public License
|
||||
;;;; along with this software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
(define form-variables '())
|
||||
|
||||
;;; CGI environment variables.
|
||||
;;; Should these all be public?
|
||||
|
||||
(define-public cgi-server-software-type #f)
|
||||
(define-public cgi-server-software-version #f)
|
||||
(define-public cgi-server-hostname #f)
|
||||
(define-public cgi-gateway-interface #f)
|
||||
(define-public cgi-server-protocol-name #f)
|
||||
(define-public cgi-server-protocol-version #f)
|
||||
(define-public cgi-server-port #f)
|
||||
(define-public cgi-request-method #f)
|
||||
(define-public cgi-path-info #f)
|
||||
(define-public cgi-path-translated #f)
|
||||
(define-public cgi-script-name #f)
|
||||
(define-public cgi-query-string #f)
|
||||
(define-public cgi-remote-host #f)
|
||||
(define-public cgi-remote-addr #f)
|
||||
(define-public cgi-authentication-type #f)
|
||||
(define-public cgi-remote-user #f)
|
||||
(define-public cgi-remote-ident #f)
|
||||
(define-public cgi-content-type #f)
|
||||
(define-public cgi-content-length #f)
|
||||
(define-public cgi-http-accept-types #f)
|
||||
(define-public cgi-http-user-agent #f)
|
||||
|
||||
|
||||
;;; CGI high-level interface
|
||||
;;;
|
||||
;;; A typical CGI program will first call (cgi:init) to initialize
|
||||
;;; the environment and read in any data returned from a form. Form
|
||||
;;; data can be extracted conveniently with these functions:
|
||||
;;;
|
||||
;;; (cgi:values NAME)
|
||||
;;; Fetch any values associated with NAME found in the form data.
|
||||
;;; Returned value is a list, even if it contains only one element.
|
||||
;;; (cgi:value NAME)
|
||||
;;; Fetch only the CAR from (cgi:values NAME). Convenient for when
|
||||
;;; you are certain that NAME is associated with only one value.
|
||||
|
||||
(define-public (cgi:init)
|
||||
(init-environment)
|
||||
(and cgi-content-length
|
||||
(parse-form (read-raw-form-data)))
|
||||
(and cgi-query-string
|
||||
(parse-form cgi-query-string)))
|
||||
|
||||
(define-public (cgi:values name)
|
||||
(assoc-ref form-variables name))
|
||||
|
||||
(define-public (cgi:value name)
|
||||
;; syntactic sugar for obtaining just one value from a particular key
|
||||
(let ((values (cgi:values name)))
|
||||
(and values (car values))))
|
||||
|
||||
(define-public (cgi:names) (map car form-variables))
|
||||
|
||||
(define-public (cgi:form-data?) (not (null? form-variables)))
|
||||
|
||||
|
||||
;;;; Internal functions.
|
||||
;;;;
|
||||
;;;; (parse-form DATA): parse DATA as raw form response data, adding
|
||||
;;;; values as necessary to `form-variables'.
|
||||
;;;; (read-raw-form-data): read in `content-length' bytes from stdin
|
||||
;;;; (init-environment): initialize CGI environment from Unix env vars.
|
||||
|
||||
(define (parse-form raw-data)
|
||||
;; get-name and get-value are used to parse individual `name=value' pairs.
|
||||
;; Values are URL-encoded, so url:decode must be called on each one.
|
||||
(define (get-name pair)
|
||||
(let ((p (string-index pair #\=)))
|
||||
(and p (make-shared-substring pair 0 p))))
|
||||
(define (get-value pair)
|
||||
(let ((p (string-index pair #\=)))
|
||||
(and p (url:decode (make-shared-substring pair (+ p 1))))))
|
||||
(for-each (lambda (pair)
|
||||
(let* ((name (get-name pair))
|
||||
(value (get-value pair))
|
||||
(old-value (cgi:values name)))
|
||||
(set! form-variables
|
||||
(assoc-set! form-variables
|
||||
name
|
||||
(cons value (or old-value '()))))))
|
||||
(separate-fields-discarding-char #\& raw-data)))
|
||||
|
||||
(define (read-raw-form-data)
|
||||
(and cgi-content-length (read-n-chars cgi-content-length)))
|
||||
|
||||
(define (init-environment)
|
||||
|
||||
;; SERVER_SOFTWARE format: name/version
|
||||
(let ((server-software (getenv "SERVER_SOFTWARE")))
|
||||
(if server-software
|
||||
(let ((slash (string-index server-software #\/)))
|
||||
(set! cgi-server-software-type (substring server-software 0 slash))
|
||||
(set! cgi-server-software-version (substring server-software (1+ slash))))))
|
||||
|
||||
(set! cgi-server-hostname (getenv "SERVER_NAME"))
|
||||
(set! cgi-gateway-interface (getenv "GATEWAY_INTERFACE"));"CGI/revision"
|
||||
|
||||
(let* ((server-protocol (getenv "SERVER_PROTOCOL")))
|
||||
(if server-protocol
|
||||
(let ((slash (string-index server-protocol #\/)))
|
||||
(set! cgi-server-protocol-name (substring server-protocol 0 slash))
|
||||
(set! cgi-server-protocol-version (substring server-protocol (1+ slash))))))
|
||||
|
||||
(let ((port (getenv "SERVER_PORT")))
|
||||
(set! cgi-server-port (and port (string->number port))))
|
||||
|
||||
(set! cgi-request-method (getenv "REQUEST_METHOD"))
|
||||
(set! cgi-path-info (getenv "PATH_INFO"))
|
||||
(set! cgi-path-translated (getenv "PATH_TRANSLATED"))
|
||||
(set! cgi-script-name (getenv "SCRIPT_NAME"))
|
||||
(set! cgi-remote-host (getenv "REMOTE_HOST"))
|
||||
(set! cgi-remote-addr (getenv "REMOTE_ADDR"))
|
||||
(set! cgi-authentication-type (getenv "AUTH_TYPE"))
|
||||
(set! cgi-remote-user (getenv "REMOTE_USER"))
|
||||
(set! cgi-remote-ident (getenv "REMOTE_IDENT"))
|
||||
(set! cgi-content-type (getenv "CONTENT_TYPE"))
|
||||
(set! cgi-query-string (getenv "QUERY_STRING"))
|
||||
|
||||
(and cgi-query-string
|
||||
(string-null? cgi-query-string)
|
||||
(set! cgi-query-string #f))
|
||||
|
||||
(let ((contlen (getenv "CONTENT_LENGTH")))
|
||||
(set! cgi-content-length (and contlen (string->number contlen))))
|
||||
|
||||
;; HTTP_ACCEPT is a list of MIME types separated by commas.
|
||||
(let ((types (getenv "HTTP_ACCEPT")))
|
||||
(set! cgi-http-accept-types
|
||||
(and types (separate-fields-discarding-char #\, types))))
|
||||
|
||||
;; HTTP_USER_AGENT format: software/version library/version.
|
||||
(set! cgi-http-user-agent (getenv "HTTP_USER_AGENT")))
|
||||
|
||||
|
||||
;;; System I/O and low-level stuff.
|
||||
|
||||
(define (read-n-chars num . port-arg)
|
||||
(let ((p (if (null? port-arg)
|
||||
(current-input-port)
|
||||
(car port-arg)))
|
||||
(s (make-string num)))
|
||||
(do ((i 0 (+ i 1))
|
||||
(ch (read-char p) (read-char p)))
|
||||
((or (>= i num) (eof-object? ch)) s)
|
||||
(string-set! s i ch))))
|
||||
|
||||
;; This is defined in #/ice-9/string-fun, but the interface is
|
||||
;; weird, the semantics perverse, and it doesn't work. We use
|
||||
;; a working copy here.
|
||||
(define (separate-fields-discarding-char ch str)
|
||||
(let loop ((fields '())
|
||||
(str str))
|
||||
(let ((pos (string-rindex str ch)))
|
||||
(if pos
|
||||
(loop (cons (make-shared-substring str (+ 1 pos)) fields)
|
||||
(make-shared-substring str 0 pos))
|
||||
(cons str fields)))))
|
||||
@@ -0,0 +1,302 @@
|
||||
;;;; http.scm: HTTP client library for Guile.
|
||||
;;;;
|
||||
|
||||
(define-module (www http)
|
||||
:use-module (www url)
|
||||
:use-module (ice-9 regex))
|
||||
|
||||
;;;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or modify
|
||||
;;;; it under the terms of the GNU General Public License as published by
|
||||
;;;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;;;; any later version.
|
||||
;;;;
|
||||
;;;; This program is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;;; GNU General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU General Public License
|
||||
;;;; along with this software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
;;; Compatibility
|
||||
|
||||
(or (defined? 'read-line)
|
||||
(use-modules (ice-9 rdelim)))
|
||||
|
||||
|
||||
;;; Variables that affect HTTP usage.
|
||||
|
||||
(define-public http:version "HTTP/1.0") ; bump up to 1.1 when ready
|
||||
(define-public http:user-agent "GuileHTTP 0.1")
|
||||
|
||||
;;; An HTTP message is represented by a vector:
|
||||
;;; #(VERSION STATUS-CODE STATUS-TEXT HEADERS BODY)
|
||||
;;;
|
||||
;;; Each of VERSION, STATUS-CODE, STATUS-TEXT are strings. HEADERS
|
||||
;;; is an alist of headers and their contents. BODY is a single string.
|
||||
|
||||
(define (http:make-message version statcode stattext headers body)
|
||||
(vector version statcode stattext headers body))
|
||||
|
||||
;;;; HTTP status predicates.
|
||||
;;;
|
||||
;;; (http:message-version MSG)
|
||||
;;; Returns the HTTP version in use in HTTP message MSG.
|
||||
;;;
|
||||
;;; (http:message-status-code MSG)
|
||||
;;; Returns the status code returned in HTTP message MSG.
|
||||
;;;
|
||||
;;; (http:message-status-text MSG)
|
||||
;;; Returns the text of the status line from HTTP message MSG.
|
||||
;;;
|
||||
;;; (http:message-status-ok? STATUS)
|
||||
;;; Returns #t if status code STATUS indicates a successful request,
|
||||
;;; #f otherwise.
|
||||
|
||||
(define-public (http:message-version msg) (vector-ref msg 0))
|
||||
(define-public (http:message-status-code msg) (vector-ref msg 1))
|
||||
(define-public (http:message-status-text msg) (vector-ref msg 2))
|
||||
(define-public (http:message-status-ok? msg)
|
||||
(http:status-ok? (http:status-code msg)))
|
||||
(define-public (http:status-ok? status)
|
||||
(char=? #\2 (string-ref status 0)))
|
||||
|
||||
(define-public (http:message-body msg) (vector-ref msg 4))
|
||||
|
||||
;;; HTTP response headers functions
|
||||
;;;
|
||||
;;; An HTTP message header is represented here by a pair. The CAR is a
|
||||
;;; symbol representing the header name, and the CDR is a string
|
||||
;;; containing the header text. E.g.:
|
||||
;;;
|
||||
;;; '((date . "Thu, 29 May 1997 23:48:27 GMT")
|
||||
;;; (server . "NCSA/1.5.1")
|
||||
;;; (last-modified . "Tue, 06 May 1997 18:32:03 GMT")
|
||||
;;; (content-type . "text/html")
|
||||
;;; (content-length . "8097"))
|
||||
;;;
|
||||
;;; Note: these symbols are all lowercase, although the original headers
|
||||
;;; were mixed-case. Clients using this library should keep this in
|
||||
;;; mind, since Guile symbols are case-sensitive.
|
||||
;;;
|
||||
;;; FIXME: should headers with known semantics be parsed automatically?
|
||||
;;; I.e. should the Content-Length header automatically get string->number?
|
||||
;;; Should Date and Last-Modified headers be run through strptime?
|
||||
;;; It is advantageous to keep headers in a uniform format, but it may
|
||||
;;; be convenient to parse headers that have unambiguous meanings.
|
||||
;;;
|
||||
;;; (http:message-headers MSG)
|
||||
;;; Returns a list of the headers from HTTP message MSG.
|
||||
;;; (http:message-header HEADER MSG)
|
||||
;;; Return the header field named HEADER from HTTP message MSG, or
|
||||
;;; #f if no such header is present in the message.
|
||||
|
||||
(define-public (http:message-headers msg) (vector-ref msg 3))
|
||||
(define-public (http:message-header header msg)
|
||||
(http:fetch-header header (http:message-headers msg)))
|
||||
|
||||
(define (http:fetch-header header header-alist)
|
||||
(assq-ref header-alist header))
|
||||
|
||||
(define header-regex (make-regexp ": *"))
|
||||
|
||||
(define (http:header-parse hd)
|
||||
(let ((match (regexp-exec header-regex hd)))
|
||||
(cons (string->symbol
|
||||
(apply string
|
||||
(map char-downcase
|
||||
(string->list (match:prefix match)))))
|
||||
(match:suffix match))))
|
||||
|
||||
(define (parse-status-line statline)
|
||||
(let* ((first (string-index statline #\space))
|
||||
(second (string-index statline #\space (1+ first))))
|
||||
(list (make-shared-substring statline 0 first)
|
||||
(make-shared-substring statline (1+ first) second)
|
||||
(make-shared-substring statline (1+ second)))))
|
||||
|
||||
|
||||
;;; HTTP connection management functions.
|
||||
;;;
|
||||
;;; Open connections are cached on hostname in the connection-table.
|
||||
;;; If an HTTP connection is already open to a particular host and TCP port,
|
||||
;;; looking up the hostname and port number in connection-table will yield
|
||||
;;; a Scheme port that may be used to communicate with that server.
|
||||
|
||||
(define connection-table '())
|
||||
|
||||
;; FIXME: you can only re-use a connection if the server sends the
|
||||
;; Keep-Alive header, I think. With these definitions, we were trying to
|
||||
;; send more requests on connections the server assumed were dead.
|
||||
;; (define (add-open-connection! host tcp-port port)
|
||||
;; (set! connection-table
|
||||
;; (assoc-set! connection-table (cons host tcp-port) port)))
|
||||
;; (define (get-open-connection host tcp-port)
|
||||
;; (assoc-ref connection-table (cons host tcp-port)))
|
||||
|
||||
(define (add-open-connection! host tcp-port port)
|
||||
#f)
|
||||
(define (get-open-connection host tcp-port)
|
||||
#f)
|
||||
|
||||
|
||||
;;; HTTP methods.
|
||||
;;;
|
||||
;;; Common methods: GET, POST etc.
|
||||
|
||||
(define-public (http:get url)
|
||||
;; FIXME: if http:open returns an old connection that has been
|
||||
;; closed remotely, this will fail.
|
||||
(http:request "GET" url))
|
||||
|
||||
;;; Connection-oriented functions:
|
||||
;;;
|
||||
;;; (http:open HOST [PORT])
|
||||
;;; Return an HTTP connection to HOST on TCP port PORT (default 80).
|
||||
;;; If an open connection already exists, use it; otherwise, create
|
||||
;;; a new socket.
|
||||
|
||||
(define-public (http:open host . args)
|
||||
(let ((port (cond ((null? args) 80)
|
||||
((not (car args)) 80)
|
||||
(else (car args)))))
|
||||
(or (get-open-connection host port)
|
||||
(let* ((tcp (vector-ref (getproto "tcp") 2))
|
||||
(addr (car (vector-ref (gethost host) 4)))
|
||||
(sock (socket AF_INET SOCK_STREAM tcp)))
|
||||
(connect sock AF_INET addr port)
|
||||
(add-open-connection! host port sock)
|
||||
sock))))
|
||||
|
||||
;;; (http:request METHOD URL [HEADERS [BODY]])
|
||||
;;; Submit an HTTP request.
|
||||
;;; URL is a structure returned by url:parse.
|
||||
;;; METHOD is the name of some HTTP method, e.g. "GET" or "POST".
|
||||
;;; The optional HEADERS and BODY arguments are lists of strings
|
||||
;;; which describe HTTP messages. The `Content-Length' header
|
||||
;;; is calculated automatically and should not be supplied.
|
||||
;;;
|
||||
;;; Example usage:
|
||||
;;; (http:request "get" parsed-url
|
||||
;;; (list "User-Agent: GuileHTTP 0.1"
|
||||
;;; "Content-Type: text/plain"))
|
||||
;;; (http:request "post" parsed-url
|
||||
;;; (list "User-Agent: GuileHTTP 0.1"
|
||||
;;; "Content-Type: unknown/x-www-form-urlencoded")
|
||||
;;; (list "search=Gosper"
|
||||
;;; "case=no"
|
||||
;;; "max_hits=50"))
|
||||
|
||||
(define-public (http:request method url . args)
|
||||
(let ((host (url:host url))
|
||||
(tcp-port (or (url:port url) 80))
|
||||
(path (string-append "/" (or (url:path url) ""))))
|
||||
(let ((sock (http:open host tcp-port))
|
||||
(request (string-append method " " path " " http:version))
|
||||
(headers (if (pair? args) (car args) '()))
|
||||
(body (if (and (pair? args) (pair? (cdr args)))
|
||||
(cadr args)
|
||||
'())))
|
||||
(let* ((content-length
|
||||
(apply +
|
||||
(map (lambda (line)
|
||||
(+ 2 (string-length line))) ; + 2 for CRLF
|
||||
body)))
|
||||
(headers (if (positive? content-length)
|
||||
(cons (string-append "Content-Length: "
|
||||
(number->string content-length))
|
||||
headers)
|
||||
headers)))
|
||||
|
||||
(with-output-to-port sock
|
||||
(lambda ()
|
||||
(display-with-crlf request)
|
||||
(for-each display-with-crlf headers)
|
||||
(display "\r\n")
|
||||
(for-each display-with-crlf body)))
|
||||
|
||||
;; parse and add status line
|
||||
;; also cons up a list of response headers
|
||||
(let* ((response-status-line (sans-trailing-whitespace
|
||||
(read-line sock 'trim)))
|
||||
(response-headers
|
||||
(let make-header-list ((ln (sans-trailing-whitespace
|
||||
(read-line sock 'trim)))
|
||||
(hlist '()))
|
||||
(if (= 0 (string-length ln))
|
||||
hlist
|
||||
(make-header-list (sans-trailing-whitespace
|
||||
(read-line sock 'trim))
|
||||
(cons (http:header-parse ln)
|
||||
hlist)))))
|
||||
(response-status-fields
|
||||
(parse-status-line response-status-line))
|
||||
(response-version (car response-status-fields))
|
||||
(response-code (cadr response-status-fields))
|
||||
(response-text (caddr response-status-fields)))
|
||||
|
||||
;; signal error if HTTP status is invalid
|
||||
;; (or (http:status-ok? response-code)
|
||||
;; (error 'http-status "HTTP server returned bad status"
|
||||
;; response-status-line))
|
||||
;; Get message body: if Content-Length header was supplied, read
|
||||
;; that many chars. Otherwise, read until EOF
|
||||
|
||||
(let ((content-length (http:fetch-header
|
||||
"content-length"
|
||||
response-headers)))
|
||||
(let ((response-body
|
||||
(if (and content-length
|
||||
(not (string-ci=? method "HEAD")))
|
||||
(read-n-chars (string->number content-length) sock)
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(while (not (eof-object? (peek-char sock)))
|
||||
(display (read-char sock))))))))
|
||||
|
||||
;; FIXME: what about keepalives?
|
||||
(close-port sock)
|
||||
|
||||
(http:make-message response-version
|
||||
response-code
|
||||
response-text
|
||||
response-headers
|
||||
response-body))))))))
|
||||
|
||||
|
||||
|
||||
;;;; System interface cruft & string funcs
|
||||
|
||||
(define (read-n-chars num . port-arg)
|
||||
(let ((p (if (null? port-arg)
|
||||
(current-input-port)
|
||||
(car port-arg)))
|
||||
(s (make-string num)))
|
||||
(do ((i 0 (+ i 1))
|
||||
(ch (read-char p) (read-char p)))
|
||||
((or (>= i num) (eof-object? ch)) s)
|
||||
(string-set! s i ch))))
|
||||
|
||||
(define (display-with-crlf line . p)
|
||||
(apply display line p)
|
||||
(apply display "\r\n" p))
|
||||
|
||||
;;; (sans-trailing-whitespace STR)
|
||||
;;; These are defined in module #/ice-9/string-fun, so this code
|
||||
;;; will prob. be discarded when the module system and boot-9
|
||||
;;; settle down.
|
||||
|
||||
(define (sans-trailing-whitespace s)
|
||||
(let ((st 0)
|
||||
(end (string-length s)))
|
||||
(while (and (< 0 end)
|
||||
(char-whitespace? (string-ref s (1- end))))
|
||||
(set! end (1- end)))
|
||||
(if (< end st)
|
||||
""
|
||||
(make-shared-substring s st end))))
|
||||
@@ -0,0 +1,49 @@
|
||||
;;;; www/main.scm: general WWW navigation aids.
|
||||
|
||||
(define-module (www main)
|
||||
:use-module (www http)
|
||||
:use-module (www url))
|
||||
|
||||
;;;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or modify
|
||||
;;;; it under the terms of the GNU General Public License as published by
|
||||
;;;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;;;; any later version.
|
||||
;;;;
|
||||
;;;; This program is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;;; GNU General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU General Public License
|
||||
;;;; along with this software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
(define dispatch-table
|
||||
(acons 'http http:get '()))
|
||||
|
||||
;;; (www:get URL)
|
||||
;;; parse a URL into portions, open a connection, and retrieve
|
||||
;;; selected document
|
||||
|
||||
(define-public (www:set-protocol-handler! proto handler)
|
||||
(set! dispatch-table
|
||||
(assq-set! dispatch-table proto handler)))
|
||||
|
||||
(define-public (www:get url-str)
|
||||
(let ((url (url:parse url-str)))
|
||||
;; get handler for this protocol
|
||||
(case (url:scheme url)
|
||||
((http) (let ((msg (http:get url)))
|
||||
(http:message-body msg)))
|
||||
(else
|
||||
(let ((handle (assq-ref dispatch-table (url:scheme url))))
|
||||
(if handle
|
||||
(handle (url:host url)
|
||||
(url:port url)
|
||||
(url:path url))
|
||||
(error "unknown URL scheme" (url:scheme url))))))))
|
||||
|
||||
@@ -0,0 +1,152 @@
|
||||
;;;; url.scm: URL manipulation tools.
|
||||
|
||||
(define-module (www url)
|
||||
:use-module (ice-9 regex))
|
||||
|
||||
;;;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or modify
|
||||
;;;; it under the terms of the GNU General Public License as published by
|
||||
;;;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;;;; any later version.
|
||||
;;;;
|
||||
;;;; This program is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;;; GNU General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU General Public License
|
||||
;;;; along with this software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
;;;; TODO:
|
||||
;;;; * support `user:password@' strings where appropriate in URLs.
|
||||
;;;; * make URL parsing smarter. This is good for most TCP/IP-based
|
||||
;;;; URL schemes, but parsing is actually specific to each URL scheme.
|
||||
;;;; * fill out url:encode, include facilities for URL-scheme-specific
|
||||
;;;; encoding methods (e.g. a url-scheme-reserved-char-alist)
|
||||
|
||||
;; `url:scheme' is an unfortunate term, but it is the technical
|
||||
;; name for that portion of the URL according to RFC 1738. Sigh.
|
||||
|
||||
(define-public (url:scheme url) (vector-ref url 0))
|
||||
(define-public (url:address url) (vector-ref url 1))
|
||||
(define-public (url:unknown url) (vector-ref url 1))
|
||||
(define-public (url:user url) (vector-ref url 1))
|
||||
(define-public (url:host url) (vector-ref url 2))
|
||||
(define-public (url:port url) (vector-ref url 3))
|
||||
(define-public (url:path url) (vector-ref url 4))
|
||||
|
||||
(define-public (url:make scheme . args)
|
||||
(apply vector scheme args))
|
||||
(define-public (url:make-http host port path)
|
||||
(vector 'http #f host port path))
|
||||
(define-public (url:make-ftp user host port path)
|
||||
(vector 'ftp user host port path))
|
||||
(define-public (url:make-mailto address)
|
||||
(vector 'mailto address))
|
||||
|
||||
(define http-regexp (make-regexp "^http://([^:/]+)(:([0-9]+))?(/(.*))?$"))
|
||||
(define ftp-regexp
|
||||
(make-regexp "^ftp://(([^@:/]+)@)?([^:/]+)(:([0-9]+))?(/(.*))?$"))
|
||||
(define mailto-regexp (make-regexp "^mailto:(.*)$"))
|
||||
|
||||
(define-public (url:parse url)
|
||||
(cond
|
||||
((regexp-exec http-regexp url)
|
||||
=> (lambda (m)
|
||||
(url:make-http (match:substring m 1)
|
||||
(cond ((match:substring m 3) => string->number)
|
||||
(else #f))
|
||||
(match:substring m 5))))
|
||||
|
||||
((regexp-exec ftp-regexp url)
|
||||
=> (lambda (m)
|
||||
(url:make-ftp (match:substring m 2)
|
||||
(match:substring m 3)
|
||||
(cond ((match:substring m 5) => string->number)
|
||||
(else #f))
|
||||
(match:substring m 7))))
|
||||
|
||||
((regexp-exec mailto-regexp url)
|
||||
=> (lambda (m)
|
||||
(url:make-mailto (match:substring m 1))))
|
||||
|
||||
(else
|
||||
(url:make 'unknown url))))
|
||||
|
||||
|
||||
(define-public (url:unparse url)
|
||||
(define (pathy scheme username host port path)
|
||||
(string-append (symbol->string scheme)
|
||||
"://" host
|
||||
(if port (string-append ":" (number->string port))
|
||||
"")
|
||||
(if path (string-append "/" path)
|
||||
"")))
|
||||
(case (url:scheme url)
|
||||
((http) (pathy 'http #f
|
||||
(url:host url)
|
||||
(url:port url)
|
||||
(url:path url)))
|
||||
((ftp) (pathy 'ftp
|
||||
(url:user url)
|
||||
(url:host url)
|
||||
(url:port url)
|
||||
(url:path url)))
|
||||
((mailto) (string-append "mailto:" (url:address url)))
|
||||
((unknown) (url:unknown url))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; (url-decode STR)
|
||||
;; Turn + into space, and hex-encoded %XX strings into their
|
||||
;; eight-bit characters. Is a regexp faster than character
|
||||
;; scanning? Does it incur more overhead (which may be more
|
||||
;; important for code that frequently gets restarted)?
|
||||
|
||||
(define-public (url:decode str)
|
||||
(regexp-substitute/global #f "\\+|%([0-9A-Fa-f][0-9A-Fa-f])" str
|
||||
'pre
|
||||
(lambda (m)
|
||||
(cond ((string=? "+" (match:substring m 0)) " ")
|
||||
(else (integer->char
|
||||
(string->number
|
||||
(match:substring m 1)
|
||||
16)))))
|
||||
'post))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; (url-encode STR)
|
||||
;; The inverse of url-decode. Can't be done easily with
|
||||
;; a regexp: we would have to construct a regular expression
|
||||
;; like "[\277-\377]", for example, and Guile strings don't
|
||||
;; let you interpolate character literals. Pity.
|
||||
;; URL-encode any characters in STR that are not safe: these
|
||||
;; include any character not in the SAFE-CHARS list and any
|
||||
;; character that *is* in the RESERVED-CHARS list argument.
|
||||
|
||||
(define-public (url:encode str reserved-chars)
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(for-each (lambda (ch)
|
||||
(if (and (safe-char? ch)
|
||||
(not (memv ch reserved-chars)))
|
||||
(display ch)
|
||||
(begin
|
||||
(display #\%)
|
||||
(display (number->string (char->integer ch) 16)))))
|
||||
(string->list str)))))
|
||||
|
||||
(define safe-chars
|
||||
'(#\$ #\- #\_ #\. #\+ #\! #\* #\' #\( #\) #\, #\; #\/ #\? #\: #\@ #\& #\=))
|
||||
|
||||
(define (safe-char? ch)
|
||||
;; ``Thus, only alphanumerics, the special characters "$-_.+!*'(),", and
|
||||
;; reserved characters used for their reserved purposes may be used
|
||||
;; unencoded within a URL.'' RFC 1738, #2.2.
|
||||
(or (char-alphabetic? ch)
|
||||
(char-numeric? ch)
|
||||
(memv ch safe-chars)))
|
||||
Executable
+28
@@ -0,0 +1,28 @@
|
||||
#!/usr/local/opt/guile-cvs/bin/guile -s
|
||||
!#
|
||||
|
||||
;;;; wwwcat: a trivial `cat' program for WWW resources.
|
||||
;;;;
|
||||
;;;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or modify
|
||||
;;;; it under the terms of the GNU General Public License as published by
|
||||
;;;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;;;; any later version.
|
||||
;;;;
|
||||
;;;; This program is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;;; GNU General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU General Public License
|
||||
;;;; along with this software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
(use-modules (www main))
|
||||
|
||||
(if (program-arguments)
|
||||
(display (www:get (list-ref (program-arguments) 1)))
|
||||
(display "wwwget: no document specified" (current-error-port)))
|
||||
Reference in New Issue
Block a user