http package (only partially working)

Makefile.in

@@ -505,6 +505,7 @@ all: startup.yss
 	@INSTALL_DLLS@ (cd library/rltree; $(MAKE))
 	@INSTALL_DLLS@ (cd library/lammpi; $(MAKE))
 	@INSTALL_DLLS@ (cd library/matrix; $(MAKE))
+	@INSTALL_DLLS@ (cd packages/http; $(MAKE))
 	@INSTALL_DLLS@ (cd packages/sgml; $(MAKE))
 	@INSTALL_DLLS@ (cd packages/plunit; $(MAKE))
 	@USE_MINISAT@ (cd packages/swi-minisat2/C; $(MAKE))
@@ -547,6 +548,7 @@ install_unix: startup.yss libYap.a
 	for f in $(PL_SOURCES); do $(INSTALL) $$f $(DESTDIR)$(SHAREDIR)/Yap/pl; done
 	@INSTALL_DLLS@ (cd packages/PLStream; $(MAKE) install)
 	@INSTALL_DLLS@ (cd packages/plunit; $(MAKE) install)
+	@INSTALL_DLLS@ (cd packages/http; $(MAKE) install)
 	@INSTALL_DLLS@ (cd packages/sgml; $(MAKE) install)
 	@USE_MINISAT@ (cd packages/swi-minisat2/C; $(MAKE) install)
 	@INSTALL_DLLS@ (cd library/random; $(MAKE) install)
@@ -593,6 +595,7 @@ install_win32: startup.yss
 	$(INSTALL) parms.h $(DESTDIR)$(INCLUDEDIR)/parms.h
 	(cd packages/PLStream; $(MAKE) install)
 	(cd packages/plunit; $(MAKE) install)
+	(cd packages/http; $(MAKE) install)
 	(cd packages/sgml; $(MAKE) install)
 	@USE_MINISAT@ (cd packages/swi-minisat2/C; $(MAKE) install)
 	(cd library/random; $(MAKE) install)

configure

@@ -7123,7 +7123,7 @@ then
   YAPLIB_CFLAGS="$SHLIB_CFLAGS"
   YAPLIB="$DYNYAPLIB"
 else
-  YAPLIB_CFLAGS"$CFLAGS"
+  YAPLIB_CFLAGS="$CFLAGS"
 fi
 
 if test "$coroutining" = "yes"
@@ -9212,6 +9212,7 @@ CHR_TARGETS=chr_support."$SO"
 
 
 CLIB_TARGETS="random.$SO unix.$SO socket.$SO cgi.$SO memfile.$SO files.$SO mime.$SO crypt.$SO"
+CLIB_PLTARGETS="\$(srcdir)/random.pl \$(srcdir)/unix.pl \$(srcdir)/socket.pl \$(srcdir)/cgi.pl \$(srcdir)/memfile.pl \$(srcdir)/filesex.pl \$(srcdir)/mime.pl \$(srcdir)/crypt.pl"
 
 ac_fn_c_check_func "$LINENO" "socket" "ac_cv_func_socket"
 if test "x$ac_cv_func_socket" = x""yes; then :
@@ -9448,6 +9449,7 @@ fi
 
 
 
+mkdir -p  library/lammpi
 mkdir -p  library/matrix
 mkdir -p  library/matlab
 mkdir -p  library/mpi
@@ -9456,7 +9458,6 @@ mkdir -p  library/regex
 mkdir -p  library/system
 mkdir -p  library/tries
 mkdir -p  library/rltree
-mkdir -p  library/lammpi
 mkdir -p  library/yap2swi
 mkdir -p  LGPL/clp
 mkdir -p  LGPL/swi_console
@@ -9472,6 +9473,7 @@ mkdir -p  packages/clpqr
 mkdir -p  packages/cplint
 mkdir -p  packages/cplint/approx
 mkdir -p  packages/cplint/approx/simplecuddLPADs
+mkdir -p  packages/http
 mkdir -p  packages/jpl
 mkdir -p  packages/jpl/src/java
 mkdir -p  packages/jpl/src/java/jpl
@@ -9529,6 +9531,8 @@ ac_config_files="$ac_config_files packages/cplint/Makefile"
 
 ac_config_files="$ac_config_files packages/cplint/approx/simplecuddLPADs/Makefile"
 
+ac_config_files="$ac_config_files packages/http/Makefile"
+
 ac_config_files="$ac_config_files packages/PLStream/Makefile"
 
 ac_config_files="$ac_config_files packages/plunit/Makefile"
@@ -10272,6 +10276,7 @@ do
     "packages/CLPBN/Makefile") CONFIG_FILES="$CONFIG_FILES packages/CLPBN/Makefile" ;;
     "packages/cplint/Makefile") CONFIG_FILES="$CONFIG_FILES packages/cplint/Makefile" ;;
     "packages/cplint/approx/simplecuddLPADs/Makefile") CONFIG_FILES="$CONFIG_FILES packages/cplint/approx/simplecuddLPADs/Makefile" ;;
+    "packages/http/Makefile") CONFIG_FILES="$CONFIG_FILES packages/http/Makefile" ;;
     "packages/PLStream/Makefile") CONFIG_FILES="$CONFIG_FILES packages/PLStream/Makefile" ;;
     "packages/plunit/Makefile") CONFIG_FILES="$CONFIG_FILES packages/plunit/Makefile" ;;
     "packages/ProbLog/Makefile") CONFIG_FILES="$CONFIG_FILES packages/ProbLog/Makefile" ;;

configure.in

@@ -1134,7 +1134,7 @@ then
   YAPLIB_CFLAGS="$SHLIB_CFLAGS"
   YAPLIB="$DYNYAPLIB"
 else
-  YAPLIB_CFLAGS"$CFLAGS"
+  YAPLIB_CFLAGS="$CFLAGS"
 fi
 
 if test "$coroutining" = "yes"
@@ -1722,6 +1722,7 @@ AC_SUBST(CLIB_NETLIBS)
 AC_SUBST(CLIB_CRYPTLIBS)
 
 CLIB_TARGETS="random.$SO unix.$SO socket.$SO cgi.$SO memfile.$SO files.$SO mime.$SO crypt.$SO"
+CLIB_PLTARGETS="\$(srcdir)/random.pl \$(srcdir)/unix.pl \$(srcdir)/socket.pl \$(srcdir)/cgi.pl \$(srcdir)/memfile.pl \$(srcdir)/filesex.pl \$(srcdir)/mime.pl \$(srcdir)/crypt.pl"
 
 AC_CHECK_FUNC(socket, [], [
              AC_CHECK_LIB(socket, socket,
@@ -1779,6 +1780,7 @@ fi
 
 
 
+mkdir -p  library/lammpi
 mkdir -p  library/matrix
 mkdir -p  library/matlab
 mkdir -p  library/mpi
@@ -1787,7 +1789,6 @@ mkdir -p  library/regex
 mkdir -p  library/system
 mkdir -p  library/tries
 mkdir -p  library/rltree
-mkdir -p  library/lammpi
 mkdir -p  library/yap2swi
 mkdir -p  LGPL/clp
 mkdir -p  LGPL/swi_console
@@ -1803,6 +1804,7 @@ mkdir -p  packages/clpqr
 mkdir -p  packages/cplint
 mkdir -p  packages/cplint/approx
 mkdir -p  packages/cplint/approx/simplecuddLPADs
+mkdir -p  packages/http
 mkdir -p  packages/jpl
 mkdir -p  packages/jpl/src/java
 mkdir -p  packages/jpl/src/java/jpl
@@ -1838,6 +1840,7 @@ AC_CONFIG_FILES([packages/clib/maildrop/rfc2045/Makefile])
 AC_CONFIG_FILES([packages/CLPBN/Makefile])
 AC_CONFIG_FILES([packages/cplint/Makefile])
 AC_CONFIG_FILES([packages/cplint/approx/simplecuddLPADs/Makefile])
+AC_CONFIG_FILES([packages/http/Makefile])
 AC_CONFIG_FILES([packages/PLStream/Makefile])
 AC_CONFIG_FILES([packages/plunit/Makefile])
 AC_CONFIG_FILES([packages/ProbLog/Makefile ])

packages/http/ChangeLog

@@ -0,0 +1,792 @@
+[Sep 13 2009]
+
+ * ADDED: Process HTTP DELETE, OPTIONS and TRACE methods.  Torbjörn Lager.
+
+[Aug 27 2009]
+
+ * FIXED: JSON Mimetype handling.  Matt Lilley.
+
+[Aug 25 2009]
+
+ * ENHANCED: Made the detection of JSON more flexible.
+
+ * ENHANCED: JSON indentation handling.  Matt Lilley.
+
+[Aug 21 2009]
+
+ * ENHANCED: Bug#414: Get rid of pool/4 in HTTP request structures.
+   Lourens van der Meij.
+
+[Aug 18 2009]
+
+ * CLEANUP: Bug#413: Complete 'make distclean'.  Feliks Kluzniak
+
+[Aug 16 2009]
+
+ * DOC: Provide documentation of http_dispatch.pl through PlDoc
+
+ * ADDED: http_redirect/3 to simplify writing redirect handlers and enhance the reflexive capabilities of the HTTP server.
+
+[Aug 14 2009]
+
+ * ADDED: Allow grouping of HTTP parameters
+
+ * ADDED: Support disjunctive types in HTTP parameter handling
+
+ * CLEANUP: Use meta_predicate for json_convert.pl
+
+[Aug 13 2009]
+
+ * ADDED: type nonneg to http_parameters/3.
+
+ * ADDED: PlDoc wiki to handle references as module:name/arity.
+
+ * ADDED: Allow hooking http_parameters type checking and conversion.
+
+ * ADDED: &(Int) is written as &#Int; in html_write.  Clarified the documentation.
+
+ * ADDED: Types list(Type), boolean and atom to http_parameters/3.
+
+[Aug 12 2009]
+
+ * ENHANCED: Better handing of \[...] in cross-referencer
+
+[Aug 10 2009]
+
+ * FIXED: Properly deal with external resources
+
+ * FIXED: Module-handling of body//1 and head//1 hooks in html_write.pl
+
+ * FIXED: Actually handle timout of the threaded HTTP deamon.  The connection is now dropped after 60 seconds inactivity of the client.
+
+ * FIXED: HTTP server DoS if the clients sends an empty Cookie header.
+
+[Jul 21 2009]
+
+ * MODIFIED: Make initialization/1 ISO compliant
+   This patch is a modest cleanup to the implementation of '$load_file'/3
+   from init.pl and provides an ISO compatible implementation of
+   initialization/1. This executes the argument goal *after* loading the
+   file rather than when encountering the directive. Often this makes no
+   difference, but notably load_foreign_library/1 is an exception.
+   Therefore we added use_foreign_library/1,2 that act as a directive and
+   provides proper integration with saved-states automatically.  Loading
+   code using initialization(load_foreign_library(...)) will load the
+   library immediately and issue a warning.
+
+   See initialization/1,2 for details and further hints for dealing with
+   possible compatibility problems.
+[Jul 1 2009]
+
+ * ADDED: Allow \-escape inside html(\List).
+
+ * ADDED: Return the fact that a handler is a prefix handler in http_current_handler/3.
+
+ * ADDED: Allow for http_handler(root(find/concept), ...).  I.e., allow for component/component without quotes,
+
+[Jun 29 2009]
+
+ * FIXED: http_currect_session(-, ?) did not generate (all) sessions.
+
+ * ADDED: http_close_session/1
+
+[Jun 23 2009]
+
+ * MODIFIED: Added option unsafe(Bool) to http_reply_file/3.  This option is by default false, which causes this predicate to refuse serving files with an absolute path, a path outside the working directory or, if an alias(Path) is used, outside the root of the alias.
+   If you want to serve such files, you must provide unsafe(true) explicitely.
+
+ * ADDED: Reply with 400 Bad Request on illegal HTTP requests
+
+[Mar 19 2009]
+
+ * CLEANUP: Removed all trailing whitespace from all source-files.  This avoids many GIT (merge) warnings.
+[Mar 12 2009]
+
+ * FIXED: Avoid race condition in session management.  Jacco van Ossenbruggen.
+
+ * MODIFIED: Renamed concat_atom/2,3 into atomic_list_concat/2,3 for compatibility.  Moved the old predicates into library(backcomp).  It is adviced to update your code, but 99% of the code will remain working because the old definitions are autoloaded.
+
+[Feb 27 2009]
+
+ * FIXED: http_current_server/2 was broken with meta_predicate introduction.
+
+[Feb 25 2009]
+
+ * ENHANCED: Use a cache for http_in_session/1 to avoid repetitive access to the CGI stream object.
+
+ * FIXED: make http_current_request/1 semidet again.  Added is_cgi_stream/1 for testing whether we are in a CGI context without raising an error.
+
+[Feb 23 2009]
+
+ * ENHANCED: Allow the start broadcast-message of the HTTP server to throw an exception.  This allows for defining additional policy-handlers as broadcast plugins.
+
+[Feb 20 2009]
+
+ * ADDED: Use nlink property of stream to close the logfile
+
+[Feb 15 2009]
+
+ * FIXED: Proper reply on partial content (use 206 reply; fix length computation)
+
+[Feb 3 2009]
+
+ * ADDED: HTTP server support for byte-ranges of files.
+
+ * ADDED: Parsing of HTTP Range field into a structured term
+
+[Jan 30 2009]
+
+ * ENHANCED: HTTP error handler in formulating replies from a file.
+
+[Jan 29 2009]
+
+ * CLEANUP: be careful, but to not crash on unexpected event on CGI streams.
+
+[Jan 28 2009]
+
+ * ADDED: When matching a prefix-path in http_dispatch, makethe remainder
+   of the path available through path_info(PathInfo) in the request.
+
+[Jan 22 2009]
+
+ * ADDED: http_in_session/1 to find the current session but do not raise an
+   exception if it doesn't exist.
+
+ * ADDED: http_current_handler/3 to get access to accumulated options on a path
+
+[Jan 20 2009]
+
+ * FIXED: ?- edit(HTTPLocation).  Module-handling issue in locate/3 in http_dispatch.pl
+
+ * CLEANUP: http_wrapper.pl: PlDoc and meta-predicate handler
+
+ * FIXED: http_open/3: avoid leaking a socket-handle if the tcp_connect
+   raises an exception.
+
+[Jan 9 2009]
+
+ * ADDED: library(http/html_head), tracking CSS and Javascript dependencies and
+   merging them automatically into the HTML <HEAD> element.  Imported from
+   Cliopatria project.
+[Dec 20 2008]
+
+ * ADDED: http_log_close/1 to provide for cooperation with logrotate
+
+[Dec 18 2008]
+
+ * MSFIX: Accept invalid cookie options sent by Microsoft (httponly). Matt Lilley.
+[Nov 26 2008]
+
+ * FIXED: Update HTTP header definition for a token to RFC 2616.  Matt Lilley
+[Oct 9 2008]
+
+ * ADDED: More flexible support for HTTP 503 (service unavailable) replies.
+
+[Oct 8 2008]
+
+ * FIXED: drop body of HTTP 304 response
+
+[Oct 7 2008]
+
+ * MODIFIED: Generalized the HTTP dispatch module authentication interface.
+       * Instead of returning an atom representing the authenticated
+       user, the hook must deliver a list of options that is added to
+       the request.  The new API allows for multiple authentication
+       hooks on the same location.  It is used by PlDoc to provide host
+       access control.  See doc_access.pl from the PlDoc package.
+
+[Oct 6 2008]
+
+ * FIXED: Updated http_error to deal with new HTTP server
+
+[Oct 5 2008]
+
+ * ADDED: Support http_path.pl specifications in http_handler/3.
+
+ * MODIFIED: library(http/http_dispatch): Handler changes.
+   :- http_handler(prefix(Path), Action, Options) is now
+   translated into http_handler(Path, Action, [prefix|Options]) with a
+   warning.  Future versions will drop the prefix(Path) syntax as it
+   becomes ambiguous after integrating http_path.pl with the handler
+   declarations.
+
+ * ADDED: html_write.pl: Support href(loc+[name1(value1),name2(value2)])
+
+[Oct 3 2008]
+
+ * ADDED: Support encode(Value) and describe http location handling.
+
+ * ADDED: http_location_by_id/2 and location_by_id(ID) to html_write values.
+   Suggested by Jacco van Ossenbruggen.
+
+[Oct 2 2008]
+
+ * ADDED: Allow redefining the HTTP server address output of non-200 pages.
+
+ * ADDED: Provide hostname in http error messages
+
+ * FIXED: File descriptor leak in http session management.
+
+[Oct 1 2008]
+
+ * FIXED: undefined parse_url_ex/3 in http_open.pl (deals with redirections)
+
+[Sep 30 2008]
+
+ * ADDED: Support for proxy routes in HTTP session management.  Also cleanup
+   and additional tests in library(http/http_session).
+
+[Sep 11 2008]
+
+ * PORT: Add AC_PREREQ to configure.h for systems that auto-select autoconf
+   versions.  After tip by Ulrich Neumerkel.
+
+[Aug 30 2008]
+
+ * FIXED: use csym instead of csymf for valid HTTP fieldname characters.  Edward Blake.
+
+[Aug 11 2008]
+
+ * INSTALL: Remove all configure files from the git repository
+[Aug 5 2008]
+
+ * MODIFIED: http_read_request/3 throws error on illegal request and http_wrapper/5
+   maps these to internal server errors.
+
+ * MODIFIED: http_open/3 now raises an error if the URL is not well-formed
+   (used to fail silently).
+
+[Jul 31 2008]
+
+ * FIXED: handling setting http:chunked_transfer(never).  Yves Raimond.
+[Jul 3 2008]
+
+ * MODIFIED: Deleted the `after' option processing.  Modern code can start a
+   thread to deal with formulating a reply and start procesing after the reply
+   has been sent.
+
+[Jul 2 2008]
+
+ * ADDED: Support for HTTP 503 (service unavailable)
+
+ * ADDED: Support for options chunked and spawn in http_handler/3.
+
+[Jun 27 2008]
+
+ * FIXED: Read JSON reply when using chunked encoding
+
+ * FIXED: Post header when using data in CGI format (used by JSON posts)
+
+[Jun 25 2008]
+
+ * MODIFIED: http_get/3 using to(atom) or to(codes) perform UTF-8 decoding if
+   the content type is declared as UTF-8.
+
+[Jul 2 2008]
+
+ * ADDED: Bug#365: timeout support for the HTTP client library.  Keri Harris.
+[Jun 16 2008]
+
+ * ENHANCED: Reduce HTTP header parsing time
+
+ * ENHANCED: Reduce overhead of deleting dead HTTP sessions
+
+[May 21 2008]
+
+ * FIXED: atom_json_term(-,+,+): typo.  Torbjörn Lager
+
+[Apr 28 2008]
+
+ * ENHANCED: Perform a GC at the end of a communication with a client.  Note that
+   at that moment we have little active memory (=cheap GC), while otherwise we may
+   remain idle for a long time with large stacks.
+[Apr 2 2008]
+
+ * FIXED: Throw an exception in illegal input wo json_write/3.
+
+[Apr 1 2008]
+
+ * FIXED: Close the server socket in http_stop_server/2.  John Stewart.
+
+[Mar 28 2008]
+
+ * MODIFIED: html//1 interpretation of Module:Term.  Previously this acted as
+   \(Module:Term), now it acts as Module:html(Term), interpreting an entire
+   specification relative to a module.
+
+[Mar 20 2008]
+
+ * FIXED: Make HTTP status messages work when using the xhtml dialect
+
+[Mar 10 2008]
+
+ * FIXED: HTTP accept loop to deal properly with termination
+
+[Mar 9 2008]
+
+ * FIXED: Various issues around JSON booleans and null.   Michiel Hildebrand.
+
+[Feb 26 2008]
+
+ * FIXED: Avoid error on destroyed message queue in http_stop_server/3.
+   Ferreira Maurizio.
+[Feb 8 2008]
+
+ * ADDED: Hook to expand HTML head material.
+
+[Feb 7 2008]
+
+ * ADDED: html_receive//2 to allow for post-processing of posted messages
+
+ * MODIFIED: http_post//2 now executes embedded commands delayed.
+
+[Feb 1 2008]
+
+ * FIXED: html_write.pl: avoid multiple receivers for xmlns.
+
+[Jan 23 2008]
+
+ * PORT: Bug#346: Allow overriding COFLAGS and CWFLAGS in package
+   configuration.   Keri Harris.
+
+[Jan 22 2008]
+
+ * DOC: Applied various patches.  Item#272, Ulrich Neumerkel.
+
+[Dec 22 2007]
+
+ * FIXED: Write JSON newlines always as \n.  Also write all control characters
+   that have no defined escape (< ' ') as \uXXXX.  Michiel Hildebrand.
+
+ * FIXED: json_read/2 for strings holding double-quotes.
+
+[Dec 18 2007]
+
+ * WORKAROUND: Emit no DOCTYPE header of the doctype is set to ''.  This avoids
+   a bug in Microsoft IE AJAX processing.
+
+[Dec 16 2007]
+
+ * FIXED: recursive handling of lists in prolog_to_json/2.  Michiel Hildebrand
+
+[Dec 15 2007]
+
+ * FIXED: is_json_term/2 for pairs.  Michiel Hildebrand.
+
+[Dec 13 2007]
+
+ * ADDED: A predefined `head' receiver for http_post//2 and a predefined `xmlns'
+   receiver used by xhtml_ns//2 to define XML namespaces in xhml mode.  Clarified
+   documentation of the html_write library with examples on how to deal with HTML
+   head material.
+
+[Dec 11 2007]
+
+ * DOC: various enhancement to the presentation of pldoc @keywords
+
+[Dec 7 2007]
+
+ * MODIFIED: renamed library(http/http_chunked) to library(http/http_stream).
+   Added range-limited streams
+
+[Dec 5 2007]
+
+ * ADDED: library(http/http_json.pl), integrating JSON support into the
+   HTTP libraries.
+
+[Dec 4 2007]
+
+ * ADDED: library(http/json), providing (still incomplete) JSON support
+
+[Nov 16 2007]
+
+ * ENHANCED: Bug#323: no longer force bgcolor=white in pagebody//1. Chris Sutton.
+
+[Nov 9 2007]
+
+ * ADDED: type between(Low, High) for numerical values
+
+[Nov 6 2007]
+
+ * ADDED: post/receive mechanism to modularize CSS and Javascript support in
+   library(html_write).  Documented using PlDoc LaTeX backend
+
+Oct 1, 2007
+
+ * ADDED: http_stop_server/2 to stop a running HTTP server.
+
+Sep 26, 2007
+
+ * ADDED: http_set_authorization/2 in library(http/http_open) to provide
+   authorization defauls.
+
+ * ADDED: authorization(basic(User, Passowrd)) to the options of http_open/3.
+   Now generates a permission error for common applicable 4xx errors.
+
+Jun 21, 2007
+
+ * Avoid leaking stream handle in http_get/3 on chunked encoding.
+
+Jun 20, 2007
+
+ * ENHANCED: Support chunked encoding in http_get/3 and http_post/4 on the
+   new http_chunked library, reducing memory usage and overhead.
+
+Jun 19, 2007
+
+ * ADDED: Support chunked encoding through library(http/http_open) based on
+   new http_chunked library.
+
+Jun 16, 2007
+
+ * ADDED: library(http/http_chunked).
+
+Jun 7, 2007
+
+ * ADDED: http_dispatch and http_authenticate libraries.
+
+Jun 1, 2007
+
+ * FIXED: Use new predicate_indicator frame attribute for safe error
+   handling.
+
+May 23, 2007
+
+ * FIXED: Preserve extra request-headers over redirect.  Yves Raimond.
+
+May 20, 2007
+
+ * FIXED: redirection issues.  Yves Raimond.
+
+Apr 12, 2007
+
+  * ADDED: .svg to mimetypes
+
+Apr 10, 2007
+
+  * FIXED: Forcing UTF-8 character set.
+
+Mar 22, 2007
+
+  * FIXED: Bug#269: time-stamp was emitted in current locale.
+
+Mar 19, 2007
+
+  * ADDED: Include name of parameter in type-errors detected by
+    http_parameters/2.
+
+Mar 15, 2007
+
+  * ADDED: Include peer in session management for better security.
+  * ADDED: Broadcast session start/end to allow deletion of derived
+    data.
+
+Mar 11, 2007
+
+  * FIXED: http_open/3: send Host: <host>:<port> if port is not 80.
+
+Mar 9, 2007
+
+  * ADDED: reply_html_page/2.  To be documented
+
+  * ADDED: Pass protocol(http/https) into request.
+
+Mar 7, 2007
+
+  * FIXED: handle throw(http_reply(moved_temporary(URL))) properly.
+
+Mar 6, 2007
+
+  * ADDED: final_url option to http_open/3
+
+Mar 5, 2007
+
+  * MODIFIED: debug(header, ...) --> debug(http(header), ...)
+
+  * ADDED: codes([Type], Codes) to http_post_data.
+
+Feb 26, 2007
+
+  * ADDED: Keep connections open on not_modified and replying files.
+
+Feb 9, 2007
+
+  * ADDED: Support for 302 (moved temporary) HTTP replies to the server.
+
+Feb 8, 2007
+
+  * ADDED: Map existence_error(http_location, URL) and
+    permission_error(http_location, access, URL) to appropriate HTTP
+    headers.
+
+Feb 2, 2007
+
+  * ADDED: Report status of stopped worker.
+
+Jan 24, 2007
+
+  * ADDED: Support for 303 (see other) HTTP replies to the server.
+    Yves Raimond.
+
+Jan 18, 2007
+
+  * ADDED: html_set_options/1 and html_current_option/1 to html_write.pl.
+    Allows for changing the document type as well as writing XHTML output
+    from the same DCG rules.
+
+Jan 15, 2007
+
+  * ADDED: Redirect support for 301 and 303.  Yves Raimond.
+
+Dec 13, 2006
+
+  * FIXED: avoid passing reply_header option to convert hooks (conflict
+    with SGML plugin).
+
+Dec 12, 2006
+
+  * FIXED: Properly close sockets on errors in http_open/3.
+
+Dec 8, 2006
+
+  * ADDED: support for HEAD to http_open/3.
+
+Oct 31, 2006
+
+  * ENHANCED: Documentation
+
+Oct 30, 2006
+
+  * ADDED: Allow for A+B in attribute values.
+
+Sep 18, 2006
+
+  * FIXED: inetd_httpd: set stream encoding to octet to be able to handle
+    binary data.  Nicos Angelopoulos.
+
+Aug 21, 2006
+
+  * FIXED: Quote & inside attribute values.
+
+Aug 10, 2006
+
+  * ENHANCED: Time printing in http_header.pl to use format_time/3.  Faster
+    and proper implementation of daylight saving time.
+
+Aug 8, 2006
+
+  * FIXED: http_relative_path/2.
+
+Aug 7, 2006
+
+  * DEBUG: Do not generate debug info for library html_write.pl, as it makes
+    code using the library very hard to debug.
+
+Jun 30, 2006
+
+  * FIXED: dangling choicepoint in http_open/3.
+
+  * ADDED: zero_or_more as parameter option to http_parameters/[2,3]
+
+Apr 11, 2006
+
+  * ADDED: http_parameters library
+
+  * FIXED: properly handle the server closing the connection if the connection
+    is specified as Keep-alive in the client (http_get/3 and http_post/4).
+
+Feb 24, 2006
+
+  * Added http_error.pl to generate nice looking stack-traces.
+
+Feb 23, 2006
+
+  * Added http_session.pl and http:request_expansion/2 hook.
+
+Feb 16, 2006
+
+  * Added http_current_request/1 to get access to the currently executing
+    request.
+
+Feb 10, 2006
+
+  * Make http_post deal with Unicode data.
+
+Jan 20, 2006
+
+  * Map Host:  <host>:<port> into host(Host), port(Port) when reading
+    HTTP requests.
+
+Jan 16, 2006
+
+  * Fixed redirect handling if the option to(Stream) is given.
+    Jacco van Ossenbruggen.
+
+Jan 11, 2006
+
+  * Added: handling of 302 redirect messages in http_get/3.
+  * Fix http_get/3 with sgml plugin and proxy option.  Usenet, `mans'.
+
+Dec 10, 2005
+
+  * Enhanced robustness of the server to malicious clients by using
+    call_cleanup wrappers around the code doing the actual reply.  Old
+    code lead to memory and file-descriptor leaking.
+
+Dec 7, 2005
+
+  * Added http_timestamp/2  to http_header.pl.  Also changed the time
+    representation to be compatible to the current RFC1132 standard.
+
+Nov 16, 2005
+
+  * Avoid XPCE http servers to be garbage collected.
+
+Oct 17, 2005
+
+  * ADDED: Pass peer from threaded HTTP server to request.
+
+  * ENHANCED: Use UTF-8 encoding for text by default.
+
+Sep 28, 2005
+
+  * FIXED: Regular expressions in xpce_httpd frontend.  Wouter Jansweijer.
+
+Sep 23, 2005
+
+  * ADDED: .class to mimetypes.pl.
+
+Sep 7, 2005
+
+  * FIXED: handle connection error in http_get/3 gracefully.
+
+Sep 6, 2005
+
+  * FIXED: handle error in tcp_accept/3 gracefully.
+
+Sep 5, 2005
+
+  * ADDED: method(head) --> "HEAD".  Matt Lilley.
+
+Apr 26, 2005
+
+  * ADDED: debug(sgml_plugin) and some missing use_module calls.  Simplifies
+    debugging automatic conversion.
+
+Mar 4, 2005
+
+  * FIXED: Bug#24: open files binary.   Fabien Todescato.
+
+Feb 11, 2005
+
+  * FIXED: empy header field eats next line as value.  Chris Ritchey.
+
+Jan 4, 2005
+
+  * FIXED: Bug#2: Disconnect from POST replies.
+
+Sep 23, 2004
+
+  * FIXED: Ignore minor types when deciding which plugin to use for the
+    SGML plugin.
+
+Aug 30, 2004
+
+  * FIXED: Bug#179: Avoid XPCE dependency on strip_module/3.  Sandro Hawke.
+
+Aug 16, 2004
+
+  * FIXED: Remove " from boundary=... HTTP-POST requests.  Appears necessary
+    for posting to Tomcat servers.  Also added explicit MIME-Version: 1.0
+    to the header.
+
+Aug 12, 2004
+
+  * ADDED: form_data(+List) alternative to http_post/4.
+
+  * ADDED: option reply_header(-Header) to get the full replied header for
+    GET and POST methods.  Also added decoding of the SetCookie field.
+
+Aug 5, 2004
+
+  * ADDED: request_header(Name=Value) to http_open/3
+
+Aug 3, 2004
+
+  * ADDED: keep_alive_timeout(Seconds) for multi-threaded server.
+
+  * FIXED: remove choicepoints in http_open/3
+
+Jul 31, 2004
+
+  * ADDED: http_current_worker/2
+
+Jul 30, 2004
+
+  * ADDED: Allow explicit head and body in page//1 and page//2
+
+Jul 21, 2004
+
+  * FIXED: Bug#166: Allow alternative responses (Sandro Hawke).
+
+  * FIXED: Bug#168: Close connection on timeout (Sandro Hawke).
+
+  * FIXED: Bug#165: Added reuseaddr (Sandro Hawke).
+
+Jul 18, 2004
+
+  * ENHANCED: handle `normal' errors silent (David Reitter)
+
+Jun 28, 2004
+
+  * ENHANCED: print server errors and continue
+
+  * ADDED: SSL interface to threaded HTTP server
+
+Jun 21, 2004
+
+  * FIXED: Handling continue header required for POST to MS IIS servers.
+    Also more patches sending \r\n where required.  With patches from
+    Mike Elston.
+
+Jun 16, 2004
+
+  * FIXED: make HTTP client library write header line terminate with
+    \r\n.  Mike Elston.
+
+Jun 15, 2004
+
+  * FIXED: Undefined predicate strip_module/2 in thread_httpd.pl when
+    there is no access to XPCE.  Dmitry.
+
+  * ADDED: request_header(Name=Value) option to the option list of
+    http_get/3 and http_post/4 for adding user request fields.
+
+  * ADDED: Map body throw(status(not_modified)) onto a "304 Not Modified"
+    page.  Mike Elston.
+
+May 20, 2003
+
+  * DOCS: Documented http_post_data/3
+
+  * ADDED: form([Name=Value, ...]) input type to http_post_data/3
+
+May 12, 2003
+
+  * FIXED: problem in mime_pack/3 using Name=Value
+
+Mar 4, 2003
+
+  * ADDED: http_open/3: header(+Name, -Value) option.  Wouter
+    Jansweijer.
+
+Jan 23, 2003
+
+  * ADDED: Provide User-Agent header for the client libraries
+
+Jan 8, 2003
+
+  * ADDED: Support for using proxy servers Option: proxy(Host, Port).
+
+  * ADDED: Support for 302 (document moved) reply in http_open/3.
+

packages/http/Makefile.in

@@ -0,0 +1,223 @@
+################################################################
+# SWI-Prolog `HTTP' package
+# Author:    Jan Wielemaker. J.Wielemaker@cs.vu.nl
+# Copyright: GPL (see COPYING or www.gnu.org
+################################################################
+
+.SUFFIXES: .txt .tex .dvi .doc .pl
+
+ifeq (@PROLOG_SYSTEM@,yap)
+
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+ROOTDIR = $(prefix)
+EROOTDIR = @exec_prefix@
+abs_top_builddir = @abs_top_builddir@
+
+srcdir=@srcdir@
+
+BINDIR = $(EROOTDIR)/bin
+LIBDIR=@libdir@
+YAPLIBDIR=@libdir@/Yap
+SHAREDIR=$(ROOTDIR)/share/Yap
+
+SHELL=@SHELL@
+PL=@INSTALL_ENV@ $(DESTDIR)$(BINDIR)/yap $(DESTDIR)$(YAPLIBDIR)/startup.yss
+EXDIR=$(YAPLIBDIR)/examples/http
+LN_S=@LN_S@
+#
+#
+CC=@CC@
+CFLAGS= @SHLIB_CFLAGS@ $(YAP_EXTRAS) $(DEFS) -D_YAP_NOT_INSTALLED_=1 -I$(srcdir) -I../.. -I$(srcdir)/../../include @CPPFLAGS@
+MKINDEX=true
+
+
+SO=@SO@
+#4.1VPATH=@srcdir@:@srcdir@/OPTYap
+CWD=$(PWD)
+#
+
+LD=@DO_SECOND_LD@	@SHLIB_CXX_LD@
+LDFLAGS=@EXTRA_LIBS_FOR_SWIDLLS@
+
+BINTARGET=$(DESTDIR)$(YAPLIBDIR)
+PLTARGET=$(DESTDIR)$(SHAREDIR)/http
+
+FINAL_BINTARGET=$(YAPLIBDIR)
+FINAL_PLTARGET=$(SHAREDIR)
+
+%.o: $(srcdir)/%.c
+		$(CC) -c $(CFLAGS) $< -o $@
+
+else	# SWI
+
+SHELL=@SHELL@
+PLBASE=@PLBASE@
+PLARCH=@PLARCH@
+PL=@PL@
+XPCEBASE=$(PLBASE)/xpce
+PKGDOC=$(PLBASE)/doc/packages
+PCEHOME=../xpce
+LIBDIR=$(PLBASE)/library/http
+EXDIR=$(PKGDOC)/examples/http
+
+CC=@CC@
+COFLAGS=@COFLAGS@
+CWFLAGS=@CWFLAGS@
+CMFLAGS=@CMFLAGS@
+CIFLAGS=
+CFLAGS=$(COFLAGS) $(CWFLAGS) $(CMFLAGS) $(CIFLAGS) @DEFS@
+LIBS=@LIBS@
+LD=@LD@
+LDFLAGS=@LDSOFLAGS@
+
+PUBLICPL=swipl
+DOCTOTEX=$(PCEHOME)/bin/doc2tex
+PLTOTEX=$(PUBLICPL) -q -s pltotex.pl -g pltotex --
+RUNTEX=../../man/runtex
+LATEX=latex
+DOC=http
+TEX=$(DOC).tex
+DVI=$(DOC).dvi
+PDF=$(DOC).pdf
+HTML=$(DOC).html
+
+endif
+
+INSTALL=@INSTALL@
+INSTALL_PROGRAM=@INSTALL_PROGRAM@
+INSTALL_DATA=@INSTALL_DATA@
+
+include $(srcdir)/common.mk
+
+STREAMOBJ=	http_stream.o
+JSONOBJ=	json.o
+SOLIBS=		http_stream.@SO@ json.@SO@
+
+all:		$(SOLIBS)
+
+
+http_stream.@SO@:	$(STREAMOBJ)
+		$(LD) $(LDFLAGS) -o $@ $(STREAMOBJ) $(LIBS)
+json.@SO@:	$(JSONOBJ)
+		$(LD) $(LDFLAGS) -o $@ $(JSONOBJ) $(LIBS)
+
+http_stream.o:	$(srcdir)/http_error.c $(srcdir)/http_chunked.c $(srcdir)/cgi_stream.c $(srcdir)/stream_range.c
+
+install:	$(LIBPL)
+		mkdir -p $(BINTARGET)
+		rm -f $(BINTARGET)/http_chunked.@SO@
+		$(INSTALL_PROGRAM) $(SOLIBS) $(BINTARGET)
+		mkdir -p $(PLTARGET)
+		mkdir -p $(PLTARGET)/web/icons
+		mkdir -p $(LIBDIR)/web/css
+		$(INSTALL_DATA) $(LIBPL) $(PLTARGET)
+		$(INSTALL_DATA) $(srcdir)/README $(PLTARGET)
+		$(INSTALL_DATA) $(srcdir)/web/icons/*.png $(PLTARGET)/web/icons
+		$(INSTALL_DATA) $(srcdir)/web/css/*.css $(DESTDIR)$(LIBDIR)/web/css
+		$(PL) -f none -g make -t halt
+
+ln-install:	$(LIBPL)
+		$(MAKE) INSTALL_DATA="../ln-install" INSTALL_PROGRAM="../ln-install" install
+
+rpm-install:	install
+
+pdf-install:	install-examples
+		$(INSTALL_DATA) $(DOC).pdf $(DESTDIR)$(PKGDOC)
+
+html-install:	install-examples
+		$(INSTALL_DATA) $(DOC).html httpserver.gif $(DESTDIR)$(PKGDOC)
+
+install-examples::
+		mkdir -p $(DESTDIR)$(EXDIR)
+		mkdir -p $(DESTDIR)$(EXDIR)/pwp
+		(cd examples && $(INSTALL_DATA) $(EXAMPLES) $(DESTDIR)$(EXDIR))
+		(cd examples/pwp && $(INSTALL_DATA) *.pwp *.pl $(DESTDIR)$(EXDIR)/pwp)
+		(cd examples && $(INSTALL_PROGRAM) $(EXAMPLEEXE) $(DESTDIR)$(EXDIR))
+
+uninstall::
+		(cd $(LIBDIR) && rm -f $(LIBPL))
+		$(PL) -f none -g make -t halt
+
+check::
+		$(PL) -q -f $(srcdir)/test_http.pl -g test_http,halt -t 'halt(1)'
+		$(PL) -q -f $(srcdir)/test_json.pl -g test_json,halt -t 'halt(1)'
+		$(PL) -q -f $(srcdir)/test_cgi_stream.pl -g true -t test_cgi_stream
+
+################################################################
+# Documentation
+################################################################
+
+doc:		$(PDF) $(HTML)
+pdf:		$(PDF)
+html:		$(HTML)
+
+SUBTEX=		post.tex json.tex httplog.tex httppath.tex htmlhead.tex \
+		httpsession.tex httpdispatch.tex httpdirindex.tex httppwp.tex \
+		httpopen.tex httphost.tex httpopenid.tex jswrite.tex
+
+$(HTML):	$(TEX) $(SUBTEX)
+		latex2html $(DOC)
+		mv html/index.html $@
+		mv html/httpserver.gif .
+		rmdir html
+
+$(PDF):		$(TEX) $(SUBTEX)
+		$(RUNTEX) --pdf $(DOC)
+
+$(TEX):		$(DOCTOTEX)
+
+json.tex:	json.pl json_convert.pl http_json.pl
+
+.txt.tex:
+		$(PUBLICPL) -q -s txttotex.pl -g txttotex,halt -t 'halt(1)' -- $*.txt
+
+httplog.tex:	http_log.pl
+		$(PLTOTEX) --subsection 'library(http/http_log)'
+
+httphost.tex:	http_host.pl
+		$(PLTOTEX) --subsection 'library(http/http_host)'
+
+httppath.tex:	http_path.pl
+		$(PLTOTEX) --subsection 'library(http/http_path)'
+
+httpopen.tex:	http_open.pl
+		$(PLTOTEX) --subsection 'library(http/http_open)'
+
+htmlhead.tex:	html_head.pl
+		$(PLTOTEX) --subsection 'library(http/html_head)'
+
+httpsession.tex: http_session.pl
+		$(PLTOTEX) --subsection 'library(http/http_session)'
+
+httpdispatch.tex: http_dispatch.pl
+		$(PLTOTEX) --subsection 'library(http/http_dispatch)'
+
+httpopenid.tex:	http_openid.pl
+		$(PLTOTEX) --subsection 'library(http/http_openid)'
+
+httpdirindex.tex: http_dirindex.pl
+		$(PLTOTEX) --subsection 'library(http/http_dirindex)'
+
+httppwp.tex:	http_pwp.pl
+		$(PLTOTEX) --subsection 'library(http/http_pwp)'
+
+jswrite.tex:	js_write.pl
+		$(PLTOTEX) --subsection 'library(http/js_write)'
+
+.doc.tex:
+		$(DOCTOTEX) $*.doc > $*.tex
+
+################################################################
+# Clean
+################################################################
+
+clean:
+		rm -f $(STREAMOBJ) $(JSONOBJ)
+		rm -f *~ *% config.log
+		rm -f $(TEX) $(SUBTEX)
+		$(RUNTEX) --clean $(DOC)
+		rm -rf html
+
+distclean:	clean
+		rm -f $(SOLIBS) config.cache config.status config.h Makefile

packages/http/Makefile.mak

@@ -0,0 +1,82 @@
+################################################################
+# Install the SWI-Prolog HTTP package for MS-Windows
+#
+# Author: Jan Wielemaker
+#
+# Use:
+#	nmake /f Makefile.mak
+#	nmake /f Makefile.mak install
+################################################################
+
+PLHOME=..\..
+!include $(PLHOME)\src\rules.mk
+!include common.mk
+
+LIBDIR=		$(PLBASE)\library\http
+EXDIR=		$(PKGDOC)\examples\http
+
+OBJ=		http_stream.obj
+
+all:		http_stream.dll json.dll
+
+http_stream.dll:	$(OBJ)
+		$(LD) /dll /out:$@ $(LDFLAGS) $(OBJ) $(PLLIB) $(LIBS)
+json.dll:	json.obj
+		$(LD) /dll /out:$@ $(LDFLAGS) json.obj $(PLLIB) $(LIBS)
+
+http_stream.obj:	http_error.c http_chunked.c cgi_stream.c stream_range.c
+
+all:
+
+!IF "$(CFG)" == "rt"
+install::
+!ELSE
+install::
+		if not exist "$(LIBDIR)\$(NULL)" $(MKDIR) "$(LIBDIR)"
+		if not exist "$(LIBDIR)\web\$(NULL)" $(MKDIR) "$(LIBDIR)\web"
+		if not exist "$(LIBDIR)\web\icons\$(NULL)" $(MKDIR) "$(LIBDIR)\web\icons"
+		if not exist "$(LIBDIR)\web\css\$(NULL)" $(MKDIR) "$(LIBDIR)\web\css"
+		@echo Copying $(LIBPL)
+		@for %f in ($(LIBPL)) do @copy %f "$(LIBDIR)"
+		copy README "$(LIBDIR)\README.TXT"
+		copy web\icons\*.* "$(LIBDIR)\web\icons"
+		copy web\css\*.* "$(LIBDIR)\web\css"
+		copy http_stream.dll "$(BINDIR)"
+		copy json.dll "$(BINDIR)"
+!IF "$(PDB)" == "true"
+		copy http_stream.pdb "$(BINDIR)"
+		copy json.pdb "$(BINDIR)"
+!ENDIF
+		$(MAKEINDEX)
+!ENDIF
+
+html-install:	install-examples
+		copy http.html "$(PKGDOC)"
+		copy httpserver.gif "$(PKGDOC)"
+
+pdf-install:	install-examples
+		copy http.pdf "$(PKGDOC)"
+
+install-examples::
+		if not exist "$(EXDIR)\$(NULL)" $(MKDIR) "$(EXDIR)"
+		if not exist "$(EXDIR)\pwp\$(NULL)" $(MKDIR) "$(EXDIR)\pwp"
+		cd examples & @for %f in ($(EXAMPLES)) do @copy %f "$(EXDIR)"
+		cd examples & copy $(EXAMPLEEXE) "$(EXDIR)"
+		cd examples & copy pwp\*.* "$(EXDIR)\pwp"
+
+xpce-install::
+
+uninstall::
+		cd $(LIBDIR) & del $(LIBPL) README.TXT
+		del "$(BINDIR)\http_stream.dll"
+		$(MAKEINDEX)
+
+clean::
+		if exist *~ del *~
+		if exist *.obj del *.obj
+
+distclean:	clean
+		if exist *.dll del *.dll
+		if exist *.pdb del *.pdb
+
+

packages/http/README

@@ -0,0 +1,18 @@
+---+ SWI-Prolog HTTP support library
+
+This directory provides  the  SWI-Prolog   libraries  for  accessing and
+providing HTTP services.  The client libraries come in two forms:
+
+    * The lightweight http_open.pl opens an HTTP location as a stream
+    * The more full-blown http_client.pl performs arbitrary HTTP
+    requests and, depending on loaded plugins, transforms the data
+    in a Prolog-friendly format.
+
+The primary server-library  is   thread_httpd.pl,  providing  full-blown
+scalable embedded HTTP server.
+
+---++ Further reading
+
+    * ../../packages/http.pdf
+    * ../../packages/examples/http contains some demos.
+    * http://www.swi-prolog.org/packages/http.html

packages/http/TODO

@@ -0,0 +1,25 @@
+---+ HTTP Server library todo list
+
+---++ Session handling
+
+Especially now that we store the current request  as a record in the CGI
+stream, it is now much too expensive to get the current session.  How to
+deal with that?	 Also store in the CGI object?
+
+---++ Debugging
+
+We plan to provide a in-core  store   for  requests with predicates that
+control what requests are stored. This   allows for showing the requests
+as well as replaying requests from the user-thread for easy debugging.
+
+Can we deal with HTTP POST requests?
+
+---++ JSON integration
+
+JavaScript Simple Object Notation is a   simple and lightweight exchange
+protocol for structured data. Support for   it  is progressing, with the
+following items on our todo list.
+
+	* Hook json_convert.pl into json.pl
+	* Deal with nested objects in conversion
+	* Documentation.

packages/http/cgi_stream.c

@@ -0,0 +1,745 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2009, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*/
+
+#include <SWI-Stream.h>
+#include <SWI-Prolog.h>
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+The task of cgi_stream.c is to interface between the actual wrapper code
+that implements an HTTP location and the   socket sending a reply to the
+client.  In particular, we want to deal with:
+
+    * Separating the header from the body of the reply
+    * Chunked or traditional transfer encoding
+    * Connection management (Keep-alife)
+    * Thread management
+
+The original HTTP infrastructure has an `accept thread' that accepts new
+connections. The connection is handed to a   thread  that reads the HTTP
+header and calls a handler with the  output redirected to a memory file,
+processing the reply-header and reply-data   after the handler finished.
+This is a clean and modular design,   but it cannot deal with especially
+chunked encoding and  thread  management.   This  module  remedies these
+issues.
+
+To do this, the  stream  provides   a  three  call-backs. Initially, the
+stream is in line-buffering mode (SIO_LBUF),   waiting for the header to
+become complete. At that moment it calls   the  hook, passing event type
+'header' and the stream. This processes the   head and combines the head
+with the request, deciding on:
+
+    * The final header
+    * The transfer encoding (chunked/none)
+    * The content encoding (octet/utf8)
+    * The connection (Keep-Alife/close)
+
+Now, the stream is placed in  full   buffering  mode  (SIO_FBUF). If the
+transfer encoding is 'chunked'  it  immediately   calls  the  hook using
+'send_header' to emit the current header.   Output continues. In chunked
+mode sending the chunks, otherwisse collecting   the  data. On close, it
+writes an empty block (chunked mode)  or   (normal  mode) calls the hook
+'send_header' which now has access to   the  content-length, followed by
+the data.
+
+Note that the work-flow is kept with the stream. This allows passing the
+cgi stream from thread to thread while keeping track of the work-flow.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+TODO
+
+	* Error handling (many places)
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+		 /*******************************
+		 *	      CONSTANTS		*
+		 *******************************/
+
+static atom_t ATOM_header;		/* header */
+static atom_t ATOM_header_codes;	/* header_codes */
+static atom_t ATOM_send_header;		/* send_header */
+static atom_t ATOM_data;		/* data */
+static atom_t ATOM_discarded;		/* discarded */
+static atom_t ATOM_request;		/* request */
+static atom_t ATOM_client;		/* client */
+static atom_t ATOM_chunked;		/* chunked */
+static atom_t ATOM_none;		/* none */
+static atom_t ATOM_state;		/* state */
+static atom_t ATOM_transfer_encoding;	/* transfer_encoding */
+static atom_t ATOM_connection;		/* connection */
+static atom_t ATOM_keep_alife;		/* keep_alife */
+static atom_t ATOM_close;		/* close */
+static atom_t ATOM_content_length;	/* content_length */
+static atom_t ATOM_id;			/* id */
+static predicate_t PREDICATE_call3;	/* Goal, Event, Handle */
+
+
+		 /*******************************
+		 *	      CONTEXT		*
+		 *******************************/
+
+#define BUFSIZE SIO_BUFSIZE		/* raw I/O buffer */
+
+typedef enum
+{ CGI_HDR  = 0,
+  CGI_DATA,
+  CGI_DISCARDED
+} cgi_state;
+
+#define CGI_MAGIC 0xa85ce042
+
+typedef struct cgi_context
+{ IOSTREAM	   *stream;		/* Original stream */
+  IOSTREAM	   *cgi_stream;		/* Stream I'm handle of */
+  IOENC		    parent_encoding;	/* Saved encoding of parent */
+					/* Prolog attributes */
+  module_t	    module;		/* Calling module */
+  record_t	    hook;		/* Hook called on action */
+  record_t	    request;		/* Associated request term */
+  record_t	    header;		/* Associated reply header term */
+  atom_t	    transfer_encoding;	/* Current transfer encoding */
+  atom_t	    connection;		/* Keep alife? */
+					/* state */
+  cgi_state	    state;		/* Current state */
+					/* data buffering */
+  size_t	    data_offset;	/* Start of real data */
+  char		   *data;		/* Buffered data */
+  size_t	    datasize;		/* #bytes buffered */
+  size_t	    dataallocated;	/* #bytes allocated */
+  int		    id;			/* Identifier */
+  unsigned int	    magic;		/* CGI_MAGIC */
+} cgi_context;
+
+
+static int start_chunked_encoding(cgi_context *ctx);
+static ssize_t cgi_chunked_write(cgi_context *ctx, char *buf, size_t size);
+
+
+		 /*******************************
+		 *	     ALLOC/FREE		*
+		 *******************************/
+
+static cgi_context*
+alloc_cgi_context(IOSTREAM *s)
+{ cgi_context *ctx = PL_malloc(sizeof(*ctx));
+
+  memset(ctx, 0, sizeof(*ctx));
+  ctx->magic  = CGI_MAGIC;
+  ctx->stream = s;
+
+  return ctx;
+}
+
+
+static void
+free_cgi_context(cgi_context *ctx)
+{ if ( ctx->stream->upstream )
+    Sset_filter(ctx->stream, NULL);
+  else
+    PL_release_stream(ctx->stream);
+
+  if ( ctx->data )       free(ctx->data);
+  if ( ctx->hook )       PL_erase(ctx->hook);
+  if ( ctx->request )    PL_erase(ctx->request);
+  if ( ctx->header )     PL_erase(ctx->header);
+  if ( ctx->connection ) PL_unregister_atom(ctx->connection);
+
+  ctx->magic = 0;
+  PL_free(ctx);
+}
+
+
+static int
+grow_data_buffer(cgi_context *ctx, size_t size)
+{ size_t newsize;
+
+  if ( ctx->dataallocated == 0 )
+    newsize = SIO_BUFSIZE;
+  else
+    newsize = ctx->dataallocated;
+
+  while(newsize < size)
+    newsize *= 2;
+  if ( ctx->data )
+  { void *p;
+
+    if ( !(p=realloc(ctx->data, newsize)) )
+      return -1;
+    ctx->data = p;
+    ctx->dataallocated = newsize;
+  } else
+  { if ( !(ctx->data = malloc(newsize)) )
+      return -1;
+
+    ctx->dataallocated = newsize;
+  }
+
+  return 0;
+}
+
+
+		 /*******************************
+		 *	     PROPERTIES		*
+		 *******************************/
+
+static IOFUNCTIONS cgi_functions;
+
+static int
+get_cgi_stream(term_t t, IOSTREAM **sp, cgi_context **ctx)
+{ IOSTREAM *s;
+
+  if ( !PL_get_stream_handle(t, &s) )
+    return FALSE;
+  if ( s->functions != &cgi_functions )
+  { PL_release_stream(s);
+    return type_error(t, "cgi_stream");
+  }
+
+  *sp = s;
+  *ctx = s->handle;
+
+  return TRUE;
+}
+
+
+static int
+unify_record(term_t t, record_t r)
+{ if ( r )
+  { term_t t2 = PL_new_term_ref();
+    PL_recorded(r, t2);
+    return PL_unify(t, t2);
+  }
+  return FALSE;
+}
+
+
+static foreign_t
+is_cgi_stream(term_t cgi)
+{ IOSTREAM *s;
+  int rc;
+
+  if ( !PL_get_stream_handle(cgi, &s) )
+    return FALSE;
+  rc = (s->functions == &cgi_functions);
+  PL_release_stream(s);
+
+  return rc;
+}
+
+
+static foreign_t
+cgi_property(term_t cgi, term_t prop)
+{ IOSTREAM *s;
+  cgi_context *ctx;
+  term_t arg = PL_new_term_ref();
+  atom_t name;
+  int arity;
+  int rc = TRUE;
+
+  if ( !get_cgi_stream(cgi, &s, &ctx) )
+    return FALSE;
+
+  if ( !PL_get_name_arity(prop, &name, &arity) || arity != 1 )
+  { rc = type_error(prop, "cgi_property");
+    goto out;
+  }
+
+  _PL_get_arg(1, prop, arg);
+  if ( name == ATOM_request )
+  { if ( ctx->request )
+      rc = unify_record(arg, ctx->request);
+    else
+      rc = PL_unify_nil(arg);
+  } else if ( name == ATOM_header )
+  { if ( ctx->header )
+      rc = unify_record(arg, ctx->header);
+     else
+      rc = PL_unify_nil(arg);
+  } else if ( name == ATOM_id )
+  { rc = PL_unify_integer(arg, ctx->id);
+  } else if ( name == ATOM_client )
+  { rc = PL_unify_stream(arg, ctx->stream);
+  } else if ( name == ATOM_transfer_encoding )
+  { rc = PL_unify_atom(arg, ctx->transfer_encoding);
+  } else if ( name == ATOM_connection )
+  { rc = PL_unify_atom(arg, ctx->connection ? ctx->connection : ATOM_close);
+  } else if ( name == ATOM_content_length )
+  { rc = PL_unify_int64(arg, ctx->datasize - ctx->data_offset);
+  } else if ( name == ATOM_header_codes )
+  { if ( ctx->data_offset > 0 )
+      rc = PL_unify_chars(arg, PL_CODE_LIST, ctx->data_offset, ctx->data);
+    else
+      rc = existence_error(cgi, "header");
+  } else if ( name == ATOM_state )
+  { atom_t state;
+
+    switch(ctx->state)
+    { case CGI_HDR:       state = ATOM_header; break;
+      case CGI_DATA:      state = ATOM_data; break;
+      case CGI_DISCARDED: state = ATOM_discarded; break;
+      default:
+	assert(0);
+    }
+
+    rc = PL_unify_atom(arg, state);
+  } else
+  { rc = existence_error(prop, "cgi_property");
+  }
+
+out:
+  PL_release_stream(s);
+  return rc;
+}
+
+
+static int
+set_term(record_t *r, term_t t)
+{ if ( *r )
+    PL_erase(*r);
+  *r = PL_record(t);
+
+  return TRUE;
+}
+
+
+static int
+set_atom(atom_t *a, term_t t)
+{ atom_t new;
+
+  if ( !PL_get_atom(t, &new) )
+    return type_error(t, "atom");
+
+  if ( *a != new )
+  { if ( *a )
+      PL_unregister_atom(*a);
+    *a = new;
+    PL_register_atom(new);
+  }
+
+  return TRUE;
+}
+
+
+static foreign_t
+cgi_set(term_t cgi, term_t prop)
+{ IOSTREAM *s;
+  cgi_context *ctx;
+  term_t arg = PL_new_term_ref();
+  atom_t name;
+  int arity;
+  int rc = TRUE;
+
+  if ( !get_cgi_stream(cgi, &s, &ctx) )
+    return FALSE;
+
+  if ( !PL_get_name_arity(prop, &name, &arity) || arity != 1 )
+  { rc = type_error(prop, "cgi_property");
+    goto out;
+  }
+
+  _PL_get_arg(1, prop, arg);
+  if ( name == ATOM_request )
+  { rc = set_term(&ctx->request, arg);
+  } else if ( name == ATOM_header )
+  { rc = set_term(&ctx->header, arg);
+  } else if ( name == ATOM_connection )
+  { rc = set_atom(&ctx->connection, arg);
+  } else if ( name == ATOM_transfer_encoding )
+  { atom_t enc;
+
+    if ( !PL_get_atom(arg, &enc) )
+      return type_error(arg, "atom");
+
+    if ( ctx->transfer_encoding != enc )
+    { if ( enc == ATOM_chunked )
+      { ctx->transfer_encoding = enc;
+	rc = start_chunked_encoding(ctx);
+      } else
+      { rc = domain_error(arg, "transfer_encoding");
+      }
+    }
+  } else
+  { rc = existence_error(prop, "cgi_property");
+  }
+
+out:
+  PL_release_stream(s);
+  return rc;
+}
+
+
+static foreign_t
+cgi_discard(term_t cgi)
+{ IOSTREAM *s;
+  cgi_context *ctx;
+
+  if ( !get_cgi_stream(cgi, &s, &ctx) )
+    return FALSE;
+
+  ctx->state = CGI_DISCARDED;
+					/* empty buffer to avoid write */
+  ctx->cgi_stream->bufp = ctx->cgi_stream->buffer;
+  PL_release_stream(s);
+
+  return TRUE;
+}
+
+
+		 /*******************************
+		 *	      HOOKS		*
+		 *******************************/
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Call hook on the data we collected sofar.   The  hook is called with the
+following additional arguments:
+
+    * Event-type (header, data)
+    * An input stream pointing to the collected data
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+static int
+call_hook(cgi_context *ctx, atom_t event)
+{ fid_t fid = PL_open_foreign_frame();
+  term_t av = PL_new_term_refs(3);
+  qid_t qid;
+  int rc;
+
+  PL_recorded(ctx->hook, av+0);
+  PL_put_atom(av+1, event);
+  PL_unify_stream(av+2, ctx->cgi_stream);
+  qid = PL_open_query(ctx->module, PL_Q_CATCH_EXCEPTION, PREDICATE_call3, av);
+  rc = PL_next_solution(qid);
+
+  if ( !rc )
+  { term_t ex;
+
+    if ( (ex = PL_exception(qid)) )
+    { Sset_exception(ctx->cgi_stream, ex);
+
+    } else
+    { char buf[256];
+      Ssprintf(buf, "CGI Hook %s failed", PL_atom_chars(event));
+
+      Sseterr(ctx->cgi_stream, SIO_WARN, buf);
+    }
+
+    PL_cut_query(qid);
+    PL_close_foreign_frame(fid);
+
+    return FALSE;
+  }
+  PL_close_query(qid);
+  PL_discard_foreign_frame(fid);
+
+  return TRUE;
+}
+
+
+static int
+start_chunked_encoding(cgi_context *ctx)
+{ if ( call_hook(ctx, ATOM_send_header) )
+  { if ( ctx->datasize > ctx->data_offset )
+    { int rc = cgi_chunked_write(ctx,
+				 &ctx->data[ctx->data_offset],
+				 ctx->datasize - ctx->data_offset);
+      if ( rc == -1 )
+	return FALSE;
+    }
+
+    return TRUE;
+  }
+
+  return FALSE;
+}
+
+
+static size_t
+find_data(cgi_context *ctx, size_t start)
+{ const char *s = &ctx->data[start];
+  const char *e = &ctx->data[ctx->datasize-2];
+
+  for(; s<=e; s++)
+  { if ( s[0] == '\r' && s[1] == '\n' &&
+	 s <= e-2 &&
+	 s[2] == '\r' && s[3] == '\n' )
+      return &s[4] - ctx->data;
+    if ( s[0] == '\n' && s[1] == '\n' )
+      return &s[2] - ctx->data;
+  }
+
+  return (size_t)-1;
+}
+
+
+
+		 /*******************************
+		 *	   IO FUNCTIONS		*
+		 *******************************/
+
+static ssize_t				/* encode */
+cgi_chunked_write(cgi_context *ctx, char *buf, size_t size)
+{ if ( Sfprintf(ctx->stream, "%x\r\n", size) < 0 )
+    return -1;
+  if ( size > 0 &&
+       Sfwrite(buf, sizeof(char), size, ctx->stream) != size )
+    return -1;
+  if ( Sfprintf(ctx->stream, "\r\n") < 0 )
+    return -1;
+  if ( Sflush(ctx->stream) < 0 )
+    return -1;
+
+  return size;
+}
+
+
+static ssize_t
+cgi_write(void *handle, char *buf, size_t size)
+{ cgi_context *ctx = handle;
+
+  DEBUG(1, Sdprintf("cgi_write(%ld bytes)\n", (long)size));
+
+  if ( ctx->state == CGI_DISCARDED )
+  { Sseterr(ctx->cgi_stream, SIO_FERR, "CGI stream was discarded");
+    return -1;
+  }
+
+  if ( ctx->transfer_encoding == ATOM_chunked )
+  { return cgi_chunked_write(ctx, buf, size);
+  } else
+  { size_t osize = ctx->datasize;
+    size_t dstart;
+
+    if ( osize+size > ctx->dataallocated )
+    { if ( grow_data_buffer(ctx, osize+size) < 0 )
+	return -1;			/* no memory */
+    }
+    memcpy(&ctx->data[osize], buf, size);
+    ctx->datasize = osize+size;
+    osize = (osize > 4 ? osize-4 : 0);	/* 4 is max size of the separator */
+
+    if ( ctx->state == CGI_HDR &&
+	 (dstart=find_data(ctx, osize)) != ((size_t)-1) )
+    { assert(dstart <= ctx->datasize);
+      ctx->data_offset = dstart;
+      ctx->state = CGI_DATA;
+      if ( !call_hook(ctx, ATOM_header) )
+      { ctx->state = CGI_DISCARDED;
+	return -1;			/* TBD: pass error kindly */
+      }
+      ctx->cgi_stream->flags &= ~(SIO_FBUF|SIO_LBUF|SIO_NBUF);
+      ctx->cgi_stream->flags |= SIO_FBUF;
+    }
+
+    return size;
+  }
+}
+
+
+static int
+cgi_control(void *handle, int op, void *data)
+{ cgi_context *ctx = handle;
+
+  if ( ctx->magic != CGI_MAGIC )
+  { DEBUG(0, Sdprintf("OOPS: cgi_control(%d): invalid handle\n", op));
+    errno = EINVAL;
+    return -1;
+  }
+
+  switch(op)
+  { case SIO_FLUSHOUTPUT:
+    case SIO_SETENCODING:
+      return 0;				/* allow switching encoding */
+    default:
+      if ( ctx->stream->functions->control )
+	return (*ctx->stream->functions->control)(ctx->stream->handle, op, data);
+      return -1;
+  }
+}
+
+
+static int
+cgi_close(void *handle)
+{ cgi_context *ctx = handle;
+  int rc = 0;
+
+  DEBUG(1, Sdprintf("cgi_close()\n"));
+
+  switch( ctx->state )
+  { case CGI_DATA:
+    { if ( ctx->transfer_encoding == ATOM_chunked )
+      { if ( cgi_chunked_write(ctx, NULL, 0) < 0 )
+	{ rc = -1;
+	  goto out;
+	}
+      } else
+      { size_t clen = ctx->datasize - ctx->data_offset;
+	const char *dstart = &ctx->data[ctx->data_offset];
+
+	if ( !call_hook(ctx, ATOM_send_header) )
+	{ rc = -1;
+	  goto out;
+	}
+	if ( Sfwrite(dstart, sizeof(char), clen, ctx->stream) != clen ||
+	     Sflush(ctx->stream) < 0 )
+	{ rc = -1;
+	  goto out;
+	}
+      }
+
+      break;
+    }
+    case CGI_HDR:
+      break;
+    case CGI_DISCARDED:
+      goto out;
+  }
+
+  if ( !call_hook(ctx, ATOM_close) )	/* what if we had no header sofar? */
+    rc = -1;				/* TBD: pass error kindly */
+
+out:
+  ctx->stream->encoding = ctx->parent_encoding;
+  free_cgi_context(ctx);
+
+  return rc;
+}
+
+
+static IOFUNCTIONS cgi_functions =
+{ NULL,					/* read */
+  cgi_write,
+  NULL,					/* seek */
+  cgi_close,
+  cgi_control,				/* control */
+  NULL,					/* seek64 */
+};
+
+
+		 /*******************************
+		 *	       OPEN		*
+		 *******************************/
+
+static int current_id = 0;		/* TBD: MT: lock */
+
+#define CGI_COPY_FLAGS (SIO_OUTPUT| \
+			SIO_TEXT| \
+			SIO_REPXML|SIO_REPPL|\
+			SIO_RECORDPOS)
+
+static foreign_t
+pl_cgi_open(term_t org, term_t new, term_t closure, term_t options)
+{ term_t tail = PL_copy_term_ref(options);
+  term_t head = PL_new_term_ref();
+  cgi_context *ctx;
+  IOSTREAM *s, *s2;
+  module_t module = NULL;
+  term_t hook = PL_new_term_ref();
+  record_t request = 0;
+
+  PL_strip_module(closure, &module, hook);
+  if ( !PL_is_callable(hook) )
+    return type_error(closure, "callable");
+
+  while(PL_get_list(tail, head, tail))
+  { atom_t name;
+    int arity;
+    term_t arg = PL_new_term_ref();
+
+    if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
+      return type_error(head, "option");
+    _PL_get_arg(1, head, arg);
+    if ( name == ATOM_request )
+    { request = PL_record(arg);
+    } else
+      return existence_error(head, "cgi_open_option");
+  }
+  if ( !PL_get_nil(tail) )
+    return type_error(tail, "list");
+
+  if ( !PL_get_stream_handle(org, &s) )
+    return FALSE;			/* Error */
+  if ( !(s->flags&SIO_OUTPUT) )		/* only allow output stream */
+  { PL_release_stream(s);
+    return permission_error("stream", "write", org);
+  }
+
+  ctx = alloc_cgi_context(s);
+  ctx->hook = PL_record(hook);
+  ctx->module = module;
+  ctx->request = request;
+  ctx->transfer_encoding = ATOM_none;
+  if ( !(s2 = Snew(ctx,
+		   (s->flags&CGI_COPY_FLAGS)|SIO_LBUF,
+		   &cgi_functions)) )
+  { free_cgi_context(ctx);			/* no memory */
+
+    return FALSE;
+  }
+
+  s2->encoding = ENC_ASCII;		/* Header is ASCII only */
+  ctx->parent_encoding = s->encoding;
+  s->encoding = ENC_OCTET;
+  ctx->cgi_stream = s2;
+  if ( PL_unify_stream(new, s2) )
+  { Sset_filter(s, s2);
+    PL_release_stream(s);
+    ctx->id = ++current_id;
+
+    return TRUE;
+  } else
+  { return instantiation_error();
+  }
+}
+
+
+static void
+install_cgi_stream()
+{ ATOM_header		 = PL_new_atom("header");
+  ATOM_header_codes	 = PL_new_atom("header_codes");
+  ATOM_send_header	 = PL_new_atom("send_header");
+  ATOM_data		 = PL_new_atom("data");
+  ATOM_discarded	 = PL_new_atom("discarded");
+  ATOM_request		 = PL_new_atom("request");
+  ATOM_header		 = PL_new_atom("header");
+  ATOM_client		 = PL_new_atom("client");
+  ATOM_chunked		 = PL_new_atom("chunked");
+  ATOM_state		 = PL_new_atom("state");
+  ATOM_none		 = PL_new_atom("none");
+  ATOM_transfer_encoding = PL_new_atom("transfer_encoding");
+  ATOM_close             = PL_new_atom("close");
+  ATOM_keep_alife        = PL_new_atom("keep_alife");
+  ATOM_connection        = PL_new_atom("connection");
+  ATOM_content_length    = PL_new_atom("content_length");
+  ATOM_id  	         = PL_new_atom("id");
+
+  PREDICATE_call3   = PL_predicate("call", 3, "system");
+
+  PL_register_foreign("cgi_open",      4, pl_cgi_open,	 PL_FA_TRANSPARENT);
+  PL_register_foreign("is_cgi_stream", 1, is_cgi_stream, 0);
+  PL_register_foreign("cgi_property",  2, cgi_property,	 0);
+  PL_register_foreign("cgi_set",       2, cgi_set,	 0);
+  PL_register_foreign("cgi_discard",   1, cgi_discard,	 0);
+}

packages/http/common.mk

@@ -0,0 +1,28 @@
+# Makefile fragments to are updated frequently and can be shared
+
+LIBPL=		$(srcdir)/html_write.pl $(srcdir)/http_client.pl \
+		$(srcdir)/http_header.pl \
+		$(srcdir)/http_mime_plugin.pl $(srcdir)/http_sgml_plugin.pl \
+		$(srcdir)/mimepack.pl $(srcdir)/mimetype.pl \
+		$(srcdir)/dcg_basics.pl \
+		$(srcdir)/thread_httpd.pl $(srcdir)/xpce_httpd.pl \
+		$(srcdir)/inetd_httpd.pl \
+		$(srcdir)/http_wrapper.pl $(srcdir)/http_open.pl \
+		$(srcdir)/http_session.pl \
+		$(srcdir)/http_error.pl $(srcdir)/http_parameters.pl \
+		$(srcdir)/http_dispatch.pl \
+		$(srcdir)/http_authenticate.pl $(srcdir)/http_stream.pl \
+		$(srcdir)/http_log.pl \
+		$(srcdir)/http_path.pl $(srcdir)/http_hook.pl \
+		$(srcdir)/html_head.pl $(srcdir)/http_exception.pl \
+		$(srcdir)/json.pl $(srcdir)/http_json.pl \
+		$(srcdir)/json_convert.pl $(srcdir)/http_dirindex.pl \
+		$(srcdir)/http_server_files.pl $(srcdir)/http_pwp.pl \
+		$(srcdir)/http_host.pl \
+		$(srcdir)/http_openid.pl $(srcdir)/js_write.pl
+EXAMPLES=	$(srcdir)/demo_body.pl $(srcdir)/demo_client.pl \
+		$(srcdir)/demo_threads.pl $(srcdir)/demo_xpce.pl \
+		$(srcdir)/calc.pl $(srcdir)/demo_files.pl \
+		$(srcdir)/demo_pwp.pl $(srcdir)/demo_openid.pl
+EXAMPLEEXE=	demo_inetd
+XPCEPL=		$(srcdir)/http_image.pl

packages/http/config.h

@@ -0,0 +1,91 @@
+/* config.h.  Generated from config.h.in by configure.  */
+/* config.h.in.  Generated from configure.in by autoheader.  */
+
+/* Define if building universal (internal helper macro) */
+/* #undef AC_APPLE_UNIVERSAL_BUILD */
+
+/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP
+   systems. This function is required for `alloca.c' support on those systems.
+   */
+/* #undef CRAY_STACKSEG_END */
+
+/* Define to 1 if using `alloca.c'. */
+/* #undef C_ALLOCA */
+
+/* Define to 1 if you have `alloca', as a function or macro. */
+#define HAVE_ALLOCA 1
+
+/* Define to 1 if you have <alloca.h> and it should be used (not on Ultrix).
+   */
+#define HAVE_ALLOCA_H 1
+
+/* Define to 1 if you have the <inttypes.h> header file. */
+#define HAVE_INTTYPES_H 1
+
+/* Define to 1 if you have the <memory.h> header file. */
+#define HAVE_MEMORY_H 1
+
+/* Define to 1 if you have the <stdint.h> header file. */
+#define HAVE_STDINT_H 1
+
+/* Define to 1 if you have the <stdlib.h> header file. */
+#define HAVE_STDLIB_H 1
+
+/* Define to 1 if you have the <strings.h> header file. */
+#define HAVE_STRINGS_H 1
+
+/* Define to 1 if you have the <string.h> header file. */
+#define HAVE_STRING_H 1
+
+/* Define to 1 if you have the <sys/stat.h> header file. */
+#define HAVE_SYS_STAT_H 1
+
+/* Define to 1 if you have the <sys/types.h> header file. */
+#define HAVE_SYS_TYPES_H 1
+
+/* Define to 1 if you have the <unistd.h> header file. */
+#define HAVE_UNISTD_H 1
+
+/* Define to the address where bug reports for this package should be sent. */
+#define PACKAGE_BUGREPORT ""
+
+/* Define to the full name of this package. */
+#define PACKAGE_NAME ""
+
+/* Define to the full name and version of this package. */
+#define PACKAGE_STRING ""
+
+/* Define to the one symbol short name of this package. */
+#define PACKAGE_TARNAME ""
+
+/* Define to the home page for this package. */
+#define PACKAGE_URL ""
+
+/* Define to the version of this package. */
+#define PACKAGE_VERSION ""
+
+/* If using the C implementation of alloca, define if you know the
+   direction of stack growth for your system; otherwise it will be
+   automatically deduced at runtime.
+	STACK_DIRECTION > 0 => grows toward higher addresses
+	STACK_DIRECTION < 0 => grows toward lower addresses
+	STACK_DIRECTION = 0 => direction of growth unknown */
+/* #undef STACK_DIRECTION */
+
+/* Define to 1 if you have the ANSI C header files. */
+#define STDC_HEADERS 1
+
+/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most
+   significant byte first (like Motorola and SPARC, unlike Intel). */
+#if defined AC_APPLE_UNIVERSAL_BUILD
+# if defined __BIG_ENDIAN__
+#  define WORDS_BIGENDIAN 1
+# endif
+#else
+# ifndef WORDS_BIGENDIAN
+/* #  undef WORDS_BIGENDIAN */
+# endif
+#endif
+
+/* Define for multi-thread support */
+/* #undef _REENTRANT */

packages/http/config.h.in

@@ -0,0 +1,90 @@
+/* config.h.in.  Generated from configure.in by autoheader.  */
+
+/* Define if building universal (internal helper macro) */
+#undef AC_APPLE_UNIVERSAL_BUILD
+
+/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP
+   systems. This function is required for `alloca.c' support on those systems.
+   */
+#undef CRAY_STACKSEG_END
+
+/* Define to 1 if using `alloca.c'. */
+#undef C_ALLOCA
+
+/* Define to 1 if you have `alloca', as a function or macro. */
+#undef HAVE_ALLOCA
+
+/* Define to 1 if you have <alloca.h> and it should be used (not on Ultrix).
+   */
+#undef HAVE_ALLOCA_H
+
+/* Define to 1 if you have the <inttypes.h> header file. */
+#undef HAVE_INTTYPES_H
+
+/* Define to 1 if you have the <memory.h> header file. */
+#undef HAVE_MEMORY_H
+
+/* Define to 1 if you have the <stdint.h> header file. */
+#undef HAVE_STDINT_H
+
+/* Define to 1 if you have the <stdlib.h> header file. */
+#undef HAVE_STDLIB_H
+
+/* Define to 1 if you have the <strings.h> header file. */
+#undef HAVE_STRINGS_H
+
+/* Define to 1 if you have the <string.h> header file. */
+#undef HAVE_STRING_H
+
+/* Define to 1 if you have the <sys/stat.h> header file. */
+#undef HAVE_SYS_STAT_H
+
+/* Define to 1 if you have the <sys/types.h> header file. */
+#undef HAVE_SYS_TYPES_H
+
+/* Define to 1 if you have the <unistd.h> header file. */
+#undef HAVE_UNISTD_H
+
+/* Define to the address where bug reports for this package should be sent. */
+#undef PACKAGE_BUGREPORT
+
+/* Define to the full name of this package. */
+#undef PACKAGE_NAME
+
+/* Define to the full name and version of this package. */
+#undef PACKAGE_STRING
+
+/* Define to the one symbol short name of this package. */
+#undef PACKAGE_TARNAME
+
+/* Define to the home page for this package. */
+#undef PACKAGE_URL
+
+/* Define to the version of this package. */
+#undef PACKAGE_VERSION
+
+/* If using the C implementation of alloca, define if you know the
+   direction of stack growth for your system; otherwise it will be
+   automatically deduced at runtime.
+	STACK_DIRECTION > 0 => grows toward higher addresses
+	STACK_DIRECTION < 0 => grows toward lower addresses
+	STACK_DIRECTION = 0 => direction of growth unknown */
+#undef STACK_DIRECTION
+
+/* Define to 1 if you have the ANSI C header files. */
+#undef STDC_HEADERS
+
+/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most
+   significant byte first (like Motorola and SPARC, unlike Intel). */
+#if defined AC_APPLE_UNIVERSAL_BUILD
+# if defined __BIG_ENDIAN__
+#  define WORDS_BIGENDIAN 1
+# endif
+#else
+# ifndef WORDS_BIGENDIAN
+#  undef WORDS_BIGENDIAN
+# endif
+#endif
+
+/* Define for multi-thread support */
+#undef _REENTRANT

packages/http/config.log

@@ -0,0 +1,483 @@
+This file contains any messages produced by compilers while
+running configure, to aid debugging if configure makes a mistake.
+
+It was created by configure, which was
+generated by GNU Autoconf 2.65.  Invocation command line was
+
+  $ ./configure --prefix=/home/vsc/Yap/pl-devel --prefix=/home/vsc/Yap/pl-devel
+
+## --------- ##
+## Platform. ##
+## --------- ##
+
+hostname = xato
+uname -m = x86_64
+uname -r = 2.6.32-22-generic
+uname -s = Linux
+uname -v = #36-Ubuntu SMP Thu Jun 3 19:31:57 UTC 2010
+
+/usr/bin/uname -p = unknown
+/bin/uname -X     = unknown
+
+/bin/arch              = unknown
+/usr/bin/arch -k       = unknown
+/usr/convex/getsysinfo = unknown
+/usr/bin/hostinfo      = unknown
+/bin/machine           = unknown
+/usr/bin/oslevel       = unknown
+/bin/universe          = unknown
+
+PATH: /home/vsc/Yap/pl-devel/bin
+PATH: /home/vsc/bin
+PATH: /usr/local/sbin
+PATH: /usr/local/bin
+PATH: /usr/sbin
+PATH: /usr/bin
+PATH: /sbin
+PATH: /bin
+PATH: /usr/games
+PATH: /home/vsc/lgtsvn/xml
+PATH: /home/vsc/lgtsvn/scripts
+PATH: /home/vsc/lgtsvn/integration
+
+
+## ----------- ##
+## Core tests. ##
+## ----------- ##
+
+configure:2132: checking for gmake
+configure:2159: result: make
+configure:2175: checking for etags
+configure:2191: found /usr/bin/etags
+configure:2202: result: etags
+configure:2251: checking for a BSD-compatible install
+configure:2319: result: /usr/bin/install -c
+configure:2378: checking for gcc
+configure:2405: result: ../swipl-ld.sh
+configure:2634: checking for C compiler version
+configure:2643: ../swipl-ld.sh --version >&5
+gcc (Ubuntu 4.4.3-4ubuntu5) 4.4.3
+Copyright (C) 2009 Free Software Foundation, Inc.
+This is free software; see the source for copying conditions.  There is NO
+warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+configure:2654: $? = 0
+configure:2643: ../swipl-ld.sh -v >&5
+Using built-in specs.
+Target: x86_64-linux-gnu
+Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.4.3-4ubuntu5' --with-bugurl=file:///usr/share/doc/gcc-4.4/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --enable-multiarch --enable-linker-build-id --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --with-gxx-include-dir=/usr/include/c++/4.4 --program-suffix=-4.4 --enable-nls --enable-clocale=gnu --enable-libstdcxx-debug --enable-plugin --enable-objc-gc --disable-werror --with-arch-32=i486 --with-tune=generic --enable-checking=release --build=x86_64-linux-gnu --host=x86_64-linux-gnu --target=x86_64-linux-gnu
+Thread model: posix
+gcc version 4.4.3 (Ubuntu 4.4.3-4ubuntu5) 
+configure:2654: $? = 0
+configure:2643: ../swipl-ld.sh -V >&5
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 0 has invalid symbol index 11
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 1 has invalid symbol index 12
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 2 has invalid symbol index 2
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 3 has invalid symbol index 2
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 4 has invalid symbol index 11
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 5 has invalid symbol index 13
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 6 has invalid symbol index 13
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 7 has invalid symbol index 13
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 8 has invalid symbol index 2
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 9 has invalid symbol index 2
+... rest of stderr output deleted ...
+configure:2654: $? = 1
+configure:2643: ../swipl-ld.sh -qversion >&5
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 0 has invalid symbol index 11
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 1 has invalid symbol index 12
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 2 has invalid symbol index 2
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 3 has invalid symbol index 2
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 4 has invalid symbol index 11
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 5 has invalid symbol index 13
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 6 has invalid symbol index 13
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 7 has invalid symbol index 13
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 8 has invalid symbol index 2
+/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 9 has invalid symbol index 2
+... rest of stderr output deleted ...
+configure:2654: $? = 1
+configure:2674: checking whether the C compiler works
+configure:2696: ../swipl-ld.sh    conftest.c  >&5
+% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.00 sec, 37,800 bytes
+% halt
+configure:2700: $? = 0
+configure:2749: result: yes
+configure:2752: checking for C compiler default output file name
+configure:2754: result: a.out
+configure:2760: checking for suffix of executables
+configure:2767: ../swipl-ld.sh -o conftest    conftest.c  >&5
+% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.01 sec, 37,800 bytes
+% halt
+configure:2771: $? = 0
+configure:2793: result: 
+configure:2815: checking whether we are cross compiling
+configure:2823: ../swipl-ld.sh -o conftest    conftest.c  >&5
+% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.00 sec, 37,800 bytes
+% halt
+configure:2827: $? = 0
+configure:2834: ./conftest
+configure:2838: $? = 0
+configure:2853: result: no
+configure:2858: checking for suffix of object files
+configure:2880: ../swipl-ld.sh -c   conftest.c >&5
+configure:2884: $? = 0
+configure:2905: result: o
+configure:2909: checking whether we are using the GNU C compiler
+configure:2928: ../swipl-ld.sh -c   conftest.c >&5
+configure:2928: $? = 0
+configure:2937: result: yes
+configure:2946: checking whether ../swipl-ld.sh accepts -g
+configure:2966: ../swipl-ld.sh -c -g  conftest.c >&5
+configure:2966: $? = 0
+configure:3007: result: yes
+configure:3024: checking for ../swipl-ld.sh option to accept ISO C89
+configure:3088: ../swipl-ld.sh  -c -g -O2  conftest.c >&5
+configure:3088: $? = 0
+configure:3101: result: none needed
+configure:3122: checking for library containing strerror
+configure:3153: ../swipl-ld.sh -o conftest -g -O2   conftest.c  >&5
+% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.00 sec, 37,800 bytes
+% halt
+configure:3153: $? = 0
+configure:3170: result: none required
+configure:3183: checking how to run the C preprocessor
+configure:3214: ../swipl-ld.sh -E  conftest.c
+configure:3214: $? = 0
+configure:3228: ../swipl-ld.sh -E  conftest.c
+conftest.c:9:28: error: ac_nonexistent.h: No such file or directory
+gcc -E returned code 256
+*** /home/vsc/Yap/pl-devel/src/../src/swipl-ld exit status 1
+configure:3228: $? = 1
+configure: failed program was:
+| /* confdefs.h */
+| #define PACKAGE_NAME ""
+| #define PACKAGE_TARNAME ""
+| #define PACKAGE_VERSION ""
+| #define PACKAGE_STRING ""
+| #define PACKAGE_BUGREPORT ""
+| #define PACKAGE_URL ""
+| /* end confdefs.h.  */
+| #include <ac_nonexistent.h>
+configure:3253: result: ../swipl-ld.sh -E
+configure:3273: ../swipl-ld.sh -E  conftest.c
+configure:3273: $? = 0
+configure:3287: ../swipl-ld.sh -E  conftest.c
+conftest.c:9:28: error: ac_nonexistent.h: No such file or directory
+gcc -E returned code 256
+*** /home/vsc/Yap/pl-devel/src/../src/swipl-ld exit status 1
+configure:3287: $? = 1
+configure: failed program was:
+| /* confdefs.h */
+| #define PACKAGE_NAME ""
+| #define PACKAGE_TARNAME ""
+| #define PACKAGE_VERSION ""
+| #define PACKAGE_STRING ""
+| #define PACKAGE_BUGREPORT ""
+| #define PACKAGE_URL ""
+| /* end confdefs.h.  */
+| #include <ac_nonexistent.h>
+configure:3316: checking for grep that handles long lines and -e
+configure:3374: result: /bin/grep
+configure:3379: checking for egrep
+configure:3441: result: /bin/grep -E
+configure:3446: checking for ANSI C header files
+configure:3466: ../swipl-ld.sh -c -g -O2  conftest.c >&5
+configure:3466: $? = 0
+configure:3539: ../swipl-ld.sh -o conftest -g -O2   conftest.c  >&5
+% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.00 sec, 37,800 bytes
+% halt
+configure:3539: $? = 0
+configure:3539: ./conftest
+configure:3539: $? = 0
+configure:3550: result: yes
+configure:3564: checking for sys/types.h
+configure:3564: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+configure:3564: $? = 0
+configure:3564: result: yes
+configure:3564: checking for sys/stat.h
+configure:3564: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+configure:3564: $? = 0
+configure:3564: result: yes
+configure:3564: checking for stdlib.h
+configure:3564: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+configure:3564: $? = 0
+configure:3564: result: yes
+configure:3564: checking for string.h
+configure:3564: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+configure:3564: $? = 0
+configure:3564: result: yes
+configure:3564: checking for memory.h
+configure:3564: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+configure:3564: $? = 0
+configure:3564: result: yes
+configure:3564: checking for strings.h
+configure:3564: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+configure:3564: $? = 0
+configure:3564: result: yes
+configure:3564: checking for inttypes.h
+configure:3564: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+configure:3564: $? = 0
+configure:3564: result: yes
+configure:3564: checking for stdint.h
+configure:3564: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+configure:3564: $? = 0
+configure:3564: result: yes
+configure:3564: checking for unistd.h
+configure:3564: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+configure:3564: $? = 0
+configure:3564: result: yes
+configure:3579: checking for working alloca.h
+configure:3596: ../swipl-ld.sh -o conftest -fPIC   conftest.c  >&5
+% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.00 sec, 37,800 bytes
+% halt
+configure:3596: $? = 0
+configure:3604: result: yes
+configure:3612: checking for alloca
+configure:3649: ../swipl-ld.sh -o conftest -fPIC   conftest.c  >&5
+% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.01 sec, 37,800 bytes
+% halt
+configure:3649: $? = 0
+configure:3657: result: yes
+configure:3767: checking whether byte ordering is bigendian
+configure:3782: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+conftest.c:22: error: expected '=', ',', ';', 'asm' or '__attribute__' before 'a'
+gcc returned code 256
+*** /home/vsc/Yap/pl-devel/src/../src/swipl-ld exit status 1
+configure:3782: $? = 1
+configure: failed program was:
+| /* confdefs.h */
+| #define PACKAGE_NAME ""
+| #define PACKAGE_TARNAME ""
+| #define PACKAGE_VERSION ""
+| #define PACKAGE_STRING ""
+| #define PACKAGE_BUGREPORT ""
+| #define PACKAGE_URL ""
+| #define STDC_HEADERS 1
+| #define HAVE_SYS_TYPES_H 1
+| #define HAVE_SYS_STAT_H 1
+| #define HAVE_STDLIB_H 1
+| #define HAVE_STRING_H 1
+| #define HAVE_MEMORY_H 1
+| #define HAVE_STRINGS_H 1
+| #define HAVE_INTTYPES_H 1
+| #define HAVE_STDINT_H 1
+| #define HAVE_UNISTD_H 1
+| #define HAVE_ALLOCA_H 1
+| #define HAVE_ALLOCA 1
+| /* end confdefs.h.  */
+| #ifndef __APPLE_CC__
+| 	       not a universal capable compiler
+| 	     #endif
+| 	     typedef int dummy;
+| 
+configure:3827: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+configure:3827: $? = 0
+configure:3845: ../swipl-ld.sh -c -fPIC  conftest.c >&5
+conftest.c: In function 'main':
+conftest.c:28: error: 'not' undeclared (first use in this function)
+conftest.c:28: error: (Each undeclared identifier is reported only once
+conftest.c:28: error: for each function it appears in.)
+conftest.c:28: error: expected ';' before 'big'
+gcc returned code 256
+*** /home/vsc/Yap/pl-devel/src/../src/swipl-ld exit status 1
+configure:3845: $? = 1
+configure: failed program was:
+| /* confdefs.h */
+| #define PACKAGE_NAME ""
+| #define PACKAGE_TARNAME ""
+| #define PACKAGE_VERSION ""
+| #define PACKAGE_STRING ""
+| #define PACKAGE_BUGREPORT ""
+| #define PACKAGE_URL ""
+| #define STDC_HEADERS 1
+| #define HAVE_SYS_TYPES_H 1
+| #define HAVE_SYS_STAT_H 1
+| #define HAVE_STDLIB_H 1
+| #define HAVE_STRING_H 1
+| #define HAVE_MEMORY_H 1
+| #define HAVE_STRINGS_H 1
+| #define HAVE_INTTYPES_H 1
+| #define HAVE_STDINT_H 1
+| #define HAVE_UNISTD_H 1
+| #define HAVE_ALLOCA_H 1
+| #define HAVE_ALLOCA 1
+| /* end confdefs.h.  */
+| #include <sys/types.h>
+| 		#include <sys/param.h>
+| 
+| int
+| main ()
+| {
+| #if BYTE_ORDER != BIG_ENDIAN
+| 		 not big endian
+| 		#endif
+| 
+|   ;
+|   return 0;
+| }
+configure:3973: result: no
+configure:4105: creating ./config.status
+
+## ---------------------- ##
+## Running config.status. ##
+## ---------------------- ##
+
+This file was extended by config.status, which was
+generated by GNU Autoconf 2.65.  Invocation command line was
+
+  CONFIG_FILES    = 
+  CONFIG_HEADERS  = 
+  CONFIG_LINKS    = 
+  CONFIG_COMMANDS = 
+  $ ./config.status 
+
+on xato
+
+config.status:822: creating Makefile
+config.status:822: creating config.h
+
+## ---------------- ##
+## Cache variables. ##
+## ---------------- ##
+
+ac_cv_c_bigendian=no
+ac_cv_c_compiler_gnu=yes
+ac_cv_env_CC_set=
+ac_cv_env_CC_value=
+ac_cv_env_CFLAGS_set=
+ac_cv_env_CFLAGS_value=
+ac_cv_env_CPPFLAGS_set=
+ac_cv_env_CPPFLAGS_value=
+ac_cv_env_CPP_set=
+ac_cv_env_CPP_value=
+ac_cv_env_LDFLAGS_set=
+ac_cv_env_LDFLAGS_value=
+ac_cv_env_LIBS_set=
+ac_cv_env_LIBS_value=
+ac_cv_env_build_alias_set=
+ac_cv_env_build_alias_value=
+ac_cv_env_host_alias_set=
+ac_cv_env_host_alias_value=
+ac_cv_env_target_alias_set=
+ac_cv_env_target_alias_value=
+ac_cv_func_alloca_works=yes
+ac_cv_header_inttypes_h=yes
+ac_cv_header_memory_h=yes
+ac_cv_header_stdc=yes
+ac_cv_header_stdint_h=yes
+ac_cv_header_stdlib_h=yes
+ac_cv_header_string_h=yes
+ac_cv_header_strings_h=yes
+ac_cv_header_sys_stat_h=yes
+ac_cv_header_sys_types_h=yes
+ac_cv_header_unistd_h=yes
+ac_cv_objext=o
+ac_cv_path_EGREP='/bin/grep -E'
+ac_cv_path_GREP=/bin/grep
+ac_cv_prog_CPP='../swipl-ld.sh -E'
+ac_cv_prog_ETAGS=etags
+ac_cv_prog_MAKE=make
+ac_cv_prog_ac_ct_CC=../swipl-ld.sh
+ac_cv_prog_cc_c89=
+ac_cv_prog_cc_g=yes
+ac_cv_search_strerror='none required'
+ac_cv_working_alloca_h=yes
+
+## ----------------- ##
+## Output variables. ##
+## ----------------- ##
+
+ALLOCA=''
+CC='../swipl-ld.sh'
+CFLAGS='-fPIC'
+CIFLAGS=''
+CMFLAGS='-fPIC'
+COFLAGS='-O2 -fno-strict-aliasing'
+CPP='../swipl-ld.sh -E'
+CPPFLAGS=''
+CWFLAGS='-Wall'
+DEFS='-DHAVE_CONFIG_H'
+ECHO_C=''
+ECHO_N='-n'
+ECHO_T=''
+EGREP='/bin/grep -E'
+ETAGS='etags'
+EXEEXT=''
+GREP='/bin/grep'
+INSTALL_DATA='/usr/bin/install -c -m 644'
+INSTALL_PROGRAM='${INSTALL}'
+INSTALL_SCRIPT='${INSTALL}'
+LD='../swipl-ld.sh'
+LDFLAGS=''
+LDSOFLAGS='-shared'
+LIBOBJS=''
+LIBS=''
+LTLIBOBJS=''
+MAKE='make'
+OBJEXT='o'
+PACKAGE_BUGREPORT=''
+PACKAGE_NAME=''
+PACKAGE_STRING=''
+PACKAGE_TARNAME=''
+PACKAGE_URL=''
+PACKAGE_VERSION=''
+PATH_SEPARATOR=':'
+PL='../swipl.sh'
+PLARCH='x86_64-linux'
+PLBASE='/home/vsc/Yap/pl-devel/lib/swipl-5.11.1'
+PLINCL='/home/vsc/Yap/pl-devel/include'
+PLLD='../swipl-ld.sh'
+PLLIBS='-lgmp -lrt -lreadline -lncurses -lm -lrt -ldl '
+SHELL='/bin/bash'
+SO='so'
+ac_ct_CC='../swipl-ld.sh'
+bindir='${exec_prefix}/bin'
+build_alias=''
+datadir='${datarootdir}'
+datarootdir='${prefix}/share'
+docdir='${datarootdir}/doc/${PACKAGE}'
+dvidir='${docdir}'
+exec_prefix='${prefix}'
+host_alias=''
+htmldir='${docdir}'
+includedir='${prefix}/include'
+infodir='${datarootdir}/info'
+libdir='${exec_prefix}/lib'
+libexecdir='${exec_prefix}/libexec'
+localedir='${datarootdir}/locale'
+localstatedir='${prefix}/var'
+mandir='${datarootdir}/man'
+oldincludedir='/usr/include'
+pdfdir='${docdir}'
+prefix='/home/vsc/Yap/pl-devel'
+program_transform_name='s,x,x,'
+psdir='${docdir}'
+sbindir='${exec_prefix}/sbin'
+sharedstatedir='${prefix}/com'
+sysconfdir='${prefix}/etc'
+target_alias=''
+
+## ----------- ##
+## confdefs.h. ##
+## ----------- ##
+
+/* confdefs.h */
+#define PACKAGE_NAME ""
+#define PACKAGE_TARNAME ""
+#define PACKAGE_VERSION ""
+#define PACKAGE_STRING ""
+#define PACKAGE_BUGREPORT ""
+#define PACKAGE_URL ""
+#define STDC_HEADERS 1
+#define HAVE_SYS_TYPES_H 1
+#define HAVE_SYS_STAT_H 1
+#define HAVE_STDLIB_H 1
+#define HAVE_STRING_H 1
+#define HAVE_MEMORY_H 1
+#define HAVE_STRINGS_H 1
+#define HAVE_INTTYPES_H 1
+#define HAVE_STDINT_H 1
+#define HAVE_UNISTD_H 1
+#define HAVE_ALLOCA_H 1
+#define HAVE_ALLOCA 1
+
+configure: exit 0

packages/http/configure.in

@@ -0,0 +1,9 @@
+dnl Process this file with autoconf to produce a configure script.
+
+AC_INIT(install-sh)
+AC_PREREQ([2.50])
+AC_CONFIG_HEADER(config.h)
+
+m4_include([../ac_swi_c.m4])
+
+AC_OUTPUT(Makefile)

packages/http/dcg_basics.pl

@@ -0,0 +1,364 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(dcg_basics,
+	  [ white//0,			% <white inside line>
+	    whites//0,			% <white inside line>*
+	    blank//0,			% <blank>
+	    blanks//0,			% <blank>*
+	    nonblank//1,		% <nonblank>
+	    nonblanks//1,		% <nonblank>* --> chars		(long)
+	    blanks_to_nl//0,		% [space,tab,ret]*nl
+	    string//1,			% <any>* -->chars 		(short)
+	    string_without//2,		% Exclude, -->chars 		(long)
+					% Characters
+	    alpha_to_lower//1,		% Get lower|upper, return lower
+					% Decimal numbers
+	    digits//1,			% [0-9]* -->chars
+	    digit//1,			% [0-9] --> char
+	    integer//1,			% [+-][0-9]+ --> integer
+	    float//1,			% [+-]?[0-9]+(.[0-9]*)?(e[+-]?[0-9]+)? --> float
+	    number//1,			% integer | float
+					% Hexadecimal numbers
+	    xdigits//1,			% [0-9a-f]* --> 0-15*
+	    xdigit//1,			% [0-9a-f] --> 0-15
+	    xinteger//1,		% [0-9a-f]+ --> integer
+					% Misc
+	    eos//0,			% demand end-of-string
+					% generation (TBD)
+	    atom//1			% generate atom
+	  ]).
+:- use_module(library(lists)).
+
+
+/** <module> Various general DCG utilities
+
+This library provides various commonly  used   DCG  primitives acting on
+list  of  character  codes.  Character    classification   is  based  on
+code_type/2.
+
+@tbd	Try to achieve an accepted standard and move this into the
+	general SWI-Prolog library.  None of this is HTTP specific.
+*/
+
+%%	string_without(+End, -Codes)// is det.
+%
+%	Take as many tokens from the input  until the next token appears
+%	in End. End itself is left on the  input. Typical use is to read
+%	upto a defined delimiter such  as   a  newline or other reserved
+%	character.
+%
+%	@see string//1.
+
+string_without(Not, [C|T]) -->
+	[C],
+	{ \+ memberchk(C, Not)
+	}, !,
+	string_without(Not, T).
+string_without(_, []) -->
+	[].
+
+%%	string(-Codes)// is nondet.
+%
+%	Take as few as possible tokens from the input, taking one more
+%	each time on backtracking. This code is normally followed by a
+%	test for a delimiter.  E.g.
+%
+%	==
+%	upto_colon(Atom) -->
+%		string(Codes), ":", !,
+%		{ atom_codes(Atom, Codes) }.
+%	==
+
+string([]) -->
+	[].
+string([H|T]) -->
+	[H],
+	string(T).
+
+%%	blanks// is det.
+%
+%	Skip zero or more white-space characters.
+
+blanks -->
+	blank, !,
+	blanks.
+blanks -->
+	[].
+
+%%	blank// is semidet.
+%
+%	Take next =space= character from input. Space characters include
+%	newline.
+%
+%	@see white//0
+
+blank -->
+	[C],
+	{ nonvar(C),
+	  code_type(C, space)
+	}.
+
+%%	nonblanks(-Codes)// is det.
+%
+%	Take all =graph= characters
+
+nonblanks([H|T]) -->
+	[H],
+	{ code_type(H, graph)
+	}, !,
+	nonblanks(T).
+nonblanks([]) -->
+	[].
+
+%%	nonblank(-Code)// is semidet.
+%
+%	Code is the next non-blank (=graph=) character.
+
+nonblank(H) -->
+	[H],
+	{ code_type(H, graph)
+	}.
+
+%%	blanks_to_nl// is semidet.
+%
+%	Take a sequence of blank//0 codes if banks are followed by a
+%	newline or end of the input.
+
+blanks_to_nl -->
+	"\n", !.
+blanks_to_nl -->
+	blank, !,
+	blanks_to_nl.
+blanks_to_nl -->
+	eos.
+
+%%	whites// is det.
+%
+%	Skip white space _inside_ a line.
+%
+%	@see blanks//0 also skips newlines.
+
+whites -->
+	white, !,
+	whites.
+whites -->
+	[].
+
+%%	white// is semidet.
+%
+%	Take next =white= character from input. White characters do
+%	_not_ include newline.
+
+white -->
+	[C],
+	{ nonvar(C),
+	  code_type(C, white)
+	}.
+
+
+		 /*******************************
+		 *	 CHARACTER STUFF	*
+		 *******************************/
+
+%%	alpha_to_lower(+C)// is det.
+%%	alpha_to_lower(-C)// is semidet.
+%
+%	Read a letter (class  =alpha=)  and   return  it  as a lowercase
+%	letter. In output mode this simply emits the character.
+
+alpha_to_lower(L) -->
+	{ integer(L) }, !,
+	[L].
+alpha_to_lower(L) -->
+	[C],
+	{ code_type(C, alpha),
+	  code_type(C, to_upper(L))
+	}.
+
+
+		 /*******************************
+		 *	      NUMBERS		*
+		 *******************************/
+
+%%	digits(?Chars)// is det.
+%%	digit(?Char)// is det.
+%%	integer(?Integer)// is det.
+%
+%	Number processing. The predicate  digits//1   matches  a posibly
+%	empty set of digits,  digit//1  processes   a  single  digit and
+%	integer processes an  optional  sign   followed  by  a non-empty
+%	sequence of digits into an integer.
+
+digits([H|T]) -->
+	digit(H), !,
+	digits(T).
+digits([]) -->
+	[].
+
+digit(C) -->
+	[C],
+	{ code_type(C, digit)
+	}.
+
+integer(I, Head, Tail) :-
+	integer(I), !,
+	format(codes(Head, Tail), '~w', [I]).
+integer(I) -->
+	int_codes(Codes),
+	{ number_codes(I, Codes)
+	}.
+
+int_codes([C,D0|D]) -->
+	sign(C), !,
+	digit(D0),
+	digits(D).
+int_codes([D0|D]) -->
+	digit(D0),
+	digits(D).
+
+
+%%	float(?Float)// is det.
+%
+%	Process a floating  point  number.   The  actual  conversion  is
+%	controlled by number_codes/2.
+
+float(F, Head, Tail) :-
+	float(F), !,
+	with_output_to(codes(Head, Tail), write(F)).
+float(F) -->
+	number(F),
+	{ float(F) }.
+
+%%	number(+Number)// is det.
+%%	number(-Number)// is semidet.
+%
+%	Generate extract a number. Handles   both  integers and floating
+%	point numbers.
+
+number(N, Head, Tail) :-
+	number(N), !,
+	format(codes(Head, Tail), '~w', N).
+number(N) -->
+	int_codes(I),
+	(   dot,
+	    digit(DF0),
+	    digits(DF)
+	->  {F = [0'., DF0|DF]}
+	;   {F = ""}
+	),
+	(   exp
+	->  int_codes(DI),
+	    {E=[0'e|DI]}
+	;   {E = ""}
+	),
+	{ append([I, F, E], Codes),
+	  number_codes(N, Codes)
+	}.
+
+sign(0'-) --> "-".
+sign(0'+) --> "+".
+
+dot --> ".".
+
+exp --> "e".
+exp --> "E".
+
+		 /*******************************
+		 *	    HEX NUMBERS		*
+		 *******************************/
+
+%%	xinteger(+Integer)// is det.
+%%	xinteger(-Integer)// is semidet.
+%
+%	Generate or extract an integer from   a  sequence of hexadecimal
+%	digits.
+
+xinteger(Val, Head, Tail) :-
+	integer(Val),
+	format(codes(Head, Tail), '~16r', [Val]).
+xinteger(Val) -->
+	xdigit(D0),
+	xdigits(D),
+	{ mkval([D0|D], 16, Val)
+	}.
+
+%%	xdigit(-Weight)// is semidet.
+%
+%	True if the next code is a  hexdecimal digit with Weight. Weight
+%	is between 0 and 15.
+
+xdigit(D) -->
+	[C],
+	{ code_type(C, xdigit(D))
+	}.
+
+%%	xdigits(-WeightList)// is det.
+%
+%	List of weights of a sequence of hexadecimal codes.  WeightList
+%	may be empty.
+
+xdigits([D0|D]) -->
+	xdigit(D0), !,
+	xdigits(D).
+xdigits([]) -->
+	[].
+
+mkval([W0|Weights], Base, Val) :-
+	mkval(Weights, Base, W0, Val).
+
+mkval([], _, W, W).
+mkval([H|T], Base, W0, W) :-
+	W1 is W0*Base+H,
+	mkval(T, Base, W1, W).
+
+
+		 /*******************************
+		 *	   END-OF-STRING	*
+		 *******************************/
+
+%%	eos//
+%
+%	True if at end of input list.
+
+eos([], []).
+
+		 /*******************************
+		 *	     GENERATION		*
+		 *******************************/
+
+%%	atom(+Atom)// is det.
+%
+%	Generate codes of Atom.  Current implementation uses write/1,
+%	dealing with any Prolog term.
+
+atom(Atom, Head, Tail) :-
+	format(codes(Head, Tail), '~w', [Atom]).

packages/http/examples/README

@@ -0,0 +1,68 @@
+This is a simple demo of the  HTTP server facilities, providing a simple
+body and the three documented server instantiations.
+
+---+ The server main programs are:
+
+	$ demo_threads.pl :
+	Run threaded server. Requires SWI-Prolog with thread-support.
+	The server is started at port 3000 using server/0.  server/2
+	allows to specify options. tm/0 provides a graphical display
+	of the runing threads.  See source-file.
+
+	$ demo_xpce.pl :
+	Run XPCE-based event-driven server.  Requires XPCE.  Use
+	?- server(3000). to start the server at port 3000.
+
+	$ demo_inetd :
+	To install this, adjust the first line of this file to point
+	to the installed Prolog executable and add the following line
+	to /etc/inetd.conf (adjust as needed):
+
+	4001 stream tcp nowait nobody /usr/sbin/tcpd /usr/lib/pl-5.1.4/library/http/demo/demo_inetd
+
+---+ Session management demo:
+
+	$ calc.pl :
+	Multi-threaded server with session management using the
+	html_write.pl library.  See source for usage.
+
+---+ File serving demo:
+
+	$ demo_files.pl :
+	Is a multi-threaded server that serves static files and
+	directory indices.
+
+---+ Client demo
+
+	$ demo_client.pl :
+	Simple multi-threaded client to test the server under
+	different conditions.  Requires SWI-Prolog with thread-support.
+	See source for usage.
+
+---+ Performance testing
+
+A very early start of some  routines   to  validate the server platform.
+Eventually, stress_server.pl will serve different   tests  from multiple
+locations  and  stress_client.pl  will  contain    client  code  to  run
+individual tests as well as doing multi-threaded tests.
+
+	$ stress_server.pl :
+	Server platform.
+
+	$ stress_client.pl :
+	Client.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

packages/http/examples/calc.pl

@@ -0,0 +1,92 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): Public domain
+*/
+
+:- use_module(library('http/thread_httpd')).
+:- use_module(library('http/html_write')).
+:- use_module(library('http/http_session')).
+:- use_module(library('http/http_error')).
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+This demo shows session state  management   in  a very simple calculator
+package. It also demonstrates the use of  the html_write library. To use
+it, start Prolog, load this file and run
+
+	?- server.
+
+Now direct your browser to http://localhost:3000/
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+server :-
+	server(3000, []).
+
+server(Port, Options) :-
+	http_server(reply,
+		    [ port(Port),
+		      timeout(20)
+		    | Options
+		    ]).
+
+reply(Request) :-
+	memberchk(path(Path), Request),
+	reply(Path, Request).
+
+reply(/, _Request) :-
+	http_session_retractall(formula(_)),
+	Formula = 0,
+	http_session_assert(formula(Formula)),
+	page(Formula).
+
+reply('/calc', Request) :-
+	memberchk(search(Search), Request),
+	memberchk(operation=Op, Search),
+	memberchk(value=AtomVal, Search),
+	atom_number(AtomVal, Val),
+	http_session_retract(formula(Formula0)),
+	debug(calc, 'Formula0 = ~w', [Formula0]),
+	Formula =.. [Op, Formula0, Val],
+	http_session_assert(formula(Formula)),
+	page(Formula).
+
+
+page(Formula) :-
+	reply_page('HTTP Session DEMO',
+		   [ h2('Simple session demo'),
+		     form([ action('/calc'),
+			    method('GET')
+			  ],
+			  table([align(center), border(1)],
+				[ tr(td(\formula(Formula))),
+				  tr(td([ \ops,
+					  input([ name(value) ]),
+					  input([ type(submit),
+						  value('Calc!')
+						])
+					]))
+				]))
+		   ]).
+
+formula(Formula) -->
+	{ sformat(S, '~w', [Formula]),
+	  Value is Formula
+	},
+	html([ S, ' = ', Value ]).
+
+ops -->
+	html(select(name(operation),
+		    [ option([selected], +),
+		      option([], -),
+		      option([], /),
+		      option([], *)
+		    ])).
+
+reply_page(Title, Content) :-
+	phrase(page(title(Title), Content), HTML),
+	format('Content-type: text/html~n~n'),
+	print_html(HTML).

packages/http/examples/demo_body.pl

@@ -0,0 +1,212 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(demo_body,
+	  [ reply/1
+	  ]).
+:- use_module(library('http/http_client')).
+:- use_module(library('http/http_mime_plugin')). % Decode multipart data
+:- use_module(library('http/http_image')).	 % make XPCE generate images
+
+
+:- style_check(-atom).			% allow long atoms
+
+reply(_) :-
+	flag(request, N, N+1),
+	fail.
+
+%	/quit
+%
+%	Explicitely close the connection
+
+reply(Request) :-
+	member(path('/quit'), Request), !,
+	format('Connection: close~n', []),
+	format('Content-type: text/html~n~n', []),
+	format('Bye Bye~n').
+
+%	/xpce?class=box
+%
+%	Make XPCE reply with a graphics image. The demo-body pce_reply/1
+%	is called embedded in a  message  to   XPCE  to  force  the XPCE
+%	incremental garbage collector to reclaim   objects created while
+%	serving the request. pce_reply/1 replies   to ?class=box using a
+%	blue box with rounded corners.
+
+reply(Request) :-
+	member(path('/xpce'), Request), !,
+	send(@prolog, call, demo_body:pce_reply(Request)).
+
+%	/env
+%
+%	Reply with the output of printenv (Unix systems only).
+
+reply(Request) :-
+	member(path('/env'), Request), !,
+	expand_file_name(~, Home),
+	format('Content-type: text/html~n~n', []),
+	format('<html>~n', []),
+	flag(request, RN, RN),
+	format('Request ~d~n', [RN]),
+	format('<pre>~n', []),
+	format('HOME = ~w~n~n', [Home]),
+	open(pipe(printenv), read, Fd),
+	copy_stream_data(Fd, current_output),
+	close(Fd),
+	format('</pre>~n', []),
+	format('</html>~n', []).
+
+%	/upload
+%	/upload_reply
+%
+%	Provide a form for uploading a file, and deal with the resulting
+%	upload.  Contributed by Nicos Angelopoulos.
+
+reply(Request) :-
+        member(path('/upload'), Request), !,
+        format('Content-type: text/html~n~n', []),
+        format('<html>~n', []),
+	format('<form action="/upload_reply" enctype="multipart/form-data" method="post">~n', []),
+	format('<input type="file" name="datafile">'),
+	format('<input type="submit" name="sent">'),
+        format('</body>~n', []),
+        format('</html>~n', []).
+
+reply(Request) :-
+        member(path('/upload_reply'), Request), !,
+        format('Content-type: text/html~n~n', []),
+        format('<html>~n', []),
+        format('<pre>~n', []),
+	write( req(Request) ), nl,
+	http_read_data(Request, Data, []),
+	write( data(Data) ), nl,
+	format('</pre>'),
+        format('</body>~n', []),
+        format('</html>~n', []).
+
+%	/xml
+%
+%	Return a simple formatted XML message.
+
+reply(Request) :-
+	member(path('/xml'), Request), !,
+	format('Content-type: text/xml~n~n', []),
+	format('\
+<message>
+  <head>
+  <from>Jan Wielemaker</from>
+  <to>Prolog users</to>
+  <subject>The SWI-Prolog web-server</subject>
+  </head>
+  <body>
+<p>
+This is the first demo of the web-server serving an XML message
+</p>
+  </body>
+</message>
+', []).
+
+%	/foreign
+%
+%	Test emitting text using UTF-8 encoding
+
+reply(Request) :-
+	member(path('/foreign'), Request), !,
+	format('Content-type: text/html~n~n', []),
+	format('\
+<html>
+<head><title>Foreign characters</title></head>
+<body>
+<p>Chinese for book is ~s
+</body>
+</html>
+',
+[ [23398, 20064]
+]).
+
+
+%	/work
+%
+%	Do a lot of work and then say 'ok'. Can be used to test
+%	concurrent access using the multi-threaded server.
+
+reply(Request) :-
+	member(path('/work'), Request),
+	format(user_error, 'Starting work ...', []),
+	forall(between(1, 10000000, _), atom_codes(_, "hello")),
+	format(user_error, 'done!~n', []),
+	format('Content-type: text/plain~n~n', []),
+	format('ok~n').
+
+%	/error
+%
+%	Produce an error.  Load http_error to see the effect.
+
+reply(Request) :-
+	member(path('/error'), Request),
+	A is 1/0,
+	format('Content-type: text/plain~n~n', []),
+	format('A = ~w~n', [A]).
+
+%	... Otherwise
+%
+%	Print the request itself.
+
+reply(Request) :-
+	format('Content-type: text/html~n~n', []),
+	format('<html>~n', []),
+	format('<table border=1>~n'),
+	print_request(Request),
+	format('~n</table>~n'),
+	format('</html>~n', []).
+
+
+print_request([]).
+print_request([H|T]) :-
+	H =.. [Name, Value],
+	format('<tr><td>~w<td>~w~n', [Name, Value]),
+	print_request(T).
+
+
+		 /*******************************
+		 *     PCE BASED REQUESTS	*
+		 *******************************/
+
+pce_reply(Request) :-
+	memberchk(search(Search), Request),
+	memberchk(class=box, Search),
+	new(Box, box(200,200)),
+	send(Box, radius, 20),
+	send(Box, fill_pattern, colour(skyblue)),
+	reply_image(Box, []).
+
+
+

packages/http/examples/demo_client.pl

@@ -0,0 +1,161 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- use_module(library('http/http_client')).
+:- use_module(library(debug)).
+:- use_module(library('http/http_sgml_plugin')).
+
+
+%	stress(+Times, +Threads, +URLOrAlias)
+%
+%	Typical use: stress(1000, 3, 1): run the test 1000 times with
+%	3 client threads on the /xml test from demo_body.pl and verify
+%	the parsed result.
+
+stress(Times, Parallel, Alias) :-
+	answer(Alias, URL, _), !,
+	stress(Times, Parallel, URL).
+stress(Times, Parallel, URL) :-
+	(   pool(pool, _)
+	->  delete_pool(pool)
+	;   true
+	),
+	create_pool(pool, Parallel),
+	stress(Times, URL),
+	wait_done(Times),
+	delete_pool(pool).
+
+wait_done(0) :- !.
+wait_done(N) :-
+	thread_get_message(done, Result),
+	put(Result), flush,
+	N1 is N - 1,
+	wait_done(N1).
+
+stress(0, _) :- !.
+stress(N, URL) :-
+	thread_send_message(pool, stress_url(URL)),
+	NN is N - 1,
+	stress(NN, URL).
+
+stress_url(URL) :-
+	thread_self(Me),
+	atom_number(N, Me),
+	(   catch(http_get(URL, X, [connection(close)]), E, true)
+	->  (   var(E)
+	    ->	(   answer(_, URL, Correct)
+		->  (   X == Correct
+		    ->  thread_send_message(done, N)
+		    ;   thread_send_message(done, !)
+		    )
+		;   thread_send_message(done, ?)
+		)
+	    ;	print_message(error, E),
+		thread_send_message(done, 'E')
+	    )
+	;   thread_send_message(done, -)
+	).
+
+:- dynamic
+	pool/2.				% name, threads
+
+create_pool(Name, N) :-
+	message_queue_create(Name),
+	findall(Id, (between(1, N, _),
+		     thread_create(worker(Name), Id, [])), Threads),
+	assert(pool(Name, Threads)).
+
+
+delete_pool(Name) :-
+	pool(Name, Threads),
+	forall(member(_, Threads), thread_send_message(Name, thread_exit(ok))),
+	forall(member(Id, Threads), thread_join(Id, _)),
+	message_queue_destroy(Name),
+	retract(pool(Name, Threads)).
+
+
+
+
+
+worker(Queue) :-
+	repeat,
+	  thread_get_message(Queue, Goal),
+	  (   catch(Goal, E, true)
+	  ->  (   var(E)
+	      ->  true
+	      ;   print_message(error, E)
+	      )
+	  ;   print_message(error, goal_failed(Goal))
+	  ),
+	fail.
+
+
+		 /*******************************
+		 *	  CORRECT ANSWERS	*
+		 *******************************/
+
+
+answer(1, 'http://localhost:3000/xml',
+       [ element(message,
+	  [],
+	  [ '\n  ',
+	    element(head,
+		    [],
+		    [ '\n  ',
+		      element(from,
+			      [],
+			      [ 'Jan Wielemaker'
+			      ]),
+		      '\n  ',
+		      element(to,
+			      [],
+			      [ 'Prolog users'
+			      ]),
+		      '\n  ',
+		      element(subject,
+			      [],
+			      [ 'The SWI-Prolog web-server'
+			      ]),
+		      '\n  '
+		    ]),
+	    '\n  ',
+	    element(body,
+		    [],
+		    [ '\n',
+		      element(p,
+			      [],
+			      [ '\nThis is the first demo of the web-server serving an XML message\n'
+			      ]),
+		      '\n  '
+		    ]),
+	    '\n'
+	  ])
+       ]).

packages/http/examples/demo_files.pl

@@ -0,0 +1,50 @@
+:- use_module(library(http/thread_httpd)).
+:- use_module(library(http/html_write)).
+:- use_module(library(http/http_dispatch)).
+:- use_module(library(http/http_dirindex)).
+
+:- http_handler(root(.), serve_files, [prefix]).
+
+%%	server(+Port, +DirSpec) is det.
+%
+%	Start  the  server  at  port  Port,  serving  directories  below
+%	DirSpec. DirSpec may contain ~ and $var.
+%
+%	This simple example defines  a   complete  web-server for static
+%	pages. Note that more specific  handlers   than  the  bave (i.e.
+%	using a longer path) have  priority   over  this handler and can
+%	thus be used to add dynamic parts to your server.
+
+server(Port, DirSpec) :-
+	expand_file_name(DirSpec, [Dir]),
+	assert(user:file_search_path(document_root, Dir)),
+	http_server(http_dispatch, [port(Port)]).
+
+%%	serve_files(Request)
+%
+%	Server a file or directory  according   to  the path_info field,
+%	which contains the path *after* the http-location matched by the
+%	handler. If the  handler  is   matched  *exactly*,  path_info is
+%	missing.
+%
+%	http_safe_file/1 checks the path for attempts to escape from the
+%	hierarchy defined by the =document_root= alias. We find the path
+%	before calling one of the two reply functions because we want to
+%	know whether we are dealing with a   directory  or a file. After
+%	that, the path is absolute  and   we  must  pass unsafe(true) to
+%	avoid the path-checker in the reply-functions complaining.
+
+serve_files(Request) :-
+	(   memberchk(path_info(PathInfo), Request)
+	->  true
+	;   PathInfo = './'
+	),
+	http_safe_file(document_root(PathInfo), []),
+	absolute_file_name(document_root(PathInfo), Path,
+			   [ access(read)] ),
+	(   exists_directory(Path)
+	->  http_reply_dirindex(Path, [unsafe(true)], Request)
+	;   http_reply_file(Path, [unsafe(true)], Request)
+	).
+
+

packages/http/examples/demo_inetd

@@ -0,0 +1,18 @@
+#!/usr/bin/pl -t main -q -f
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:  Jan Wielemaker
+    E-mail:  jan@swi.psy.uva.nl
+    WWW:     http://www.swi.psy.uva.nl/projects/SWI-Prolog/
+    Copying: GPL-2.  See the file COPYING or http://www.gnu.org
+
+    Copyright (C) 1990-2001 SWI, University of Amsterdam. All rights reserved.
+*/
+
+:- use_module(demo_body).
+:- use_module(library('http/inetd_httpd')).
+
+main :-
+	http_server(reply, []).

packages/http/examples/demo_openid.pl

@@ -0,0 +1,173 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2007-2010, University of Amsterdam,
+			      VU University Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+
+:- asserta(file_search_path(library, '..')).
+
+:- use_module(library(uri)).
+:- use_module(library(http/http_openid)).
+:- use_module(library(http/http_host)).
+:- use_module(library(http/http_dispatch)).
+:- use_module(library(http/http_path)).
+:- use_module(library(http/thread_httpd)).
+:- use_module(library(http/html_write)).
+:- use_module(library(http/http_error)).
+
+http:location(openid, root(openid), []).
+
+:- multifile
+	http_openid:openid_hook/1.
+
+http_openid:openid_hook(trusted(_OpenID, Server)) :-
+	debug(openid(test), 'Trusting server ~q', [Server]).
+
+
+%%	server
+%
+%	Create demo server  and  client.   After  starting  the  server,
+%	contact http://localhost:8000/
+
+server :-
+	debug(openid(_)),
+	Port = 8000,
+	http_server(http_dispatch,
+		    [ port(Port)
+		    ]),
+	debug(openid(test), 'Server started at http://localhost:~w/', [Port]).
+
+
+assoc :-
+	openid_associate('http://localhost:8000/openid/server', Handle, Assoc),
+	writeln(Handle-Assoc).
+
+%%	secret(+Request) is det.
+%
+%	Example of a handler that requires an  OpenID login. If the user
+%	is not logged it, it will be  redirected to the login page, from
+%	there to the OpenID server and back here. All this is completely
+%	transparent to us.
+
+:- http_handler(root('secret'), secret, []).
+
+secret(Request) :-
+	openid_user(Request, User, []),
+	reply_html_page(title('Secret'),
+			[ 'You\'ve reached the secret page as user ', %'
+			  a(href(User), User)
+			]).
+
+%%	root(+Request).
+%%	allow(+Request).
+%
+%	Shows an indirect login.
+
+:- http_handler(root(.),	     root,				[]).
+:- http_handler(root('test/verify'), openid_verify([return_to(allow)]),	[]).
+:- http_handler(root('test/allow'),  allow,				[]).
+
+root(_Request) :-
+	reply_html_page(title('Demo OpenID consumer'),
+			[ h1('OpenID consumer'),
+			  form([ name(login),
+				 action('/test/verify'),
+				 method('GET')
+			       ],
+			       [ div([ 'OpenID: ',
+				       input([ name(openid_url),
+					       size(40),
+					       value('http://localhost:8000/user/bob') % test
+					     ]),
+				       input([type(submit), value('Verify!')])
+				     ])
+			       ]),
+			  p([ 'Or go directly to the ', a(href=secret, 'secret page') ])
+			]).
+
+
+allow(Request) :-
+	openid_authenticate(Request, Server, Identity, _ReturnTo),
+	reply_html_page(title('Success'),
+			[ h1('OpenID login succeeded'),
+			  p([ 'The OpenID server ',
+			      a(href(Server),Server),
+			      ' verified you as ',
+			      a(href(Identity), Identity)
+			    ])
+			]).
+
+
+		 /*******************************
+		 *	   OpenID SERVER	*
+		 *******************************/
+
+:- http_handler(root('user/'),	user_page,	   [prefix]).
+:- http_handler(openid(server),	openid_server([]), []).
+:- http_handler(openid(grant),	openid_grant, []).
+
+:- multifile
+	http_openid:openid_hook/1.
+
+http_openid:openid_hook(grant(_Request, Options)) :-
+	debug(openid(test), 'Granting access to ~p', [Options]).
+
+%%	user_page(+Request) is det.
+%
+%	Generate a page for user as /user/<user>.
+
+user_page(Request) :-
+	http_current_host(Request, Host, Port,
+			  [ global(true)
+			  ]),
+	http_location_by_id(openid_server, ServerLocation),
+	uri_authority_data(host, AComp, Host),
+	uri_authority_data(port, AComp, Port),
+	uri_authority_components(Authority, AComp),
+	uri_data(scheme, Components, http),
+	uri_data(authority, Components, Authority),
+	uri_data(path, Components, ServerLocation),
+	uri_components(OpenIDServer, Components),
+	memberchk(path_info(User), Request),
+	reply_html_page([ link([ rel('openid.server'),
+				 href(OpenIDServer)
+			       ]),
+			  title('OpenID page of ~w'-[User])
+			],
+			h1('OpenID page of ~w'-[User])).
+
+
+		 /*******************************
+		 *		DEBUG		*
+		 *******************************/
+
+:- http_handler(root(.), print_request, [prefix]).
+
+print_request(Request) :-
+	format('Content-type: text/plain~n~n'),
+	pp(Request).

packages/http/examples/demo_pwp.pl

@@ -0,0 +1,20 @@
+:- use_module(library(http/thread_httpd)).
+:- use_module(library(http/http_parameters)).
+:- use_module(library(http/http_dispatch)).
+:- use_module(library(http/http_error)).
+:- use_module(library(http/html_write)).
+:- use_module(library(http/http_pwp)).
+
+:- prolog_load_context(directory, Dir),
+   asserta(user:file_search_path(http_demo, Dir)).
+
+user:file_search_path(pwp_demo, http_demo(pwp)).
+
+:- http_handler(root(.),
+		pwp_handler([path_alias(pwp_demo), view(true)]),
+		[prefix]).
+
+server(Port) :-
+	http_server(http_dispatch, [port(Port)]).
+
+

packages/http/examples/demo_threads.pl

@@ -0,0 +1,30 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:  Jan Wielemaker
+    E-mail:  jan@swi.psy.uva.nl
+    WWW:     http://www.swi.psy.uva.nl/projects/SWI-Prolog/
+    Copying: GPL-2.  See the file COPYING or http://www.gnu.org
+
+    Copyright (C) 1990-2001 SWI, University of Amsterdam. All rights reserved.
+*/
+
+:- load_files([ demo_body,
+		library('http/thread_httpd')
+	      ],
+	      [ silent(true)
+	      ]).
+
+server :-
+	server(3000, []).
+
+server(Port, Options) :-
+	http_server(reply,
+		    [ port(Port),
+		      timeout(20)
+		    | Options
+		    ]).
+
+tm :-
+	prolog_ide(thread_monitor).

packages/http/examples/demo_xpce.pl

@@ -0,0 +1,40 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- use_module(library('http/xpce_httpd')).
+:- use_module(demo_body).
+
+server(Port) :-
+	http_server(reply,
+		    [ port(Port)
+		    ]).
+
+

packages/http/examples/pwp/context.pwp

@@ -0,0 +1,23 @@
+<?xml version="1.0"?>
+<!DOCTYPE html>
+
+<html xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl">
+
+<head>
+  <title>Context variables for PWP scripts</title>
+</head>
+<body>
+  <p>This PWP demo lists the context-parameters that are passed into
+     the script.
+  </p>
+  <ul>
+    <li pwp:ask="member(Name=Value, CONTEXT)">
+      <span class=name pwp:use="Name"/>
+      =
+      <span class=value pwp:use="writeq(Value)"/>
+    </li>
+  </ul>
+</body>
+
+</html>
+

packages/http/examples/pwp/index.pwp

@@ -0,0 +1,25 @@
+<?xml version="1.0"?>
+<!DOCTYPE html>
+
+<html xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl">
+
+<head>
+  <title>Index for PWP demos</title>
+</head>
+<body pwp:ask="atom_concat(SCRIPT_DIRECTORY, /, Prefix),
+	       atom_concat(Prefix, '*.pwp', Pattern),
+	       expand_file_name(Pattern, Paths),
+	       maplist(atom_concat(Prefix), Files, Paths)">
+
+<h1>PWP scripts in this directory</h1>
+
+  <ul>
+    <li pwp:ask="member(F, Files), F \== 'index.pwp'">
+	<a pwp:use="F" pwp:att="$" href="$(F)$"/>
+	<a pwp:att="$" href="$(F)$?view=source">source</a>
+    </li>
+  </ul>
+</body>
+
+</html>
+

packages/http/examples/pwp/pwp1.pwp

@@ -0,0 +1,12 @@
+<?xml version="1.0"?>
+
+<html
+  xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl"
+  pwp:ask = "ensure_loaded(pwp(pwpdb)), once(msg(Greeting))">
+  <head>
+    <title pwp:use="Greeting"/>
+  </head>
+  <body>
+    <p><span pwp:use="Greeting" pwp:tag='-'/></p>
+  </body>
+</html>

packages/http/examples/pwp/pwp2.pwp

@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+
+<html
+  xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl">
+  <head><title>Example 2</title></head>
+  <body pwp:ask="Hello = 'Hello world', A = 20, B = 22">
+    <h1 pwp:use="Hello"/>
+    <p>The answer is <span pwp:tag='-' pwp:use="C" pwp:ask="C is A+B"/>.</p>
+  </body>
+</html>

packages/http/examples/pwp/pwp3.pwp

@@ -0,0 +1,25 @@
+<?xml version="1.0"?>
+
+<html
+  xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl"
+  pwp:ask='ensure_loaded(pwp(pwpdb))'>
+  <head>
+    <title>Phone list for Full-Time staff.</title>
+  </head>
+  <body>
+    <h1>Phone list for Full-Time staff.</h1>
+    <table
+      pwp:ask = "setof(FullName-Phone,
+		       N^O^E^(
+			 status(N, full_time),
+			 staff(N, FullName, O, Phone, E)
+		       ),
+		       Staff_List)">
+      <tr><th>Name</th><th>Phone</th></tr>
+      <tr pwp:ask="member(FullName-Phone, Staff_List)">
+	<td pwp:use="FullName"/>
+	<td pwp:use="Phone"/>
+      </tr>
+    </table>
+  </body>
+</html>

packages/http/examples/pwp/pwp4.pwp

@@ -0,0 +1,23 @@
+<?xml version="1.0"?>
+
+<html
+  xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl"
+  pwp:ask='ensure_loaded(pwp(pwpdb))'>
+  <head>
+    <title>Phone list for Full-Time staff.</title>
+  </head>
+  <body>
+    <h1>Phone list for Full-Time staff.</h1>
+    <table
+      pwp:ask = "setof(FullName-E_Mail,
+		       N^O^P^staff(N, FullName, O, P, E_Mail),
+		       Staff_List)">
+      <tr><th>Name</th><th>Address</th></tr>
+      <tr pwp:ask="member(FullName-E_Mail, Staff_List)">
+	<td pwp:use="FullName"/>
+	<td><a pwp:use="E_Mail"
+	       pwp:att='$' href="mailto:$(E_Mail)$"/></td>
+      </tr>
+    </table>
+  </body>
+</html>

packages/http/examples/pwp/pwp5.pwp

@@ -0,0 +1,11 @@
+<?xml version="1.0"?>
+
+<html
+  xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl">
+  <head><title>$SHELL</title></head>
+  <body>
+    <p pwp:ask="getenv('SHELL', Shell)"
+    >The default shell is <span pwp:tag="-" pwp:use="Shell"/>.</p>
+    <p pwp:ask="\+getenv('SHELL',_)">There is no default shell.</p>
+  </body>
+</html>

packages/http/examples/pwp/pwp6.pwp

@@ -0,0 +1,3 @@
+<?xml version="1.0"?>
+
+<a>b</a>

packages/http/examples/pwp/pwp7.pwp

@@ -0,0 +1,3 @@
+<?xml version="1.0"?>
+
+<a><b pwp:use='27' pwp:tag='-'/></a>

packages/http/examples/pwp/pwp8.pwp

@@ -0,0 +1,3 @@
+<?xml version="1.0"?>
+
+<a pwp:ask="B=20,C=22"><b pwp:use="B"/><c pwp:use="C"/></a>

packages/http/examples/pwp/pwpdb.pl

@@ -0,0 +1,12 @@
+%  This is a tiny data base for testing PWP.
+
+msg('Hello, World!').
+
+status(tom,   full_time).
+status(dick,  part_time).
+status(harry, full_time).
+
+staff(tom,   'Tom Cat',    1-21, 'x1234', 'tom@jerry.example.org').
+staff(dick,  'Dick Tater', 2-50, 'x9999', 'boss@hq.example.org').
+staff(harry, 'Harry Ett',  3-14, 'x7654', 'h.ett@kit.example.org').
+

packages/http/examples/stress_client.pl

@@ -0,0 +1,52 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_stress_client,
+	  [ client/2,			% +Port, +Test
+	    client/3			% +Port, +Test, +Times
+	  ]).
+
+:- use_module(library(http/http_client)).
+
+/** <module> Sample HTTP client to run some stress tests
+
+*/
+
+client(Port, Action, Times) :-
+	forall(between(1, Times, _),
+	       client(Port, Action)).
+
+
+client(Port, ping) :-
+	http_get([ host(localhost),
+		   port(Port),
+		   path('/ping')
+		 ], _, []).

packages/http/examples/stress_server.pl

@@ -0,0 +1,129 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_stress_server,
+	  [ server/1,			% +Port
+	    profile/0
+	  ]).
+:- load_files([ library(http/thread_httpd),
+		library(http/html_write),
+		library(http/http_session),
+		library(http/http_dispatch),
+		library(http/http_parameters),
+		library(http/http_error),
+		library(thread_pool)
+	      ],
+	      [ silent(true)
+	      ]).
+
+/** <module> Sample HTTP server to run some stress tests
+
+*/
+
+%%	server(+Port) is det.
+%
+%	Start the server at Port.
+
+server(Port) :-
+	create_pools,
+	server(Port,
+	       [ workers(1)
+	       ]).
+
+server(Port, Options) :-
+	http_server(http_dispatch,
+		    [ port(Port),
+		      timeout(20)
+		    | Options
+		    ]).
+
+%%	create_pools
+%
+%	Create our thread pools.
+
+create_pools :-
+	thread_pool_create(single, 1, [backlog(0)]).
+
+%%	profile
+%
+%	Run thread profiler on the one and only server.
+
+profile :-
+	findall(Id, http_current_worker(_, Id), Ids),
+	(   Ids = [Id]
+	->  tprofile(Id)
+	;   Ids == []
+	->  format(user_error, 'No HTTP server!~n', []),
+	    fail
+	;   format(user_error, 'Multiple HTPP workers: ~p~n', [Ids]),
+	    fail
+	).
+
+
+		 /*******************************
+		 *	     METHODS		*
+		 *******************************/
+
+:- http_handler('/ping', ping, []).
+:- http_handler('/wait', wait, [chunked]).
+:- http_handler(prefix('/spawn/'), spawn, [spawn(single)]).
+:- http_handler(prefix('/spawn2/'), spawn, [spawn(single)]).
+
+ping(_Request) :-
+	format('Content-type: text/plain~n~n'),
+	format('alife~n').
+
+wait(Request) :-
+	http_parameters(Request,
+			[ wait(Time, [default(1)]),
+			  count(N, [default(10)])
+			]),
+	wait(Time, N).
+
+wait(Time, N) :-
+	format('Content-type: text/plain~n~n'),
+	forall(between(1, N, I),
+	       (   sleep(Time),
+		   format('~D~n', [I]),
+		   flush_output
+	       )).
+
+%%	spawn(+Request)
+%
+%	Run requests under /spawn/ in their own thread.
+
+spawn(Request) :-
+	selectchk(path(Path), Request, Request1),
+	(   sub_atom(Path, Start, _, _, /), Start > 0
+	->  sub_atom(Path, Start, _, 0, NewPath)
+	),
+	http_dispatch([path(NewPath)|Request1]).
+

packages/http/figs/.cvsignore

@@ -0,0 +1 @@
+*.pdf

packages/http/figs/httpserver.eps

@@ -0,0 +1,384 @@
+%!PS-Adobe-3.0 EPSF-3.0
+%%Creator: PCE 6.6.35, June 2007
+%%CreationDate: (Thu Jun  7 16:13:39 2007)
+%%Pages: 1
+%%DocumentFonts: (atend)
+%%BoundingBox: 70 70 570 361
+%%Object: @2548888/draw_canvas
+%%EndComments
+
+/draw
+	{ 0 currentlinewidth ne
+	  { currentdash 0 eq exch [] eq and not
+	    { gsave nodash 1 setgray stroke grestore
+	    } if
+	    stroke
+	  } if
+	} def
+
+/pspen
+	{ 2 div
+	} def
+
+/pen
+	{ pspen
+	  setlinewidth
+	} def
+
+/boxpath
+	{ /r exch def
+	  /h exch def
+	  /w exch def
+	  /y exch def
+	  /x exch def
+	  /p exch def
+	  
+	  r 0 eq
+	  { 2 setlinecap newpath
+	    x p pspen add y p pspen add moveto
+	    w p sub 0 rlineto
+	    0 h p sub rlineto
+	    w p sub neg 0 rlineto
+	    0 h p sub neg rlineto
+	  }
+	  { newpath
+	    /pr r p pspen add def
+	    x pr add y p pspen add moveto
+	    x w add pr sub	y pr add	r 270 360 arc
+	    x w add pr sub	y h add pr sub	r 0 90 arc
+	    x pr add		y h add pr sub  r 90 180 arc
+	    x pr add		y pr add	r 180 270 arc
+	  } ifelse
+	  
+	  p pen
+	} def
+
+/nodash
+	{ [] 0 setdash
+	} def
+
+/text
+	{ /s exch def
+	  /w exch def
+	  
+	  gsave
+	    1 eq { invert } if
+	    moveto s stringwidth pop w exch div -1 scale s show
+	  grestore
+	} def
+
+/startpath
+	{ newpath moveto pen
+	} def
+
+/linepath
+	{ /h exch def
+	  /w exch def
+	  newpath moveto w h rlineto
+	  pen
+	} def
+
+/dotted
+	{ [1 5] 0 setdash
+	} def
+
+gsave
+
+70 70 translate
+0.83 -0.83 scale
+-196 -425 translate
+%%EndProlog
+%%Page 0 1
+
+%%Object: @2548888/draw_canvas
+gsave 0 0 translate 0.00 0.00 0.00 setrgbcolor 
+
+%%Object: @2787654/cml_drole
+gsave 222 158 translate 
+
+%%Object: @2744708/box
+gsave  nodash 1 0 0 100 50 0 boxpath
+draw grestore
+
+%%Object: @2788290/draw_text
+grestore
+
+%%Object: @2788418/cml_drole
+gsave 222 158 translate 
+
+%%Object: @2744846/box
+gsave  nodash 1 0 0 100 50 0 boxpath
+draw grestore
+
+%%Object: @2788530/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+9 30 0 82 (thread_httpd.pl) text
+grestore
+grestore
+
+%%Object: @2788654/cml_drole
+gsave 222 241 translate 
+
+%%Object: @2795026/box
+gsave  nodash 1 0 0 100 50 0 boxpath
+draw grestore
+
+%%Object: @2795084/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+13 30 0 73 (xpce_httpd.pl) text
+grestore
+grestore
+
+%%Object: @2790930/cml_drole
+gsave 222 158 translate 
+
+%%Object: @2791042/box
+gsave  nodash 1 0 0 100 50 0 boxpath
+draw grestore
+
+%%Object: @2791100/draw_text
+grestore
+
+%%Object: @2791312/cml_drole
+gsave 222 325 translate 
+
+%%Object: @2791424/box
+gsave  nodash 1 0 0 100 50 0 boxpath
+draw grestore
+
+%%Object: @2791482/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+14 30 0 73 (inetd_httpd.pl) text
+grestore
+grestore
+
+%%Object: @2790756/cml_drole
+gsave 390 241 translate 
+
+%%Object: @2794830/box
+gsave  nodash 1 0 0 100 50 0 boxpath
+draw grestore
+
+%%Object: @2794888/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+8 30 0 84 (http_wrapper.pl) text
+grestore
+grestore
+
+%%Object: @2790850/draw_rect_connection
+gsave 
+grestore
+
+%%Object: @2795558/path
+gsave 0 0 translate  nodash 1 322 203 startpath
+ 356 203 lineto
+ 356 246 lineto 390 246 lineto
+draw
+
+%%Object: @draw_default_arrow/arrow
+gsave  nodash 0 pen newpath 380 249 moveto 390 246 lineto 380 243 lineto closepath gsave 0.00 setgray fill grestore
+ grestore
+grestore
+
+%%Object: @2790364/draw_rect_connection
+gsave 
+grestore
+
+%%Object: @2795684/path
+gsave 0 0 translate  nodash 1 322 266 startpath
+ 390 266 lineto
+
+draw
+
+%%Object: @draw_default_arrow/arrow
+gsave  nodash 0 pen newpath 380 269 moveto 390 266 lineto 380 263 lineto closepath gsave 0.00 setgray fill grestore
+ grestore
+grestore
+
+%%Object: @2791228/draw_rect_connection
+gsave 
+grestore
+
+%%Object: @2795816/path
+gsave 0 0 translate  nodash 1 322 330 startpath
+ 356 330 lineto
+ 356 286 lineto 390 286 lineto
+draw
+
+%%Object: @draw_default_arrow/arrow
+gsave  nodash 0 pen newpath 380 289 moveto 390 286 lineto 380 283 lineto closepath gsave 0.00 setgray fill grestore
+ grestore
+grestore
+
+%%Object: @2793566/cml_function
+gsave 681 165 translate 
+
+%%Object: @2793678/box
+gsave  nodash 1 0 0 100 50 25 boxpath
+draw grestore
+
+%%Object: @2793736/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+18 29 0 65 (handler_1/1) text
+grestore
+grestore
+
+%%Object: @2795976/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+205 387 0 134 (Unix inetd based servers) text
+grestore
+
+%%Object: @2796080/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+199 303 0 147 (XPCE event-driven servers) text
+grestore
+
+%%Object: @2796184/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+214 220 0 117 (Multi-threaded severs) text
+grestore
+
+%%Object: @2796288/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+668 115 0 126 (User's application code) text
+grestore
+
+%%Object: @2796392/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+385 115 0 77 (HTTP protocol) text
+grestore
+
+%%Object: @2796556/draw_line
+gsave 
+dotted 1 365 75 0 328 linepath draw
+grestore
+
+%%Object: @2796618/draw_line
+gsave 
+dotted 1 514 80 0 328 linepath draw
+grestore
+
+%%Object: @2796684/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+223 115 0 97 (Select server-type) text
+grestore
+
+%%Object: @2796788/draw_line
+gsave 
+dotted 1 649 78 0 328 linepath draw
+grestore
+
+%%Object: @2791796/cml_drole
+gsave 533 241 translate 
+
+%%Object: @2794634/box
+gsave  nodash 1 0 0 100 50 0 boxpath
+draw grestore
+
+%%Object: @2794692/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+8 29 0 85 (http_dispatch.pl) text
+grestore
+grestore
+
+%%Object: @2791606/draw_rect_connection
+gsave 
+grestore
+
+%%Object: @2796862/path
+gsave 0 0 translate  nodash 1 490 266 startpath
+ 533 266 lineto
+
+draw
+
+%%Object: @draw_default_arrow/arrow
+gsave  nodash 0 pen newpath 523 269 moveto 533 266 lineto 523 263 lineto closepath gsave 0.00 setgray fill grestore
+ grestore
+grestore
+
+%%Object: @2791890/draw_rect_connection
+gsave 
+grestore
+
+%%Object: @2797002/path
+gsave 0 0 translate  nodash 1 633 246 startpath
+ 657 246 lineto
+ 657 190 lineto 681 190 lineto
+draw
+
+%%Object: @draw_default_arrow/arrow
+gsave  nodash 0 pen newpath 671 193 moveto 681 190 lineto 671 187 lineto closepath gsave 0.00 setgray fill grestore
+ grestore
+grestore
+
+%%Object: @2793944/cml_function
+gsave 681 241 translate 
+
+%%Object: @2794056/box
+gsave  nodash 1 0 0 100 50 25 boxpath
+draw grestore
+
+%%Object: @2794114/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+18 29 0 65 (handler_2/1) text
+grestore
+grestore
+
+%%Object: @2793860/draw_rect_connection
+gsave 
+grestore
+
+%%Object: @2797162/path
+gsave 0 0 translate  nodash 1 633 266 startpath
+ 681 266 lineto
+
+draw
+
+%%Object: @draw_default_arrow/arrow
+gsave  nodash 0 pen newpath 671 269 moveto 681 266 lineto 671 263 lineto closepath gsave 0.00 setgray fill grestore
+ grestore
+grestore
+
+%%Object: @2794322/cml_function
+gsave 681 375 translate 
+
+%%Object: @2794434/box
+gsave  nodash 1 0 0 100 50 25 boxpath
+draw grestore
+
+%%Object: @2794492/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+18 29 0 65 (handler_n/1) text
+grestore
+grestore
+
+%%Object: @2794238/draw_rect_connection
+gsave 
+grestore
+
+%%Object: @2797294/path
+gsave 0 0 translate  nodash 1 633 286 startpath
+ 657 286 lineto
+ 657 400 lineto 681 400 lineto
+draw
+
+%%Object: @draw_default_arrow/arrow
+gsave  nodash 0 pen newpath 671 403 moveto 681 400 lineto 671 397 lineto closepath gsave 0.00 setgray fill grestore
+ grestore
+grestore
+
+%%Object: @2797450/draw_line
+gsave 
+dotted 1 731 305 0 50 linepath draw
+grestore
+
+%%Object: @2797582/draw_text
+gsave /Helvetica findfont 12 scalefont setfont
+543 115 0 80 (Dispatch paths) text
+grestore
+grestore
+
+%%Trailer
+grestore
+%%DocumentFonts:
+showpage

packages/http/html_head.pl

@@ -0,0 +1,503 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2009, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(html_head,
+	  [ html_resource/2,		% +Resource, +Attributes
+	    html_requires//1		% +Resource
+	  ]).
+:- use_module(library(http/html_write)).
+:- use_module(library(http/mimetype)).
+:- use_module(library(http/http_path)).
+:- use_module(library(error)).
+:- use_module(library(settings)).
+:- use_module(library(lists)).
+:- use_module(library(occurs)).
+:- use_module(library(option)).
+:- use_module(library(ordsets)).
+:- use_module(library(assoc)).
+:- use_module(library(ugraphs)).
+:- use_module(library(broadcast)).
+:- use_module(library(apply)).
+:- use_module(library(debug)).
+
+
+/** <module> Automatic inclusion of CSS and scripts links
+
+This library allows for  abstract  declaration   of  available  CSS  and
+Javascript resources and their dependencies using html_resource/2. Based
+on these declarations, html generating code  can declare that it depends
+on specific CSS or Javascript functionality,   after  which this library
+ensures  that  the  proper  links   appear    in   the  HTML  head.  The
+implementation is based on mail  system   implemented  by html_post/2 of
+library html_write.pl.
+
+Declarations come in two forms. First of all http locations are declared
+using the http_path.pl library. Second,   html_resource/2 specifies HTML
+resources to be used in the =head= and their dependencies. Resources are
+currently limited to Javascript files (.js)  and style sheets (.css). It
+is  trivial  to  add  support  for  other  material  in  the  head.  See
+html_include//1.
+
+For usage in HTML generation,  there   is  the DCG rule html_requires//1
+that demands named resources  in  the   HTML  head.
+
+---++ About resource ordering
+
+All calls to html_requires//1 for the page are collected and duplicates
+are removed.  Next, the following steps are taken:
+
+    1. Add all dependencies to the set
+    2. Replace multiple members by `aggregate' scripts or css files.
+       see use_agregates/4.
+    3. Order all resources by demanding that their dependencies
+       preceede the resource itself.  Note that the ordering of
+       resources in the dependency list is *ignored*.  This implies
+       that if the order matters the dependency list must be split
+       and only the primary dependency must be added.
+
+---++ Debugging dependencies
+
+Use ?- debug(html(script)). to  see  the   requested  and  final  set of
+resources. All declared resources  are   in  html_resource/3. The edit/1
+command recognises the names of HTML resources.
+
+@tbd	Possibly we should add img//2 to include images from symbolic
+	path notation.
+@tbd	It would be nice if the HTTP file server could use our location
+	declarations.
+*/
+
+:- dynamic
+	html_resource/3.		% Resource, Source, Properties
+
+%%	html_resource(+About, +Properties) is det.
+%
+%	Register an HTML head resource.  About   is  either an atom that
+%	specifies an HTTP location or  a   term  Alias(Sub).  This works
+%	similar to absolute_file_name/2.  See   http:location_path/2  for
+%	details.  Recognised properties are:
+%
+%		* requires(+Requirements)
+%		Other required script and css files.  If this is a plain
+%		file name, it is interpreted relative to the declared
+%		resource.  Requirements can be a list, which is equivalent
+%		to multiple requires properties.
+%
+%		* virtual(+Bool)
+%		If =true= (default =false=), do not include About itself,
+%		but only its dependencies.  This allows for defining an
+%		alias for one or more resources.
+%
+%		* aggregate(+List)
+%		States that About is an aggregate of the resources in
+%		List.
+
+html_resource(About, Properties) :-
+	source_location(File, Line), !,
+	retractall(html_resource(About, File:Line, _)),
+	assert_resource(About, File:Line, Properties).
+html_resource(About, Properties) :-
+	assert_resource(About, -, Properties).
+
+assert_resource(About, Location, Properties) :-
+	assert(html_resource(About, Location, Properties)),
+	clean_same_about_cache,
+	(   memberchk(aggregate(_), Properties)
+	->  clean_aggregate_cache
+	;   true
+	).
+
+
+%%	html_requires(+ResourceOrList)// is det.
+%
+%	Include ResourceOrList and all dependencies  derived from it and
+%	add them to the  HTML  =head=   using  html_post/2.  The  actual
+%	dependencies are computed  during  the   HTML  output  phase  by
+%	html_insert_resource//1.
+
+html_requires(Required) -->
+	html_post(head, 'html required'(Required)).
+
+:- multifile
+	html_write:html_head_expansion/2.
+
+html_write:html_head_expansion(In, Out) :-
+	require_commands(In, Required, Rest),
+	Required \== [], !,
+	flatten(Required, Plain),
+	Out = [ html_head:(\html_insert_resource(Plain))
+	      | Rest
+	      ].
+
+require_commands([], [], []).
+require_commands([_:('html required'(Required))|T0], [Required|TR], R) :- !,
+	require_commands(T0, TR, R).
+require_commands([R|T0], TR, [R|T]) :- !,
+	require_commands(T0, TR, T).
+
+
+%%	html_insert_resource(+ResourceOrList)// is det.
+%
+%	Actually   include   HTML   head   resources.   Called   through
+%	html_post//2   from   html_requires//1   after     rewrite    by
+%	html_head_expansion/2. We are guaranteed we   will  only get one
+%	call that is passed a flat   list  of requested requirements. We
+%	have three jobs:
+%
+%	    1. Figure out all indirect requirements
+%	    2. See whether we can use any `aggregate' resources
+%	    3. Put required resources before their requiree.
+
+html_insert_resource(Required) -->
+	{ requirements(Required, Paths),
+	  debug(html(script), 'Requirements: ~q~nFinal: ~q', [Required, Paths])
+	},
+	html_include(Paths).
+
+requirements(Required, Paths) :-
+	phrase(requires(Required), List),
+	sort(List, Paths0),		% remove duplicates
+	use_agregates(Paths0, Paths1, AggregatedBy),
+	order_html_resources(Paths1, AggregatedBy, Paths).
+
+%%	use_agregates(+Paths, -Aggregated, -AggregatedBy) is det.
+%
+%	Try to replace sets of  resources   by  an  `aggregate', a large
+%	javascript or css file that  combines   the  content of multiple
+%	small  ones  to  reduce  the  number   of  files  that  must  be
+%	transferred to the server. The current rule says that aggregates
+%	are used if at least half of the members are used.
+
+use_agregates(Paths, Aggregated, AggregatedBy) :-
+	empty_assoc(AggregatedBy0),
+	use_agregates(Paths, Aggregated, AggregatedBy0, AggregatedBy).
+
+use_agregates(Paths, Aggregated, AggregatedBy0, AggregatedBy) :-
+	current_aggregate(Aggregate, Parts, Size),
+	ord_subtract(Paths, Parts, NotCovered),
+	length(Paths, Len0),
+	length(NotCovered, Len1),
+	Covered is Len0-Len1,
+	Covered >= Size/2, !,
+	ord_add_element(NotCovered, Aggregate, NewPaths),
+	add_aggregated_by(Parts, AggregatedBy0, Aggregate, AggregatedBy1),
+	use_agregates(NewPaths, Aggregated, AggregatedBy1, AggregatedBy).
+use_agregates(Paths, Paths, AggregatedBy, AggregatedBy).
+
+add_aggregated_by([], Assoc, _, Assoc).
+add_aggregated_by([H|T], Assoc0, V, Assoc) :-
+	put_assoc(H, Assoc0, V, Assoc1),
+	add_aggregated_by(T, Assoc1, V, Assoc).
+
+
+:- dynamic
+	aggregate_cache_filled/0,
+	aggregate_cache/3.
+:- volatile
+	aggregate_cache_filled/0,
+	aggregate_cache/3.
+
+clean_aggregate_cache :-
+	retractall(aggregate_cache_filled).
+
+%%	current_aggregate(-Aggregate, -Parts, -Size) is nondet.
+%
+%	True if Aggregate is a defined   aggregate  with Size Parts. All
+%	parts are canonical absolute HTTP locations  and Parts is sorted
+%	to allow for processing using ordered set predicates.
+
+current_aggregate(Path, Parts, Size) :-
+	aggregate_cache_filled, !,
+	aggregate_cache(Path, Parts, Size).
+current_aggregate(Path, Parts, Size) :-
+	retractall(aggregate_cache(_,_, _)),
+	forall(uncached_aggregate(Path, Parts, Size),
+	       assert(aggregate_cache(Path, Parts, Size))),
+	assert(aggregate_cache_filled),
+	aggregate_cache(Path, Parts, Size).
+
+uncached_aggregate(Path, APartsS, Size) :-
+	html_resource(Aggregate, _, Properties),
+	memberchk(aggregate(Parts), Properties),
+	http_absolute_location(Aggregate, Path, []),
+	absolute_paths(Parts, Path, AParts),
+	sort(AParts, APartsS),
+	length(APartsS, Size).
+
+absolute_paths([], _, []).
+absolute_paths([H0|T0], Base, [H|T]) :-
+	http_absolute_location(H0, H, [relative_to(Base)]),
+	absolute_paths(T0, Base, T).
+
+
+%%	requires(+Spec)// is det.
+%%	requires(+Spec, +Base)// is det.
+%
+%	True if Files is the set of  files   that  need to be loaded for
+%	Spec. Note that Spec normally appears in  Files, but this is not
+%	necessary (i.e. virtual resources  or   the  usage  of aggregate
+%	resources).
+
+requires(Spec) -->
+	requires(Spec, /).
+
+requires([], _) --> !,
+	[].
+requires([H|T], Base) --> !,
+	requires(H, Base),
+	requires(T, Base).
+requires(Spec, Base) -->
+	requires(Spec, Base, true).
+
+requires(Spec, Base, Virtual) -->
+	{ res_properties(Spec, Properties),
+	  http_absolute_location(Spec, File, [relative_to(Base)])
+	},
+	(   { option(virtual(true), Properties)
+	    ; Virtual == false
+	    }
+	->  []
+	;   [File]
+	),
+	requires_from_properties(Properties, File).
+
+
+requires_from_properties([], _) -->
+	[].
+requires_from_properties([H|T], Base) -->
+	requires_from_property(H, Base),
+	requires_from_properties(T, Base).
+
+requires_from_property(requires(What), Base) --> !,
+	requires(What, Base).
+requires_from_property(_, _) -->
+	[].
+
+
+%%	order_html_resources(+Requirements, +AggregatedBy, -Ordered) is det.
+%
+%	Establish a proper order for the   collected (sorted and unique)
+%	list of Requirements.
+
+order_html_resources(Requirements, AggregatedBy, Ordered) :-
+	requirements_graph(Requirements, AggregatedBy, Graph),
+	(   top_sort(Graph, Ordered)
+	->  true
+	;   connect_graph(Graph, Start, Connected),
+	    top_sort(Connected, Ordered0),
+	    Ordered0 = [Start|Ordered]
+	).
+
+%%	requirements_graph(+Requirements, +AggregatedBy, -Graph) is det.
+%
+%	Produce an S-graph (see library(ugraphs))   that  represents the
+%	dependencies  in  the  list  of  Requirements.  Edges  run  from
+%	required to requirer.
+
+requirements_graph(Requirements, AggregatedBy, Graph) :-
+	phrase(prerequisites(Requirements, AggregatedBy, Vertices, []), Edges),
+	vertices_edges_to_ugraph(Vertices, Edges, Graph).
+
+prerequisites([], _, Vs, Vs) -->
+	[].
+prerequisites([R|T], AggregatedBy, Vs, Vt) -->
+	prerequisites_for(R, AggregatedBy, Vs, Vt0),
+	prerequisites(T, AggregatedBy, Vt0, Vt).
+
+prerequisites_for(R, AggregatedBy, Vs, Vt) -->
+	{ phrase(requires(R, /, false), Req) },
+	(   {Req == []}
+	->  {Vs = [R|Vt]}
+	;   req_edges(Req, AggregatedBy, R),
+	    {Vs = Vt}
+	).
+
+req_edges([], _, _) -->
+	[].
+req_edges([H|T], AggregatedBy, R) -->
+	(   { get_assoc(H, AggregatedBy, Aggregate) }
+	->  [Aggregate-R]
+	;   [H-R]
+	),
+	req_edges(T, AggregatedBy, R).
+
+
+%%	connect_graph(+Graph, -Start, -Connected) is det.
+%
+%	Turn Graph into a connected graph   by putting a shared starting
+%	point before all vertices.
+
+connect_graph([], 0, []) :- !.
+connect_graph(Graph, Start, [Start-Vertices|Graph]) :-
+	vertices(Graph, Vertices),
+	Vertices = [First|_],
+	before(First, Start).
+
+%%	before(+Term, -Before) is det.
+%
+%	Unify Before to a term that comes   before  Term in the standard
+%	order of terms.
+%
+%	@error instantiation_error if Term is unbound.
+
+before(X, _) :-
+	var(X), !,
+	instantiation_error(X).
+before(Number, Start) :-
+	number(Number), !,
+	Start is Number - 1.
+before(_, 0).
+
+
+%%	res_properties(+Spec, -Properties) is det.
+%
+%	True if Properties is the set of defined properties on Spec.
+
+res_properties(Spec, Properties) :-
+	findall(P, res_property(Spec, P), Properties0),
+	list_to_set(Properties0, Properties).
+
+res_property(Spec, Property) :-
+	same_about(Spec, About),
+	html_resource(About, _, Properties),
+	member(Property, Properties).
+
+:- dynamic
+	same_about_cache/2.
+:- volatile
+	same_about_cache/2.
+
+clean_same_about_cache :-
+	retractall(same_about_cache(_,_)).
+
+same_about(Spec, About) :-
+	same_about_cache(Spec, Same), !,
+	member(About, Same).
+same_about(Spec, About) :-
+	findall(A, uncached_same_about(Spec, A), List),
+	assert(same_about_cache(Spec, List)),
+	member(About, List).
+
+uncached_same_about(Spec, About) :-
+	html_resource(About, _, _),
+	same_resource(Spec, About).
+
+
+%%	same_resource(+R1, +R2) is semidet.
+%
+%	True if R1 an R2 represent  the   same  resource.  R1 and R2 are
+%	resource specifications are defined by http_absolute_location/3.
+
+same_resource(R, R) :- !.
+same_resource(R1, R2) :-
+	resource_base_name(R1, B),
+	resource_base_name(R2, B),
+	http_absolute_location(R1, Path, []),
+	http_absolute_location(R2, Path, []).
+
+:- dynamic
+	base_cache/2.
+:- volatile
+	base_cache/2.
+
+resource_base_name(Spec, Base) :-
+	(   base_cache(Spec, Base0)
+	->  Base = Base0
+	;   uncached_resource_base_name(Spec, Base0),
+	    assert(base_cache(Spec, Base0)),
+	    Base = Base0
+	).
+
+uncached_resource_base_name(Atom, Base) :-
+	atomic(Atom), !,
+	file_base_name(Atom, Base).
+uncached_resource_base_name(Compound, Base) :-
+	arg(1, Compound, Base0),
+	file_base_name(Base0, Base).
+
+%%	html_include(+PathOrList)// is det.
+%
+%	Include to HTML resources  that  must   be  in  the  HTML <head>
+%	element. Currently onlu supports  =|.js|=   and  =|.css|= files.
+%	Extend this to support more  header   material.  Do not use this
+%	predicate directly. html_requires//1 is the  public interface to
+%	include HTML resources.
+%
+%	@param	HTTP location or list of these.
+
+html_include([]) --> !.
+html_include([H|T]) --> !,
+	html_include(H),
+	html_include(T).
+html_include(Path) -->
+	{ file_mime_type(Path, Mime) }, !,
+	html_include(Mime, Path).
+
+html_include(text/css, Path) --> !,
+	html(link([ rel(stylesheet),
+		    type('text/css'),
+		    href(Path)
+		  ], [])).
+html_include(text/javascript, Path) --> !,
+	html(script([ type('text/javascript'),
+		      src(Path)
+		    ], [])).
+html_include(Mime, Path) -->
+	{ print_message(warning, html_include(dont_know, Mime, Path))
+	}.
+
+
+		 /*******************************
+		 *	  CACHE CLEANUP		*
+		 *******************************/
+
+:- multifile
+	user:message_hook/3.
+:- dynamic
+	user:message_hook/3.
+
+user:message_hook(make(done(Reload)), _Level, _Lines) :-
+	Reload \== [],
+	clean_same_about_cache,
+	clean_aggregate_cache,
+	fail.
+
+
+		 /*******************************
+		 *	       EDIT		*
+		 *******************************/
+
+% Allow edit(Location) to edit the :- html_resource declaration.
+:- multifile
+	prolog_edit:locate/3.
+
+prolog_edit:locate(Path, html_resource(Spec), [file(File), line(Line)]) :-
+	atom(Path),
+	html_resource(Spec, File:Line, _Properties),
+	sub_term(Path, Spec).

packages/http/http_authenticate.pl

@@ -0,0 +1,221 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2007, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+
+:- module(authenticate,
+	  [ http_authenticate/3		% +Check, +Header, -User
+	  ]).
+:- use_module(library(base64)).
+:- use_module(library('http/dcg_basics')).
+:- use_module(library(readutil)).
+:- use_module(library(crypt)).
+:- use_module(library(debug)).
+
+/**	<module> Authenticate HTTP connections using 401 headers
+
+This module provides the basics  to   validate  an  HTTP =Authorization=
+error. User and  password  information  are   read  from  a  Unix/Apache
+compatible password file. This information, as   well  as the validation
+process is cached to achieve optimal performance.
+
+@author	Jan Wielemaker
+*/
+
+%%	http_authenticate(+Type, +Request, -Fields)
+%
+%	True if Request contains the   information to continue according
+%	to Type. Type identifies the required authentication technique:
+%
+%		* basic(+PasswordFile)
+%		Use HTTP =Basic= authetication and verify the password
+%		from PasswordFile. PasswordFile is a file holding
+%		usernames and passwords in a format compatible to
+%		Unix and Apache. Each line is record with =|:|=
+%		separated fields. The first field is the username and
+%		the second the password _hash_.  Password hashes are
+%		validated using crypt/2.
+%
+%	Successful authorization is  cached  for   60  seconds  to avoid
+%	overhead of decoding and lookup of the user and password data.
+%
+%	http_authenticate/3 just validates the  header. If authorization
+%	is not provided the browser must   be challenged, in response to
+%	which it normally opens a   user-password dialogue. Example code
+%	realising this is below. The exception   causes the HTTP wrapper
+%	code to generate an HTTP 401 reply.
+%
+%	==
+%	(   http_authenticate(basic(passwd), Request, Fields)
+%	->  true
+%	;   throw(http_reply(authorise(basic, Realm)))
+%	).
+%	==
+%
+%	@tbd	Should we also cache failures to reduce the risc of
+%		DoS attacks?
+
+http_authenticate(basic(File), Request, [user(User)]) :-
+	memberchk(authorization(Text), Request),
+	debug(http_authenticate, 'Authorization: ~w', [Text]),
+	(   cached_authenticated(Text, File, User)
+	->  true
+	;   user_and_passwd(Text, Method, UserChars, Password),
+	    downcase_atom(Method, basic),
+	    debug(http_authenticate,
+		  'User: ~s, Password: ~s', [UserChars, Password]),
+	    atom_codes(User, UserChars),
+	    validate(File, User, Password),
+	    get_time(Now),
+	    assert(authenticated(Text, File, User, Now)),
+	    debug(http_authenticate, 'Authenticated ~w~n', [User])
+	).
+
+%%	user_and_passwd(+AuthorizeText, -Method, -User, -Password) is det.
+%
+%	Decode the HTTP =Authorization= header.
+
+user_and_passwd(Text, Method, User, Password) :-
+	atom_codes(Text, Codes),
+	phrase(authorization(Method, Cookie), Codes),
+	phrase(base64(UserPwd), Cookie),
+	phrase(ident(User, Password), UserPwd).
+
+authorization(Method, Cookie) -->
+	nonblanks(MethodChars),
+	{ atom_codes(Method, MethodChars)
+	},
+	blanks,
+	nonblanks(Cookie),
+	blanks.
+
+ident(User, Password) -->
+	string(User),
+	":",
+	string(Password).
+
+%%	cached_authenticated(+Authorization, +File, -User)
+%
+%	Validate using the cache. If the entry   is not in the cache, we
+%	also remove all outdated entries from the cache.
+
+:- dynamic
+	authenticated/4.		% Authorization, File, User, Time
+
+cached_authenticated(Authorization, File, User) :-
+	authenticated(Authorization, File, User, Time),
+	get_time(Now),
+	Now-Time =< 60, !.		% 60-second timeout
+cached_authenticated(_, _, _) :-
+	get_time(Now),
+	(   clause(authenticated(_, _, _, Time), true, Ref),
+	    Now-Time > 60,
+	    erase(Ref),
+	    fail
+	).
+
+
+%%	validate(+File, +User, +Passwd)
+%
+%	True if User and Passwd combination   appears in File. File uses
+%	the same format as .htaccess files  from Apache or Unix password
+%	files. I.e. it consists  of  one   line  per  entry  with fields
+%	separated by =|:|=. The  first  field   is  the  User field, The
+%	second contains the Passwd in DES   or MD5 encrypted format. See
+%	crypt/2 for details.
+
+validate(File, User, Password) :-
+	update_passwd(File, Path),
+	passwd(User, Path, Hash),
+	crypt(Password, Hash).
+
+%%	update_passwd(+File, -Path) is det.
+%
+%	Update passwd/3 to reflect the correct  passwords for File. Path
+%	is the absolute path for File.
+
+:- dynamic
+	passwd/3,			% User, File, Encrypted
+	last_modified/2.		% File, Stamp
+
+update_passwd(File, Path) :-
+	absolute_file_name(File, Path, [access(read)]),
+	time_file(Path, Stamp),
+	(   last_modified(Path, Stamp)
+	->  true
+	;   with_mutex(http_passwd, reload_passwd_file(Path, Stamp))
+	).
+
+reload_passwd_file(Path, Stamp) :-
+	last_modified(Path, Stamp), !.	% another thread did the work
+reload_passwd_file(Path, Stamp) :-
+	retractall(last_modified(Path, _)),
+	retractall(passwd(_, Path, _)),
+	open(Path, read, Fd),
+	read_line_to_codes(Fd, Line),
+	read_passwd_file(Line, Fd, Path),
+	close(Fd),
+	assert(last_modified(Path, Stamp)).
+
+read_passwd_file(end_of_file, _, _) :- !.
+read_passwd_file(Line, Fd, Path) :-
+	(   phrase(password_line(User, Hash), Line, _)
+	->  assert(passwd(User, Path, Hash))
+	;   true			% TBD: warning
+	),
+	read_line_to_codes(Fd, Line2),
+	read_passwd_file(Line2, Fd, Path).
+
+
+password_line(User, Hash) -->
+	string(UserCodes),
+	":",
+	string(HashCodes),
+	(   ":"
+	;   eos
+	), !,
+	{ atom_codes(User, UserCodes),
+	  atom_codes(Hash, HashCodes)
+	}.
+
+
+		 /*******************************
+		 *   PLUGIN FOR HTTP_DISPATCH   *
+		 *******************************/
+
+:- multifile
+	http:authenticate/3.
+
+http:authenticate(basic(File, Realm), Request, User) :-
+	(   http_authenticate(basic(File), Request, User)
+	->  true
+	;   throw(http_reply(authorise(basic, Realm)))
+	).
+

packages/http/http_chunked.c

@@ -0,0 +1,293 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2007-2009, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*/
+
+#define O_DEBUG 1
+#include <SWI-Stream.h>
+#include <SWI-Prolog.h>
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <time.h>
+#include <errno.h>
+
+#define MAXHDR 1024			/* max size of chink header line */
+
+static atom_t ATOM_close_parent;	/* close_parent(Bool) */
+static atom_t ATOM_max_chunk_size;	/* max_chunk_size(Int) */
+
+
+		 /*******************************
+		 *	       TYPES		*
+		 *******************************/
+
+#define BUFSIZE SIO_BUFSIZE		/* raw I/O buffer */
+
+typedef struct chunked_context
+{ IOSTREAM	   *stream;		/* Original stream */
+  IOSTREAM	   *chunked_stream;	/* Stream I'm handle of */
+  int		    close_parent;	/* close parent on close */
+  IOENC		    parent_encoding;	/* Saved encoding of parent */
+  size_t	    avail;		/* data available */
+} chunked_context;
+
+
+static chunked_context*
+alloc_chunked_context(IOSTREAM *s)
+{ chunked_context *ctx = PL_malloc(sizeof(*ctx));
+
+  memset(ctx, 0, sizeof(*ctx));
+  ctx->stream       = s;
+  ctx->close_parent = FALSE;
+
+  return ctx;
+}
+
+
+static void
+free_chunked_context(chunked_context *ctx)
+{ if ( ctx->stream->upstream )
+    Sset_filter(ctx->stream, NULL);
+  else
+    PL_release_stream(ctx->stream);
+
+  PL_free(ctx);
+}
+
+
+		 /*******************************
+		 *	    CHUNKED I/O		*
+		 *******************************/
+
+static ssize_t				/* decode */
+chunked_read(void *handle, char *buf, size_t size)
+{ chunked_context *ctx = handle;
+
+  for(;;)
+  { if ( ctx->avail > 0 )			/* data waiting */
+    { size_t  max_rd = ctx->avail < size ? ctx->avail : size;
+      ssize_t rc;
+
+      if ( (rc = Sfread(buf, sizeof(char), max_rd, ctx->stream)) > 0 )
+      { ctx->avail -= rc;
+
+	if ( ctx->avail == 0 )
+	{ if ( Sgetc(ctx->stream) != '\r' ||
+	       Sgetc(ctx->stream) != '\n' )
+	  { Sseterr(ctx->chunked_stream, 0, "Chunk not followed by \\r\\n");
+	    return -1;
+	  }
+	}
+
+	return rc;
+      } else if ( rc == 0 )
+      { Sseterr(ctx->chunked_stream, 0, "Unexpected EOF in chunked data");
+	return -1;
+      } else
+      { return -1;
+      }
+    } else
+    { char hdr[MAXHDR];
+      char *s;
+
+
+      if ( (s = Sfgets(hdr, sizeof(hdr), ctx->stream)) )
+      { char *ehdr;
+	long len;
+
+	errno = 0;
+	len = strtol(hdr, &ehdr, 16);
+	if ( errno || len < 0 )
+	{ Sseterr(ctx->chunked_stream, 0, "Bad chunk length");
+	  return -1;
+	}
+	if ( len == 0 )
+	{ do
+	  { s = Sfgets(hdr, sizeof(hdr), ctx->stream);
+	  } while ( s && strcmp(s, "\r\n") != 0 );
+	  if ( s )
+	    return 0;
+	  Sseterr(ctx->chunked_stream, 0, "Bad end-of-stream");
+	  return -1;
+	}
+	ctx->avail = len;
+	/*continue*/
+      }
+    }
+  }
+}
+
+
+static ssize_t				/* encode */
+chunked_write(void *handle, char *buf, size_t size)
+{ chunked_context *ctx = handle;
+
+  if ( Sfprintf(ctx->stream, "%x\r\n", size) >= 0 &&
+       Sfwrite(buf, sizeof(char), size, ctx->stream) == size &&
+       Sfprintf(ctx->stream, "\r\n") >= 0 )
+    return size;
+
+  return -1;
+}
+
+
+static int
+chunked_control(void *handle, int op, void *data)
+{ chunked_context *ctx = handle;
+
+  switch(op)
+  { case SIO_FLUSHOUTPUT:
+    case SIO_SETENCODING:
+      return 0;				/* allow switching encoding */
+    default:
+      if ( ctx->stream->functions->control )
+	return (*ctx->stream->functions->control)(ctx->stream->handle, op, data);
+      return -1;
+  }
+}
+
+
+static int
+chunked_close(void *handle)
+{ chunked_context *ctx = handle;
+  int rc = 0;
+
+  DEBUG(1, Sdprintf("chunked_close() ...\n"));
+
+  if ( (ctx->chunked_stream->flags & SIO_OUTPUT) )
+  { if ( Sfprintf(ctx->stream, "0\r\n\r\n") < 0 )
+      rc = -1;
+  }
+
+  ctx->stream->encoding = ctx->parent_encoding;
+
+  if ( ctx->close_parent )
+  { IOSTREAM *parent = ctx->stream;
+    int rc2;
+
+    free_chunked_context(ctx);
+    rc2 = Sclose(parent);
+    if ( rc == 0 )
+      rc = rc2;
+  } else
+  { free_chunked_context(ctx);
+  }
+
+  return rc;
+}
+
+
+static IOFUNCTIONS chunked_functions =
+{ chunked_read,
+  chunked_write,
+  NULL,					/* seek */
+  chunked_close,
+  chunked_control,			/* zcontrol */
+  NULL,					/* seek64 */
+};
+
+
+		 /*******************************
+		 *	 PROLOG CONNECTION	*
+		 *******************************/
+
+#define COPY_FLAGS (SIO_INPUT|SIO_OUTPUT| \
+		    SIO_TEXT| \
+		    SIO_REPXML|SIO_REPPL|\
+		    SIO_RECORDPOS)
+
+static foreign_t
+pl_http_chunked_open(term_t org, term_t new, term_t options)
+{ term_t tail = PL_copy_term_ref(options);
+  term_t head = PL_new_term_ref();
+  chunked_context *ctx;
+  IOSTREAM *s, *s2;
+  int close_parent = FALSE;
+  int max_chunk_size = 0;
+
+  while(PL_get_list(tail, head, tail))
+  { atom_t name;
+    int arity;
+    term_t arg = PL_new_term_ref();
+
+    if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
+      return type_error(head, "option");
+    _PL_get_arg(1, head, arg);
+
+    if ( name == ATOM_max_chunk_size )
+    { if ( !get_int_ex(arg, &max_chunk_size) )
+	return FALSE;
+      if ( max_chunk_size <= 0 )
+	return domain_error(arg, "positive_integer");
+    } else if ( name == ATOM_close_parent )
+    { if ( !get_bool_ex(arg, &close_parent) )
+	return FALSE;
+    }
+  }
+  if ( !PL_get_nil(tail) )
+    return type_error(tail, "list");
+
+  if ( !PL_get_stream_handle(org, &s) )
+    return FALSE;			/* Error */
+  ctx = alloc_chunked_context(s);
+  ctx->close_parent = close_parent;
+
+  if ( !(s2 = Snew(ctx,
+		   (s->flags&COPY_FLAGS)|SIO_FBUF,
+		   &chunked_functions))	)
+  { free_chunked_context(ctx);			/* no memory */
+
+    return FALSE;
+  }
+
+  if ( max_chunk_size > 0 )
+  { char *buf = PL_malloc(max_chunk_size);
+    Ssetbuffer(s2, buf, max_chunk_size);
+  }
+
+  s2->encoding = s->encoding;
+  ctx->parent_encoding = s->encoding;
+  s->encoding = ENC_OCTET;
+  ctx->chunked_stream = s2;
+  if ( PL_unify_stream(new, s2) )
+  { Sset_filter(s, s2);
+    PL_release_stream(s);
+
+    return TRUE;
+  } else
+  { return instantiation_error();
+  }
+}
+
+
+		 /*******************************
+		 *	       INSTALL		*
+		 *******************************/
+
+static void
+install_http_chunked()
+{ ATOM_close_parent   = PL_new_atom("close_parent");
+  ATOM_max_chunk_size = PL_new_atom("max_chunk_size");
+
+  PL_register_foreign("http_chunked_open",  3, pl_http_chunked_open,  0);
+}

packages/http/http_client.pl

@@ -0,0 +1,482 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2010, University of Amsterdam, VU University Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+
+:- module(http_client,
+	  [ http_get/3,			% +URL, -Reply, +Options
+	    http_delete/3,		% +URL, -Reply, +Options
+	    http_post/4,		% +URL, +In, -Reply, +Options
+	    http_put/4,			% +URL, +In, -Reply, +Options
+	    http_read_data/3,		% +Header, -Data, +Options
+	    http_disconnect/1		% +What
+	  ]).
+:- use_module(library(socket)).
+:- use_module(library(url)).
+:- use_module(http_header).
+:- use_module(http_stream).
+:- use_module(library(debug)).
+:- use_module(library(memfile)).
+:- use_module(library(lists)).
+:- use_module(library(error)).
+:- use_module(library(option)).
+:- use_module(dcg_basics).
+
+:- multifile
+	http_convert_data/4,		% http_read_data plugin-hook
+	post_data_hook/3,		% http_post_data/3 hook
+	open_connection/4,		% do_connect/5 hook
+	close_connection/4.
+
+%%	open_connection(+Scheme, +Address, -In, -Out) is semidet.
+%
+%	Hook to open a connection for the  given URL-scheme to the given
+%	address. If successful, In and  Out   must  be  two valid Prolog
+%	streams that connect to the server.
+%
+%	@param Scheme is the URL schema (=http= or =https=)
+%	@param Address is a term Host:Port as used by tcp_connect/4.
+
+%%	close_connection(+Scheme, +Address, +In, +Out) is semidet.
+%
+%	Hook to close a specific connection.   If the hook succeeds, the
+%	HTTP client assumes that In and Out are no longer to be used. If
+%	the hook fails, the client calls close/2 on both streams.
+
+:- dynamic
+	connection/5.			% Host:Port, Protocol, Thread, In, Out
+
+:- expects_dialect(swi).
+:- assert(system:swi_io).
+
+user_agent('SWI-Prolog (http://www.swi-prolog.org)').
+
+%%	connect(+UrlParts, -Read, -Write, +Options) is det.
+%%	disconnect(+UrlParts) is det.
+%
+%	Connect/disconnect on the basis of a parsed URL.
+
+connect(Parts, Read, Write, _) :-
+	memberchk(socket(Read, Write), Parts), !.
+connect(Parts, Read, Write, Options) :-
+	address(Parts, Address, Protocol, Options),
+	with_mutex(http_client_connect,
+		   connect2(Address, Protocol, Read, Write, Options)).
+
+connect2(Address, Protocol, In, Out, _) :-
+	thread_self(Self),
+	connection(Address, Protocol, Self, In, Out), !.
+connect2(Address, Protocol, In, Out, Options) :-
+	thread_self(Self),
+	do_connect(Address, Protocol, In, Out, Options),
+	assert(connection(Address, Protocol, Self, In, Out)).
+
+do_connect(Address, Protocol, In, Out, Options) :-
+	debug(http(client), 'http_client: Connecting to ~p ...', [Address]),
+	(   open_connection(Protocol, Address, In, Out)
+	->  true
+	;   tcp_socket(Socket),
+	    catch(tcp_connect(Socket, Address, In, Out),
+		  E,
+		  (   tcp_close_socket(Socket),
+		      throw(E)
+		  ))
+	),
+	debug(http(client), '\tok ~p --> ~p', [In, Out]),
+	(   memberchk(timeout(Timeout), Options)
+        ->  set_stream(In, timeout(Timeout))
+        ;   true
+	), !.
+do_connect(Address, _, _, _, _) :-		% can this happen!?
+	throw(error(failed(connect, Address), _)).
+
+
+disconnect(Parts) :-
+	protocol(Parts, Protocol),
+	address(Parts, Protocol, Address, []), !,
+	disconnect(Address, Protocol).
+
+disconnect(Address, Protocol) :-
+	with_mutex(http_client_connect,
+		   disconnect_locked(Address, Protocol)).
+
+disconnect_locked(Address, Protocol) :-
+	thread_self(Me),
+	debug(connection, '~w: Closing connection to ~w~n', [Me, Address]),
+	thread_self(Self),
+	retract(connection(Address, Protocol, Self, In, Out)), !,
+	disconnect(Protocol, Address, In, Out).
+
+disconnect(Protocol, Address, In, Out) :-
+	close_connection(Protocol, Address, In, Out), !.
+disconnect(_, _, In, Out) :-
+	close(Out, [force(true)]),
+	close(In,  [force(true)]).
+
+%%	http_disconnect(+Connections) is det.
+%
+%	Close down some connections. Currently Connections must have the
+%	value =all=, closing all connections.
+
+http_disconnect(all) :-
+	(   thread_self(Self),
+	    connection(Address, Protocol, Self, _, _),
+	    disconnect(Address, Protocol),
+	    fail
+	;   true
+	).
+
+address(_Parts, Host:Port, Protocol, Options) :-
+	(   memberchk(proxy(Host, Port, Protocol), Options)
+	->  true
+	;   memberchk(proxy(Host, Port), Options),
+	    Protocol = http
+	).
+address(Parts, Host:Port, Protocol, _Options) :-
+	memberchk(host(Host), Parts),
+	port(Parts, Port),
+	protocol(Parts, Protocol).
+
+port(Parts, Port) :-
+	memberchk(port(Port), Parts), !.
+port(Parts, 80) :-
+	memberchk(protocol(http), Parts).
+
+protocol(Parts, Protocol) :-
+	memberchk(protocol(Protocol), Parts), !.
+protocol(_, http).
+
+		 /*******************************
+		 *	        GET		*
+		 *******************************/
+
+%%	http_delete(+URL, -Data, +Options) is det.
+%
+%	Execute a DELETE method on the server.
+%
+%	@tbd Properly map the 201, 202 and 204 replies.
+
+http_delete(URL, Data, Options) :-
+	http_get(URL, Data, [method('DELETE')|Options]).
+
+
+%%	http_get(+URL, -Data, +Options) is det.
+%
+%	Get data from an HTTP server.
+
+http_get(URL, Data, Options) :-
+	atomic(URL), !,
+	parse_url(URL, Parts),
+        http_get(Parts, Data, Options).
+http_get(Parts, Data, Options) :-
+	must_be(list, Options),
+	memberchk(connection(Connection), Options),
+	downcase_atom(Connection, 'keep-alive'), !,
+	between(0, 1, _),
+	catch(http_do_get(Parts, Data, Options), E,
+	      (	  message_to_string(E, Msg),
+	          debug(keep_alive, 'Error: ~w; retrying~n', [Msg]),
+	          disconnect(Parts),
+		  fail
+	      )), !.
+http_get(Parts, Data, Options) :-
+	address(Parts, Address, Protocol, Options),
+	do_connect(Address, Protocol, Read, Write, Options),
+	call_cleanup(http_do_get([socket(Read, Write)|Parts], Data, Options),
+		     disconnect(Protocol, Address, Read, Write)).
+
+http_do_get(Parts, Data, Options) :-
+	connect(Parts, Read, Write, Options),
+	(   select(proxy(_,_), Options, Options1)
+	->  parse_url(Location, Parts)
+	;   http_location(Parts, Location),
+	    Options1 = Options
+	),
+	memberchk(host(Host), Parts),
+	option(method(Method), Options, 'GET'),
+	http_write_header(Write, Method, Location, Host,
+			  Options1, ReplyOptions),
+	write(Write, '\r\n'),
+	flush_output(Write),
+	http_read_reply(Read, Data0, ReplyOptions), !,
+	(   Data0 = redirect(Redirect),
+	    nonvar(Redirect)
+	->  debug(http(redirect), 'Redirect to ~w', [Redirect]),
+	    parse_url(Redirect, Parts, NewParts),
+	    http_get(NewParts, Data, Options)
+	;   Data = Data0
+	).
+http_do_get(Parts, _Data, _Options) :-
+	throw(error(failed(http_get, Parts), _)).
+
+http_read_reply(In, Data, Options) :-
+	between(0, 1, _),
+	    http_read_reply_header(In, Fields),
+	\+ memberchk(status(continue, _), Fields), !,
+	(   memberchk(location(Location), Fields),
+	    (   memberchk(status(moved, _), Fields)
+	    ;	memberchk(status(moved_temporary, _), Fields)
+	    ;	memberchk(status(see_other, _), Fields)
+	    )
+	->  Data = redirect(Location)
+	;   (   select(reply_header(Fields), Options, ReadOptions)
+	    ->  true
+	    ;   ReadOptions = Options
+	    ),
+	    http_read_data(In, Fields, Data, ReadOptions)
+	),
+	(   memberchk(connection(Connection), Fields),
+	    downcase_atom(Connection, 'keep-alive')
+	->  true
+	;   thread_self(Self),
+	    connection(Address, Protocol, Self, In, _Out)
+	->  disconnect(Address, Protocol)
+	;   true
+	).
+http_read_reply(In, _Data, _Options) :-
+	format(user_error, 'Get FAILED~n', []),
+	throw(error(failed(read_reply, In), _)).
+
+
+%%	http_write_header(+Out, +Method, +Location,
+%%			  +Host, +Options, -RestOptions) is det.
+%
+%	Write the request header.  It accepts the following options:
+%
+%		* http_version(Major-Minor)
+%		* connection(Connection)
+%		* user_agent(Agent)
+%		* request_header(Name=Value)
+%
+%	Remaining options are returned in RestOptions.
+
+http_write_header(Out, Method, Location, Host, Options, RestOptions) :-
+	(   select(http_version(Major-Minor), Options, Options1)
+	->  true
+	;   Major = 1, Minor = 1,
+	    Options1 = Options
+	),
+	format(Out, '~w ~w HTTP/~w.~w\r\n', [Method, Location, Major, Minor]),
+	format(Out, 'Host: ~w\r\n', [Host]),
+	(   select(connection(Connection), Options1, Options2)
+	->  true
+	;   Connection = 'Keep-Alive',
+	    Options2 = Options1
+	),
+	(   select(user_agent(Agent), Options2, Options3)
+	->  true
+	;   user_agent(Agent),
+	    Options3 = Options2
+	),
+	format(Out, 'User-Agent: ~w\r\n\
+		     Connection: ~w\r\n', [Agent, Connection]),
+	x_headers(Options3, Out, RestOptions).
+
+%%	x_headers(+Options, +Out, -RestOptions) is det.
+%
+%	Pass additional request options.  For example:
+%
+%		request_header('Accept-Language' = 'nl, en')
+%
+%	No checking is performed on the fieldname or value. Both are
+%	copied literally and in the order of appearance to the request.
+
+x_headers([], _, []).
+x_headers([H|T0], Out, Options) :-
+	x_header(H, Out), !,
+	x_headers(T0, Out, Options).
+x_headers([H|T0], Out, [H|T]) :-
+	x_headers(T0, Out, T).
+
+x_header(request_header(Name=Value), Out) :-
+	format(Out, '~w: ~w\r\n', [Name, Value]).
+x_header(proxy_authorization(ProxyAuthorization), Out) :-
+	proxy_auth_header(ProxyAuthorization, Out).
+x_header(range(Spec), Out) :-
+	Spec =.. [Unit, From, To],
+	(   To == end
+	->  ToT = ''
+	;   must_be(integer, To),
+	    ToT = To
+	),
+	format(Out, 'Range: ~w=~d-~w\r\n', [Unit, From, ToT]).
+
+proxy_auth_header(basic(User, Password), Out) :- !,
+	format(codes(Codes), '~w:~w', [User, Password]),
+	phrase(base64(Codes), Base64Codes),
+	format(Out, 'Proxy-Authorization: basic ~s\r\n', [Base64Codes]).
+proxy_auth_header(Auth, _) :-
+	domain_error(authorization, Auth).
+
+%%	http_read_data(+Fields, -Data, +Options) is det.
+%
+%	Read data from an HTTP connection.   Options must contain a term
+%	input(In) that provides the input stream   from the HTTP server.
+%	Fields is the parsed http  reply-header. Options is one of:
+%
+%		* to(stream(+WriteStream))
+%		Append the content of the message to Stream
+%		* to(atom)
+%		Return the reply as an atom
+%		* to(codes)
+%		Return the reply as a list of codes
+
+http_read_data(Fields, Data, Options) :-
+	memberchk(input(In), Fields),
+	(   http_read_data(In, Fields, Data, Options)
+	->  true
+	;   throw(error(failed(http_read_data), _))
+	).
+
+
+http_read_data(In, Fields, Data, Options) :-	% Transfer-encoding: chunked
+	select(transfer_encoding(chunked), Fields, RestFields), !,
+	http_chunked_open(In, DataStream, []),
+	call_cleanup(http_read_data(DataStream, RestFields, Data, Options),
+		     close(DataStream)).
+http_read_data(In, Fields, Data, Options) :-
+	memberchk(to(X), Options), !,
+	(   X = stream(Stream)
+	->  (   memberchk(content_length(Bytes), Fields)
+	    ->  copy_stream_data(In, Stream, Bytes)
+	    ;   copy_stream_data(In, Stream)
+	    )
+	;   new_memory_file(MemFile),
+	    open_memory_file(MemFile, write, Stream, [encoding(octet)]),
+	    (   memberchk(content_length(Bytes), Fields)
+	    ->  copy_stream_data(In, Stream, Bytes)
+	    ;   copy_stream_data(In, Stream)
+	    ),
+	    close(Stream),
+	    encoding(Fields, Encoding),
+	    (   X == atom
+	    ->  memory_file_to_atom(MemFile, Data0, Encoding)
+	    ;	X == codes
+	    ->	memory_file_to_codes(MemFile, Data0, Encoding)
+	    ;	domain_error(return_type, X)
+	    ),
+	    free_memory_file(MemFile),
+	    Data = Data0
+	).
+http_read_data(In, Fields, Data, _) :-
+	memberchk(content_type('application/x-www-form-urlencoded'), Fields), !,
+	http_read_data(In, Fields, Codes, [to(codes)]),
+	parse_url_search(Codes, Data).
+http_read_data(In, Fields, Data, Options) :- 			% call hook
+	(   select(content_type(Type), Options, Options1)
+	->  delete(Fields, content_type(_), Fields1),
+	    http_convert_data(In, [content_type(Type)|Fields1], Data, Options1)
+	;   http_convert_data(In, Fields, Data, Options)
+	), !.
+http_read_data(In, Fields, Data, Options) :-
+	http_read_data(In, Fields, Data, [to(atom)|Options]).
+
+
+encoding(Fields, utf8) :-
+	memberchk(content_type(Type), Fields),
+	(   sub_atom(Type, _, _, _, 'UTF-8')
+	->  true
+	;   sub_atom(Type, _, _, _, 'utf-8')
+	), !.
+encoding(_, octet).
+
+
+		 /*******************************
+		 *	       POST		*
+		 *******************************/
+
+%%	http_put(+URL, +In, -Out, +Options)
+%
+%	Issue an HTTP PUT request.
+
+http_put(URL, In, Out, Options) :-
+	http_post(URL, In, Out, [method('PUT')|Options]).
+
+
+%%	http_post(+URL, +In, -Out, +Options)
+%
+%	Issue an HTTP POST request, In is modelled after the reply
+%	from the HTTP server module.  In is one of:
+%
+%		* string(String)
+%		* string(MimeType, String)
+%		* html(Tokens)
+%		* file(MimeType, File)
+
+http_post(URL, In, Out, Options) :-
+	atomic(URL), !,
+	parse_url(URL, Parts),
+	http_post(Parts, In, Out, Options).
+http_post(Parts, In, Out, Options) :-
+	memberchk(connection(Connection), Options),
+	downcase_atom(Connection, 'keep-alive'), !,
+	between(0, 1, _),
+	catch(http_do_post(Parts, In, Out, Options), error(io_error, _),
+	      (	  disconnect(Parts),
+		  fail
+	      )), !.
+http_post(Parts, In, Out, Options) :-
+	address(Parts, Address, Protocol, Options),
+	do_connect(Address, Protocol, Read, Write, Options),
+	call_cleanup(http_do_post([socket(Read, Write)|Parts],
+				  In, Out, Options),
+		     disconnect(Protocol, Address, Read, Write)).
+
+http_do_post(Parts, In, Out, Options) :-
+	connect(Parts, Read, Write, Options),
+	(   memberchk(proxy(_,_), Options)
+	->  parse_url(Location, Parts)
+	;   http_location(Parts, Location)
+	),
+	memberchk(host(Host), Parts),
+	split_options(Options, PostOptions, ReplyOptions),
+	write_post_header(Write, Location, Host, In, PostOptions),
+	http_read_reply(Read, Out, ReplyOptions).
+
+write_post_header(Out, Location, Host, In, Options) :-
+	option(method(Method), Options, 'POST'),
+	http_write_header(Out, Method, Location, Host, Options, DataOptions),
+	http_post_data(In, Out, DataOptions),
+	flush_output(Out).
+
+post_option(connection(_)).
+post_option(http_version(_)).
+post_option(cache_control(_)).
+post_option(request_header(_)).
+
+split_options([], [], []).
+split_options([H|T], [H|P], R) :-
+	post_option(H), !,
+	split_options(T, P, R).
+split_options([H|T], P, [H|R]) :-
+	split_options(T, P, R).
+
+:- retract(system:swi_io).
+

packages/http/http_dirindex.pl

@@ -0,0 +1,202 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2009, VU University Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_dirindex,
+	  [ http_reply_dirindex/3	% +PhysicalDir, +Options, +Request
+	  ]).
+:- use_module(library(http/html_write)).
+:- use_module(library(http/http_path)).
+:- use_module(library(http/http_dispatch)).
+:- use_module(library(http/http_server_files)).
+:- use_module(library(http/html_head)).
+:- use_module(library(apply)).
+:- use_module(library(option)).
+
+/** <module> HTTP directory listings
+
+This module provides a simple API to   generate  an index for a physical
+directory. The index can be customised   by  overruling the dirindex.css
+CSS file and by defining  additional  rules   for  icons  using the hook
+http:file_extension_icon/2.
+
+@tbd	Provide more options (sorting, selecting columns, hiding files)
+*/
+
+%%	http_reply_dirindex(+DirSpec, +Options, +Request) is det.
+%
+%	Provide a directory listing for Request, assuming it is an index
+%	for the physical directrory Dir. If   the  request-path does not
+%	end with /, first return a moved (301 Moved Permanently) reply.
+%
+%	The  calling  conventions  allows  for    direct   calling  from
+%	http_handler/3.
+
+http_reply_dirindex(DirSpec, Options, Request) :-
+	http_safe_file(DirSpec, Options),
+	absolute_file_name(DirSpec, Dir,
+			   [ file_type(directory),
+			     access(read)
+			   ]),
+	memberchk(path(Path), Request),
+	(   atom_concat(PlainPath, /, Path),
+	    merge_options(Options,
+			  [ title(['Index of ', PlainPath]) ],
+			  Options1)
+	->  dir_index(Dir, Options1)
+	;   atom_concat(Path, /, NewLocation),
+	    throw(http_reply(moved(NewLocation)))
+	).
+
+dir_index(Dir, Options) :-
+	directory_members(Dir, SubDirs, Files),
+	option(title(Title), Options, Dir),
+	reply_html_page(title(Title),
+			[ \html_requires(http_dirindex),
+			  h1(Title),
+			  table(class(dirindex),
+				[ \dirindex_title,
+				  \back
+				| \dirmembers(SubDirs, Files)
+				])
+			]).
+
+directory_members(Dir, Dirs, Files) :-
+	atom_concat(Dir, '/*', Pattern),
+	expand_file_name(Pattern, Matches),
+	partition(exists_directory, Matches, Dirs, Files).
+
+dirindex_title -->
+	html(tr(class(dirindex_header),
+		[ th(class(icon),     ''),
+		  th(class(name),     'Name'),
+		  th(class(modified), 'Last modified'),
+		  th(class(size),     'Size')
+		])).
+
+back -->
+	html(tr([ \icon_cell('back.png', '[UP]'),
+		  \name_cell(.., 'Up'),
+		  td(class(modified), -),
+		  td(class(size),     -)
+		])).
+
+dirmembers(Dirs, Files) -->
+	dir_rows(Dirs, odd, End),
+	file_rows(Files, End, _).
+
+dir_rows([], OE, OE) --> [].
+dir_rows([H|T], OE0, OE) -->
+	dir_row(H, OE0),
+	{ oe(OE0, OE1) },
+	dir_rows(T, OE1, OE).
+
+file_rows([], OE, OE) --> [].
+file_rows([H|T], OE0, OE) -->
+	file_row(H, OE0),
+	{oe(OE0, OE1)},
+	file_rows(T, OE1, OE).
+
+oe(odd, even).
+oe(even, odd).
+
+dir_row(Dir, OE) -->
+	{ file_base_name(Dir, Name)
+	},
+	html(tr(class(OE),
+		[ \icon_cell('folder.png', '[DIR]'),
+		  \name_cell(Name, Name),
+		  \modified_cell(Dir),
+		  td(class(size), -)
+		])).
+
+
+file_row(File, OE) -->
+	{ file_base_name(File, Name),
+	  file_name_extension(_, Ext, Name),
+	  file_type_icon(Ext, IconName)
+	},
+	html(tr(class(OE),
+		[ \icon_cell(IconName, '[FILE]'),
+		  \name_cell(Name, Name),
+		  \modified_cell(File),
+		  td(class(size), \size(File))
+		])).
+
+icon_cell(IconName, Alt) -->
+	{ http_absolute_location(icons(IconName), Icon, [])
+	},
+	html(td(class(icon), img([src(Icon), alt(Alt)]))).
+
+
+name_cell(Ref, Name) -->
+	html(td(class(name), a(href(Ref), Name))).
+
+
+modified_cell(Name) -->
+	{ time_file(Name, Stamp),
+	  format_time(string(Date), '%+', Stamp)
+	},
+	html(td(class(modified), Date)).
+
+size(Name) -->
+	{ size_file(Name, Size)
+	},
+	html('~D'-[Size]).
+
+%%	file_type_icon(+Extension, -Icon) is det.
+%
+%	Determine the icon that is used  to   show  a  file of the given
+%	extension. This predicate can  be   hooked  using  the multifile
+%	http:file_extension_icon/2 hook with the same signature. Icon is
+%	the  plain  name  of  an  image    file   that  appears  in  the
+%	file-search-path =icons=.
+
+file_type_icon(Ext, Icon) :-
+	http:file_extension_icon(Ext, Icon), !.
+file_type_icon(_, 'generic.png').
+
+:- multifile
+	http:file_extension_icon/2.
+
+http:file_extension_icon(pdf, 'layout.png').
+http:file_extension_icon(c,   'c.png').
+http:file_extension_icon(gz,  'compressed.png').
+http:file_extension_icon(tgz, 'compressed.png').
+http:file_extension_icon(zip, 'compressed.png').
+
+
+		 /*******************************
+		 *	      RESOURCES		*
+		 *******************************/
+
+:- html_resource(http_dirindex,
+		 [ virtual(true),
+		   requires([ css('dirindex.css')
+			    ])
+		 ]).

packages/http/http_dispatch.pl

@@ -0,0 +1,855 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2007-2009, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_dispatch,
+	  [ http_dispatch/1,		% +Request
+	    http_handler/3,		% +Path, +Predicate, +Options
+	    http_delete_handler/1,	% +Path
+	    http_reply_file/3,		% +File, +Options, +Request
+	    http_redirect/3,		% +How, +Path, +Request
+	    http_current_handler/2,	% ?Path, ?Pred
+	    http_current_handler/3,	% ?Path, ?Pred
+	    http_location_by_id/2,	% +ID, -Location
+	    http_link_to_id/3,		% +ID, +Parameters, -HREF
+	    http_safe_file/2		% +Spec, +Options
+	  ]).
+:- use_module(library(option)).
+:- use_module(library(lists)).
+:- use_module(library(time)).
+:- use_module(library(error)).
+:- use_module(library(settings)).
+:- use_module(library(uri)).
+:- use_module(library(http/mimetype)).
+:- use_module(library(http/http_path)).
+:- use_module(library(http/http_header)).
+:- use_module(library(http/thread_httpd)).
+
+/** <module> Dispatch requests in the HTTP server
+
+This module can be placed between   http_wrapper.pl  and the application
+code to associate HTTP _locations_ to   predicates that serve the pages.
+In addition, it associates parameters  with   locations  that  deal with
+timeout handling and user authentication.  The typical setup is:
+
+==
+server(Port, Options) :-
+	http_server(http_dispatch,
+		    [ port(Port),
+		    | Options
+		    ]).
+
+:- http_handler('/index.html', write_index, []).
+
+write_index(Request) :-
+	...
+==
+*/
+
+:- setting(http:time_limit, nonneg, 300,
+	   'Time limit handling a single query (0=infinite)').
+
+%%	http_handler(+Path, :Closure, +Options) is det.
+%
+%	Register Closure as a handler for HTTP requests. Path is a
+%	specification as provided by http_path.pl.  If an HTTP
+%	request arrives at the server that matches Path, Closure
+%	is called with one extra argument: the parsed HTTP request.
+%	Options is a list containing the following options:
+%
+%		* authentication(+Type)
+%		Demand authentication.  Authentication methods are
+%		pluggable.  The library http_authenticate.pl provides
+%		a plugin for user/password based =Basic= HTTP
+%		authentication.
+%
+%		* chunked
+%		Use =|Transfer-encoding: chunked|= if the client
+%		allows for it.
+%
+%		* id(+Term)
+%		Identifier of the handler.  The default identifier is
+%		the predicate name.  Used by http_location_by_id/2.
+%
+%		* priority(+Integer)
+%		If two handlers handle the same path, the one with the
+%		highest priority is used.  If equal, the last registered
+%		is used.  Please be aware that the order of clauses in
+%		multifile predicates can change due to reloading files.
+%		The default priority is 0 (zero).
+%
+%		* prefix
+%		Call Pred on any location that is a specialisation of
+%		Path.  If multiple handlers match, the one with the
+%		longest path is used.
+%
+%		* spawn(+SpawnOptions)
+%		Run the handler in a seperate thread.  If SpawnOptions
+%		is an atom, it is interpreted as a thread pool name
+%		(see create_thread_pool/3).  Otherwise the options
+%		are passed to http_spawn/2 and from there to
+%		thread_create/3.  These options are typically used to
+%		set the stack limits.
+%
+%		* time_limit(+Spec)
+%		One of =infinite=, =default= or a positive number
+%		(seconds)
+%
+%		* content_type(+Term)
+%		Specifies the content-type of the reply.  This value is
+%		currently not used by this library.  It enhances the
+%		reflexive capabilities of this library through
+%		http_current_handler/3.
+%
+%	Note that http_handler/3 is normally invoked  as a directive and
+%	processed using term-expansion.  Using   term-expansion  ensures
+%	proper update through make/0 when the specification is modified.
+%	We do not expand when the  cross-referencer is running to ensure
+%	proper handling of the meta-call.
+%
+%	@error	existence_error(http_location, Location)
+%	@see    http_reply_file/3 and http_redirect/3 are generic
+%		handlers to serve files and achieve redirects.
+
+:- dynamic handler/4.			% Path, Action, IsPrefix, Options
+:- multifile handler/4.
+:- dynamic generation/1.
+
+:- meta_predicate
+	http_handler(+, :, +),
+	http_current_handler(?, :),
+	http_current_handler(?, :, ?).
+
+http_handler(Path, Pred, Options) :-
+	strip_module(Pred, M, P),
+	compile_handler(Path, M:P, Options, Clause),
+	next_generation,
+	assert(Clause).
+
+:- multifile
+	system:term_expansion/2.
+
+system:term_expansion((:- http_handler(Path, Pred, Options)), Clause) :-
+	\+ current_prolog_flag(xref, true),
+	prolog_load_context(module, M),
+	compile_handler(Path, M:Pred, Options, Clause),
+	next_generation.
+
+
+%%	http_delete_handler(+Path) is det.
+%
+%	Delete handler for Path. Typically, this should only be used for
+%	handlers that are registered dynamically.
+
+http_delete_handler(Path) :-
+	retractall(handler(Path, _Pred, _, _Options)),
+	next_generation.
+
+
+%%	next_generation is det.
+%%	current_generation(-G) is det.
+%
+%	Increment the generation count.
+
+next_generation :-
+	retractall(id_location_cache(_,_)),
+	with_mutex(http_dispatch, next_generation_unlocked).
+
+next_generation_unlocked :-
+	retract(generation(G0)), !,
+	G is G0	+ 1,
+	assert(generation(G)).
+next_generation_unlocked :-
+	assert(generation(1)).
+
+current_generation(G) :-
+	with_mutex(http_dispatch, generation(G)), !.
+current_generation(0).
+
+
+%%	compile_handler(+Path, :Pred, +Options) is det.
+%
+%	Compile a handler specification. For now we this is a no-op, but
+%	in the feature can make this more efficiently, especially in the
+%	presence of one or multiple prefix declarations. We can also use
+%	this to detect conflicts.
+
+compile_handler(prefix(Path), Pred, Options,
+		http_dispatch:handler(Path, Pred, true, Options)) :- !,
+	check_path(Path, Path1),
+	print_message(warning, http_dispatch(prefix(Path1))).
+compile_handler(Path, Pred, Options0,
+		http_dispatch:handler(Path1, Pred, IsPrefix, Options)) :-
+	check_path(Path, Path1),
+	(   select(prefix, Options0, Options)
+	->  IsPrefix = true
+	;   IsPrefix = false,
+	    Options = Options0
+	).
+
+%%	check_path(+PathSpecIn, -PathSpecOut) is det.
+%
+%	Validate the given path specification.  We want one of
+%
+%		* AbsoluteLocation
+%		* Alias(Relative)
+%
+%	Similar  to  absolute_file_name/3,  Relative  can    be  a  term
+%	_|Component/Component/...|_
+%
+%	@error	domain_error, type_error
+%	@see	http_absolute_location/3
+
+check_path(Path, Path) :-
+	atom(Path), !,
+	(   sub_atom(Path, 0, _, _, /)
+	->  true
+	;   domain_error(absolute_http_location, Path)
+	).
+check_path(Alias, AliasOut) :-
+	compound(Alias),
+	Alias =.. [Name, Relative], !,
+	to_atom(Relative, Local),
+	(   sub_atom(Local, 0, _, _, /)
+	->  domain_error(relative_location, Relative)
+	;   AliasOut =.. [Name, Local]
+	).
+check_path(PathSpec, _) :-
+	type_error(path_or_alias, PathSpec).
+
+to_atom(Atom, Atom) :-
+	atom(Atom), !.
+to_atom(Path, Atom) :-
+	phrase(path_to_list(Path), Components), !,
+	atomic_list_concat(Components, '/', Atom).
+to_atom(Path, _) :-
+	ground(Path), !,
+	type_error(relative_location, Path).
+to_atom(Path, _) :-
+	instantiation_error(Path).
+
+path_to_list(Var) -->
+	{ var(Var), !,
+	  fail
+	}.
+path_to_list(A/B) -->
+	path_to_list(A),
+	path_to_list(B).
+path_to_list(Atom) -->
+	{ atom(Atom) },
+	[Atom].
+
+
+
+%%	http_dispatch(Request) is det.
+%
+%	Dispatch a Request using http_handler/3 registrations.
+
+http_dispatch(Request) :-
+	memberchk(path(Path), Request),
+	find_handler(Path, Pred, Options),
+	authentication(Options, Request, Fields),
+	append(Fields, Request, AuthRequest),
+	action(Pred, AuthRequest, Options).
+
+
+%%	http_current_handler(+Location, :Closure) is semidet.
+%%	http_current_handler(-Location, :Closure) is nondet.
+%
+%	True if Location is handled by Closure.
+
+http_current_handler(Path, Closure) :-
+	atom(Path), !,
+	path_tree(Tree),
+	find_handler(Tree, Path, Closure, _).
+http_current_handler(Path, M:C) :-
+	handler(Spec, M:C, _, _),
+	http_absolute_location(Spec, Path, []).
+
+%%	http_current_handler(+Location, :Closure, -Options) is semidet.
+%%	http_current_handler(?Location, :Closure, ?Options) is nondet.
+%
+%	Resolve the current handler and options to execute it.
+
+http_current_handler(Path, Closure, Options) :-
+	atom(Path), !,
+	path_tree(Tree),
+	find_handler(Tree, Path, Closure, Options).
+http_current_handler(Path, M:C, Options) :-
+	handler(Spec, M:C, _, _),
+	http_absolute_location(Spec, Path, []),
+	path_tree(Tree),
+	find_handler(Tree, Path, _, Options).
+
+
+%%	http_location_by_id(+ID, -Location) is det.
+%
+%	Find the HTTP Location of handler with   ID. If the setting (see
+%	setting/2)  http:prefix  is  active,  Location  is  the  handler
+%	location prefixed with the prefix setting.   Handler  IDs can be
+%	specified in two ways:
+%
+%	    * id(ID)
+%	    If this appears in the option list of the handler, this
+%	    it is used and takes preference over using the predicate.
+%	    * M:PredName
+%	    The module-qualified name of the predicate.
+%	    * PredName
+%	    The unqualified name of the predicate.
+%
+%	@error existence_error(http_handler_id, Id).
+
+:- dynamic
+	id_location_cache/2.
+
+http_location_by_id(ID, Location) :-
+	must_be(ground, ID),
+	id_location_cache(ID, L0), !,
+	Location = L0.
+http_location_by_id(ID, Location) :-
+	findall(P-L, location_by_id(ID, L, P), List),
+	keysort(List, RevSorted),
+	reverse(RevSorted, Sorted),
+	(   Sorted = [_-One]
+	->  assert(id_location_cache(ID, One)),
+	    Location = One
+	;   List == []
+	->  existence_error(http_handler_id, ID)
+	;   List = [P0-Best,P1-_|_]
+	->  (   P0 == P1
+	    ->	print_message(warning,
+			      http_dispatch(ambiguous_id(ID, Sorted, Best)))
+	    ;	true
+	    ),
+	    assert(id_location_cache(ID, Best)),
+	    Location = Best
+	).
+
+location_by_id(ID, Location, Priority) :-
+	location_by_id_raw(ID, L0, Priority),
+	to_path(L0, Location).
+
+to_path(prefix(Path0), Path) :- !,	% old style prefix notation
+	add_prefix(Path0, Path).
+to_path(Path0, Path) :-
+	atomic(Path0), !,		% old style notation
+	add_prefix(Path0, Path).
+to_path(Spec, Path) :-			% new style notation
+	http_absolute_location(Spec, Path, []).
+
+add_prefix(P0, P) :-
+	(   catch(setting(http:prefix, Prefix), _, fail),
+	    Prefix \== ''
+	->  atom_concat(Prefix, P0, P)
+	;   P = P0
+	).
+
+location_by_id_raw(ID, Location, Priority) :-
+	handler(Location, _, _, Options),
+	option(id(ID), Options),
+	option(priority(P0), Options, 0),
+	Priority is P0+1000.		% id(ID) takes preference over predicate
+location_by_id_raw(ID, Location, Priority) :-
+	handler(Location, M:C, _, Options),
+	option(priority(Priority), Options, 0),
+	functor(C, PN, _),
+	(   ID = M:PN
+	;   ID = PN
+	), !.
+
+
+%%	http_link_to_id(+HandleID, +Parameters, -HREF)
+%
+%	HREF is a link on the local server to a handler with given ID,
+%	passing the given Parameters.
+
+http_link_to_id(HandleID, Parameters, HREF) :-
+	http_location_by_id(HandleID, Location),
+	uri_data(path, Components, Location),
+	uri_query_components(String, Parameters),
+	uri_data(search, Components, String),
+	uri_components(HREF, Components).
+
+
+%	hook into html_write:attribute_value//1.
+
+:- multifile
+	html_write:expand_attribute_value//1.
+
+html_write:expand_attribute_value(location_by_id(ID)) -->
+	{ http_location_by_id(ID, Location) },
+	html_write:html_quoted_attribute(Location).
+
+
+%%	authentication(+Options, +Request, -Fields) is det.
+%
+%	Verify  authentication  information.   If    authentication   is
+%	requested through Options, demand it. The actual verification is
+%	done by the multifile   predicate  http_dispatch:authenticate/3.
+%	The  library  http_authenticate.pl  provides  an  implementation
+%	thereof.
+%
+%	@error	permission_error(access, http_location, Location)
+
+:- multifile
+	http:authenticate/3.
+
+authentication([], _, []).
+authentication([authentication(Type)|Options], Request, Fields) :- !,
+	(   http:authenticate(Type, Request, XFields)
+	->  append(XFields, More, Fields),
+	    authentication(Options, Request, More)
+	;   memberchk(path(Path), Request),
+	    throw(error(permission_error(access, http_location, Path), _))
+	).
+authentication([_|Options], Request, Fields) :-
+	authentication(Options, Request, Fields).
+
+
+%%	find_handler(+Path, -Action, -Options) is det.
+%
+%	Find the handler to call from Path.  Rules:
+%
+%		* If there is a matching handler, use this.
+%		* If there are multiple prefix(Path) handlers, use the
+%		  longest.
+%
+%	If there is a handler for =|/dir/|=   and  the requested path is
+%	=|/dir|=, find_handler/3 throws a  http_reply exception, causing
+%	the wrapper to generate a 301 (Moved Permanently) reply.
+%
+%	@error	existence_error(http_location, Location)
+%	@throw	http_reply(moved(Dir))
+%	@tbd	Introduce automatic redirection to indexes here?
+
+find_handler(Path, Action, Options) :-
+	path_tree(Tree),
+	(   find_handler(Tree, Path, Action, Options)
+	->  true
+	;   \+ sub_atom(Path, _, _, 0, /),
+	    atom_concat(Path, /, Dir),
+	    find_handler(Tree, Dir, Action, Options)
+	->  throw(http_reply(moved(Dir)))
+	;   throw(error(existence_error(http_location, Path), _))
+	).
+
+
+find_handler([node(prefix(Prefix), PAction, POptions, Children)|_],
+	     Path, Action, Options) :-
+	sub_atom(Path, 0, _, After, Prefix), !,
+	(   find_handler(Children, Path, Action, Options)
+	->  true
+	;   Action = PAction,
+	    path_info(After, Path, POptions, Options)
+	).
+find_handler([node(Path, Action, Options, _)|_], Path, Action, Options) :- !.
+find_handler([_|Tree], Path, Action, Options) :-
+	find_handler(Tree, Path, Action, Options).
+
+path_info(0, _, Options,
+	  [prefix(true)|Options]) :- !.
+path_info(After, Path, Options,
+	  [path_info(PathInfo),prefix(true)|Options]) :-
+	sub_atom(Path, _, After, 0, PathInfo).
+
+
+%%	action(+Action, +Request, +Options) is det.
+%
+%	Execute the action found.  Here we take care of the options
+%	=time_limit=, =chunked= and =spawn=.
+%
+%	@error	goal_failed(Goal)
+
+action(Action, Request, Options) :-
+	memberchk(chunked, Options), !,
+	format('Transfer-encoding: chunked~n'),
+	spawn_action(Action, Request, Options).
+action(Action, Request, Options) :-
+	spawn_action(Action, Request, Options).
+
+spawn_action(Action, Request, Options) :-
+	option(spawn(Spawn), Options), !,
+	spawn_options(Spawn, SpawnOption),
+	http_spawn(time_limit_action(Action, Request, Options), SpawnOption).
+spawn_action(Action, Request, Options) :-
+	time_limit_action(Action, Request, Options).
+
+spawn_options([], []) :- !.
+spawn_options(Pool, Options) :-
+	atom(Pool), !,
+	Options = [pool(Pool)].
+spawn_options(List, List).
+
+time_limit_action(Action, Request, Options) :-
+	(   option(time_limit(TimeLimit), Options),
+	    TimeLimit \== default
+	->  true
+	;   setting(http:time_limit, TimeLimit)
+	),
+	number(TimeLimit),
+	TimeLimit > 0, !,
+	call_with_time_limit(TimeLimit, call_action(Action, Request, Options)).
+time_limit_action(Action, Request, Options) :-
+	call_action(Action, Request, Options).
+
+
+%%	call_action(+Action, +Request, +Options)
+%
+%	@tbd	reply_file is normal call?
+
+call_action(reply_file(File, FileOptions), Request, _Options) :- !,
+	http_reply_file(File, FileOptions, Request).
+call_action(Pred, Request, Options) :-
+	memberchk(path_info(PathInfo), Options), !,
+	call_action(Pred, [path_info(PathInfo)|Request]).
+call_action(Pred, Request, _Options) :-
+	call_action(Pred, Request).
+
+call_action(Pred, Request) :-
+	(   call(Pred, Request)
+	->  true
+	;   extend(Pred, [Request], Goal),
+	    throw(error(goal_failed(Goal), _))
+	).
+
+extend(Var, _, Var) :-
+	var(Var), !.
+extend(M:G0, Extra, M:G) :-
+	extend(G0, Extra, G).
+extend(G0, Extra, G) :-
+	G0 =.. List,
+	append(List, Extra, List2),
+	G =.. List2.
+
+%%	http_reply_file(+FileSpec, +Options, +Request) is det.
+%
+%	Options is a list of
+%
+%		* cache(+Boolean)
+%		If =true= (default), handle If-modified-since and send
+%		modification time.
+%
+%		* mime_type(+Type)
+%		Overrule mime-type guessing from the filename as
+%		provided by file_mime_type/2.
+%
+%		* unsafe(+Boolean)
+%		If =false= (default), validate that FileSpec does not
+%		contain references to parent directories.  E.g.,
+%		specifications such as =|www('../../etc/passwd')|= are
+%		not allowed.
+%
+%	If caching is not disabled,  it   processed  the request headers
+%	=|If-modified-since|= and =Range=.
+%
+%	@throws	http_reply(not_modified)
+%	@throws http_reply(file(MimeType, Path))
+
+http_reply_file(File, Options, Request) :-
+	http_safe_file(File, Options),
+	absolute_file_name(File, Path,
+			   [ access(read)
+			   ]),
+	(   option(cache(true), Options, true)
+	->  (   memberchk(if_modified_since(Since), Request),
+	        time_file(Path, Time),
+		catch(http_timestamp(Time, Since), _, fail)
+	    ->  throw(http_reply(not_modified))
+	    ;	true
+	    ),
+	    (	memberchk(range(Range), Request)
+	    ->	Reply = file(Type, Path, Range)
+	    ;	Reply = file(Type, Path)
+	    )
+	;   Reply = tmp_file(Type, Path)
+	),
+	(   option(mime_type(Type), Options)
+	->  true
+	;   file_mime_type(Path, Type)
+	->  true
+	;   Type = text/plain		% fallback type
+	),
+	throw(http_reply(Reply)).
+
+%%	http_safe_file(+FileSpec, +Options) is det.
+%
+%	True if FileSpec is considered _safe_.  If   it  is  an atom, it
+%	cannot  be  absolute  and  cannot   have  references  to  parent
+%	directories. If it is of the   form  alias(Sub), than Sub cannot
+%	have references to parent directories.
+%
+%	@error instantiation_error
+%	@error permission_error(read, file, FileSpec)
+
+http_safe_file(File, _) :-
+	var(File), !,
+	instantiation_error(File).
+http_safe_file(_, Options) :-
+	option(unsafe(true), Options, false), !.
+http_safe_file(File, _) :-
+	http_safe_file(File).
+
+http_safe_file(File) :-
+	compound(File),
+	functor(File, _, 1), !,
+	arg(1, File, Name),
+	safe_name(Name, File).
+http_safe_file(Name) :-
+	(   is_absolute_file_name(Name)
+	->  permission_error(read, file, Name)
+	;   true
+	),
+	safe_name(Name, Name).
+
+safe_name(Name, _) :-
+	must_be(atom, Name),
+	\+ unsafe_name(Name), !.
+safe_name(_, Spec) :-
+	permission_error(read, file, Spec).
+
+unsafe_name(Name) :- Name == '..'.
+unsafe_name(Name) :- sub_atom(Name, 0, _, _, '../').
+unsafe_name(Name) :- sub_atom(Name, _, _, _, '/../').
+unsafe_name(Name) :- sub_atom(Name, _, _, 0, '/..').
+
+
+%%	http_redirect(+How, +To, +Request) is det.
+%
+%	Redirect to a new  location.  The   argument  order,  using  the
+%	Request as last argument, allows for  calling this directly from
+%	the handler declaration:
+%
+%	    ==
+%	    :- http_handler(root(.),
+%			    http_redirect(moved, myapp('index.html')),
+%			    []).
+%	    ==
+%
+%	@param How is one of =moved=, =moved_temporary= or =see_also=
+%	@param To is an atom, a aliased path as defined by
+%	http_absolute_location/3. or a term location_by_id(Id). If To is
+%	not absolute, it is resolved relative to the current location.
+
+http_redirect(How, To, Request) :-
+	(   To = location_by_id(Id)
+	->  http_location_by_id(Id, URL)
+	;   memberchk(path(Base), Request),
+	    http_absolute_location(To, URL, [relative_to(Base)])
+	),
+	must_be(oneof([moved, moved_temporary, see_also]), How),
+	Term =.. [How,URL],
+	throw(http_reply(Term)).
+
+
+		 /*******************************
+		 *	  PATH COMPILATION	*
+		 *******************************/
+
+%%	path_tree(-Tree) is det.
+%
+%	Compile paths into  a  tree.  The   treee  is  multi-rooted  and
+%	represented as a list of nodes, where each node has the form:
+%
+%		node(PathOrPrefix, Action, Options, Children)
+%
+%	The tree is a potentially complicated structure. It is cached in
+%	a global variable. Note that this   cache is per-thread, so each
+%	worker thread holds a copy of  the   tree.  If handler facts are
+%	changed the _generation_ is  incremented using next_generation/0
+%	and each worker thread will  re-compute   the  tree  on the next
+%	ocasion.
+
+path_tree(Tree) :-
+	current_generation(G),
+	nb_current(http_dispatch_tree, G-Tree), !. % Avoid existence error
+path_tree(Tree) :-
+	findall(Prefix, prefix_handler(Prefix, _, _), Prefixes0),
+	sort(Prefixes0, Prefixes),
+	prefix_tree(Prefixes, [], PTree),
+	prefix_options(PTree, [], OPTree),
+	add_paths_tree(OPTree, Tree),
+	current_generation(G),
+	nb_setval(http_dispatch_tree, G-Tree).
+
+prefix_handler(Prefix, Action, Options) :-
+	handler(Spec, Action, true, Options),
+	http_absolute_location(Spec, Prefix, []).
+
+%%	prefix_tree(PrefixList, +Tree0, -Tree)
+%
+%	@param Tree	list(Prefix-list(Children))
+
+prefix_tree([], Tree, Tree).
+prefix_tree([H|T], Tree0, Tree) :-
+	insert_prefix(H, Tree0, Tree1),
+	prefix_tree(T, Tree1, Tree).
+
+insert_prefix(Prefix, Tree0, Tree) :-
+	select(P-T, Tree0, Tree1),
+	sub_atom(Prefix, 0, _, _, P), !,
+	insert_prefix(Prefix, T, T1),
+	Tree = [P-T1|Tree1].
+insert_prefix(Prefix, Tree, [Prefix-[]|Tree]).
+
+
+%%	prefix_options(+PrefixTree, +DefOptions, -OptionTree)
+%
+%	Generate the option-tree for all prefix declarations.
+%
+%	@tbd	What to do if there are more?
+
+prefix_options([], _, []).
+prefix_options([P-C|T0], DefOptions,
+	       [node(prefix(P), Action, Options, Children)|T]) :-
+	once(prefix_handler(P, Action, Options0)),
+	merge_options(Options0, DefOptions, Options),
+	prefix_options(C, Options, Children),
+	prefix_options(T0, DefOptions, T).
+
+
+%%	add_paths_tree(+OPTree, -Tree) is det.
+%
+%	Add the plain paths.
+
+add_paths_tree(OPTree, Tree) :-
+	findall(path(Path, Action, Options),
+		plain_path(Path, Action, Options),
+		Triples),
+	add_paths_tree(Triples, OPTree, Tree).
+
+add_paths_tree([], Tree, Tree).
+add_paths_tree([path(Path, Action, Options)|T], Tree0, Tree) :-
+	add_path_tree(Path, Action, Options, [], Tree0, Tree1),
+	add_paths_tree(T, Tree1, Tree).
+
+
+%%	plain_path(-Path, -Action, -Options) is nondet.
+%
+%	True if {Path,Action,Options} is registered and  Path is a plain
+%	(i.e. not _prefix_) location.
+
+plain_path(Path, Action, Options) :-
+	handler(Spec, Action, false, Options),
+	http_absolute_location(Spec, Path, []).
+
+
+%%	add_path_tree(+Path, +Action, +Options, +Tree0, -Tree) is det.
+%
+%	Add a path to a tree. If a  handler for the same path is already
+%	defined, the one with the highest   priority or the latest takes
+%	precedence.
+
+add_path_tree(Path, Action, Options0, DefOptions, [],
+	      [node(Path, Action, Options, [])]) :- !,
+	merge_options(Options0, DefOptions, Options).
+add_path_tree(Path, Action, Options, _,
+	      [node(prefix(Prefix), PA, DefOptions, Children0)|RestTree],
+	      [node(prefix(Prefix), PA, DefOptions, Children)|RestTree]) :-
+	sub_atom(Path, 0, _, _, Prefix), !,
+	add_path_tree(Path, Action, Options, DefOptions, Children0, Children).
+add_path_tree(Path, Action, Options1, DefOptions, [H0|T], [H|T]) :-
+	H0 = node(Path, _, Options2, _),
+	option(priority(P1), Options1, 0),
+	option(priority(P2), Options2, 0),
+	P1 >= P2, !,
+	merge_options(Options1, DefOptions, Options),
+	H = node(Path, Action, Options, []).
+add_path_tree(Path, Action, Options, DefOptions, [H|T0], [H|T]) :-
+	add_path_tree(Path, Action, Options, DefOptions, T0, T).
+
+
+		 /*******************************
+		 *	      MESSAGES		*
+		 *******************************/
+
+:- multifile
+	prolog:message/3.
+
+prolog:message(http_dispatch(ambiguous_id(ID, _List, Selected))) -->
+	[ 'HTTP dispatch: ambiguous handler ID ~q (selected ~q)'-[ID, Selected]
+	].
+prolog:message(http_dispatch(prefix(_Path))) -->
+	[ 'HTTP dispatch: prefix(Path) is replaced by the option prefix'-[]
+	].
+
+
+		 /*******************************
+		 *	      XREF		*
+		 *******************************/
+
+:- multifile
+	prolog:meta_goal/2.
+:- dynamic
+	prolog:meta_goal/2.
+
+prolog:meta_goal(http_handler(_, G, _), [G+1]).
+prolog:meta_goal(http_current_handler(_, G), [G+1]).
+
+
+		 /*******************************
+		 *	       EDIT		*
+		 *******************************/
+
+% Allow edit(Location) to edit the implementation for an HTTP location.
+
+:- multifile
+	prolog_edit:locate/3.
+
+prolog_edit:locate(Path, Spec, Location) :-
+	atom(Path),
+	Pred = _M:_H,
+	http_current_handler(Path, Pred),
+	closure_name_arity(Pred, 1, PI),
+	prolog_edit:locate(PI, Spec, Location).
+
+closure_name_arity(M:Term, Extra, M:Name/Arity) :- !,
+	callable(Term),
+	functor(Term, Name, Arity0),
+	Arity is Arity0 + Extra.
+closure_name_arity(Term, Extra, Name/Arity) :-
+	callable(Term),
+	functor(Term, Name, Arity0),
+	Arity is Arity0 + Extra.
+
+
+		 /*******************************
+		 *	  CACHE CLEANUP		*
+		 *******************************/
+
+:- listen(settings(changed(http:prefix, _, _)),
+	  next_generation).
+
+:- multifile
+	user:message_hook/3.
+:- dynamic
+	user:message_hook/3.
+
+user:message_hook(make(done(Reload)), _Level, _Lines) :-
+	Reload \== [],
+	next_generation,
+	fail.

packages/http/http_error.c

@@ -0,0 +1,171 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2007, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*/
+
+#include <SWI-Stream.h>
+#include <SWI-Prolog.h>
+
+#define O_DEBUG 1
+
+static functor_t FUNCTOR_error2;	/* error(Formal, Context) */
+static functor_t FUNCTOR_type_error2;	/* type_error(Term, Expected) */
+static functor_t FUNCTOR_domain_error2;	/* domain_error(Term, Expected) */
+static functor_t FUNCTOR_permission_error3; /* permission_error(Op, Type, Term) */
+static functor_t FUNCTOR_existence_error2; /* existence_error(Type, Term) */
+static int debuglevel = 0;
+
+#define MKFUNCTOR(name, arity) PL_new_functor(PL_new_atom(name), arity)
+
+#ifdef O_DEBUG
+#define DEBUG(n, g) if ( debuglevel >= n ) g
+#else
+#define DEBUG(n, g) (void)0
+#endif
+
+
+#ifdef O_DEBUG
+static foreign_t
+http_stream_debug(term_t level)
+{ return PL_get_integer(level, &debuglevel);
+}
+#endif
+
+
+		 /*******************************
+		 *	       ERRORS		*
+		 *******************************/
+
+static int
+type_error(term_t actual, const char *expected)
+{ term_t ex;
+
+  if ( (ex = PL_new_term_ref()) &&
+       PL_unify_term(ex,
+		     PL_FUNCTOR, FUNCTOR_error2,
+		       PL_FUNCTOR, FUNCTOR_type_error2,
+		         PL_CHARS, expected,
+		         PL_TERM, actual,
+		       PL_VARIABLE) )
+    return PL_raise_exception(ex);
+
+  return FALSE;
+}
+
+
+static int
+domain_error(term_t actual, const char *domain)
+{ term_t ex;
+
+  if ( (ex = PL_new_term_ref()) &&
+       PL_unify_term(ex,
+		     PL_FUNCTOR, FUNCTOR_error2,
+		       PL_FUNCTOR, FUNCTOR_domain_error2,
+		         PL_CHARS, domain,
+		         PL_TERM, actual,
+		       PL_VARIABLE) )
+    return PL_raise_exception(ex);
+
+  return FALSE;
+}
+
+
+static int
+existence_error(term_t actual, const char *type)
+{ term_t ex;
+
+  if ( (ex = PL_new_term_ref()) &&
+       PL_unify_term(ex,
+		     PL_FUNCTOR, FUNCTOR_error2,
+		       PL_FUNCTOR, FUNCTOR_existence_error2,
+		         PL_CHARS, type,
+		         PL_TERM, actual,
+		       PL_VARIABLE) )
+    return PL_raise_exception(ex);
+
+  return FALSE;
+}
+
+
+static int
+permission_error(const char *op, const char *objtype, term_t obj)
+{ term_t ex;
+
+  if ( (ex = PL_new_term_ref()) &&
+       PL_unify_term(ex,
+		     PL_FUNCTOR, FUNCTOR_error2,
+		       PL_FUNCTOR, FUNCTOR_permission_error3,
+		         PL_CHARS, op,
+		         PL_CHARS, objtype,
+		         PL_TERM, obj,
+		       PL_VARIABLE) )
+    return PL_raise_exception(ex);
+
+  return FALSE;
+}
+
+
+static int
+instantiation_error()
+{ term_t ex;
+
+  if ( (ex = PL_new_term_ref()) &&
+       PL_unify_term(ex,
+		     PL_FUNCTOR, FUNCTOR_error2,
+		       PL_CHARS, "instantiation_error",
+		       PL_VARIABLE) )
+    return PL_raise_exception(ex);
+
+  return FALSE;
+}
+
+
+static int
+get_int_ex(term_t t, int *i)
+{ if ( PL_get_integer(t, i) )
+    return TRUE;
+
+  return type_error(t, "integer");
+}
+
+
+static int
+get_bool_ex(term_t t, int *i)
+{ if ( PL_get_bool(t, i) )
+    return TRUE;
+
+  return type_error(t, "boolean");
+}
+
+
+static void
+init_errors()
+{ FUNCTOR_error2            = MKFUNCTOR("error", 2);
+  FUNCTOR_type_error2	    = MKFUNCTOR("type_error", 2);
+  FUNCTOR_domain_error2     = MKFUNCTOR("domain_error", 2);
+  FUNCTOR_existence_error2  = MKFUNCTOR("existence_error", 2);
+  FUNCTOR_permission_error3 = MKFUNCTOR("permission_error", 3);
+
+#ifdef O_DEBUG
+  PL_register_foreign("http_stream_debug", 1, http_stream_debug, 0);
+#endif
+}

packages/http/http_error.pl

@@ -0,0 +1,100 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2005, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_error,
+	  [
+	  ]).
+:- use_module(library(debug)).
+:- use_module(library(prolog_stack)).
+
+/** <module> Decorate uncaught exceptions with stack-trace
+
+This module decorates uncaught exceptions of the user code with a full
+stack-trace. It is based on a hook introduced in SWI-Prolog 5.6.5.
+Please note that although loading this module greatly simplifies
+debugging, it also provides clues for hackers on how to compromise your
+site. The more information you give them, the easier it is to break into
+your server!
+
+To use this file, simply load it.
+
+@author	Jan Wielemaker
+*/
+
+:- multifile
+	user:prolog_exception_hook/4.
+:- dynamic
+	user:prolog_exception_hook/4.
+
+guard(httpd_wrapper:call_handler/6).	% old version
+guard(httpd_wrapper:wrapper/5).
+guard(httpd_wrapper:handler_with_output_to/5).
+
+user:prolog_exception_hook(error(E, context(Ctx0,Msg)),
+			   error(E, context(prolog_stack(Stack),Msg)),
+			   Fr, Guard) :-
+	Guard \== none,
+	prolog_frame_attribute(Guard, predicate_indicator, Goal),
+	debug(http_error, 'Got exception ~p (Ctx0=~p, Catcher=~p)',
+	      [E, Ctx0, Goal]),
+	guard(Goal),
+	get_prolog_backtrace(Fr, 50, Stack0),
+	debug(http_error, 'Stack = ~w', [Stack0]),
+	clean_stack(Stack0, Stack).
+
+clean_stack([], []).
+clean_stack([H|_], [H]) :-
+	guard_frame(H), !.
+clean_stack([H|T0], [H|T]) :-
+	clean_stack(T0, T).
+
+guard_frame(frame(_,clause(ClauseRef, _))) :-
+	nth_clause(M:Head, _, ClauseRef),
+	functor(Head, Name, Arity),
+	guard(M:Name/Arity).
+
+
+		 /*******************************
+		 *	     MESSAGES		*
+		 *******************************/
+
+:- multifile
+	prolog:message/3.
+
+prolog:message(error(Error, context(Stack, Message))) -->
+	{ is_stack(Stack, Frames) }, !,
+	'$messages':translate_message(error(Error, context(_, Message))),
+	[ nl, 'In:', nl ],
+	prolog_stack:message(Frames).
+
+is_stack(Stack, Frames) :-
+	nonvar(Stack),
+	Stack = prolog_stack(Frames).

packages/http/http_exception.pl

@@ -0,0 +1,112 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2009, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_exception,
+	  [ map_exception_to_http_status/3
+	  ]).
+
+/** <module> Internal module of the HTTP server
+
+@see	http_header.pl, http_wrapper.pl
+*/
+
+%%	map_exception_to_http_status(+Exception, -Reply, -HdrExtra)
+%
+%	Map certain defined  exceptions  to   special  reply  codes. The
+%	http(not_modified)   provides   backward     compatibility    to
+%	http_reply(not_modified).
+
+map_exception_to_http_status(http(not_modified),
+	      not_modified,
+	      [connection('Keep-Alive')]) :- !.
+map_exception_to_http_status(http_reply(Reply),
+	      Reply,
+	      [connection(Close)]) :- !,
+	(   keep_alive(Reply)
+	->  Close = 'Keep-Alive'
+	;   Close = close
+	).
+map_exception_to_http_status(http_reply(Reply, HdrExtra0),
+	      Reply,
+	      HdrExtra) :- !,
+	(   memberchk(close(_), HdrExtra0)
+	->  HdrExtra = HdrExtra0
+	;   HdrExtra = [close(Close)|HdrExtra0],
+	    (   keep_alive(Reply)
+	    ->  Close = 'Keep-Alive'
+	    ;   Close = close
+	    )
+	).
+map_exception_to_http_status(error(existence_error(http_location, Location), _),
+	      not_found(Location),
+	      [connection(close)]) :- !.
+map_exception_to_http_status(error(permission_error(_, http_location, Location), _),
+	      forbidden(Location),
+	      [connection(close)]) :- !.
+map_exception_to_http_status(error(threads_in_pool(_Pool), _),
+	      busy,
+	      [connection(close)]) :- !.
+map_exception_to_http_status(E,
+	      resource_error(E),
+	      [connection(close)]) :-
+	resource_error(E), !.
+map_exception_to_http_status(E,
+	      bad_request(E),
+	      [connection(close)]) :-
+	bad_request_error(E), !.
+map_exception_to_http_status(E,
+	      server_error(E),
+	      [connection(close)]).
+
+resource_error(error(resource_error(_), _)).
+
+bad_request_error(error(domain_error(http_request, _), _)).
+
+%%	keep_alive(+Reply) is semidet.
+%
+%	If true for Reply, the default is to keep the connection open.
+
+keep_alive(not_modified).
+keep_alive(file(_Type, _File)).
+keep_alive(tmp_file(_Type, _File)).
+keep_alive(stream(_In, _Len)).
+keep_alive(cgi_stream(_In, _Len)).
+
+
+		 /*******************************
+		 *	    IDE SUPPORT		*
+		 *******************************/
+
+% See library('trace/exceptions')
+
+:- multifile
+	prolog:general_exception/2.
+
+prolog:general_exception(http_reply(_), http_reply(_)).
+prolog:general_exception(http_reply(_,_), http_reply(_,_)).

packages/http/http_hook.pl

@@ -0,0 +1,84 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2008, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_hook,
+	  []).
+
+/** <module> HTTP library hooks
+
+Get the declarations of the HTTP package using
+
+    ==
+    :- use_module(library(http/http_hook)).
+    ==
+
+@tbd	This should be using include, but then it cannot be a module
+	and this would cause more overhead in SWI-Prolog
+@tbd	Complete this and document the hooks.
+*/
+
+		 /*******************************
+		 *	     HTTP-PATH		*
+		 *******************************/
+
+:- multifile http:location/3.
+:- dynamic   http:location/3.
+
+
+		 /*******************************
+		 *	     HTML-WRITE		*
+		 *******************************/
+
+:- multifile
+	html_write:expand//1,
+	html_write:expand_attribute_value//1,
+	html_write:html_head_expansion/2,
+	html_write:layout/3.
+
+
+		 /*******************************
+		 *	   HTTP-DISPATCH	*
+		 *******************************/
+
+:- multifile
+	http:authenticate/3.
+
+
+		 /*******************************
+		 *	 HTTP-PARAMETERS	*
+		 *******************************/
+
+:- multifile
+	http:convert_parameter/3.
+
+%%	http:convert_parameter(+Type, +ValueIn, -ValueOut) is semidet.
+%
+%	Hook to execute a step in the HTTP parameter conversion process.
+%
+%	@see http_parameters:check_type/4.

packages/http/http_host.pl

@@ -0,0 +1,123 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2007-2010, University of Amsterdam,
+			      VU University Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_host,
+	  [ http_current_host/4		% +Request, -Host, -Port, +Options
+	  ]).
+:- use_module(library('http/thread_httpd')).
+:- use_module(library(socket)).
+:- use_module(library(option)).
+:- use_module(library(settings)).
+
+:- setting(http:public_host, atom, '',
+	   'Name the outside world can use to contact me').
+:- setting(http:public_port, integer, 80,
+	   'Port on the public server').
+
+
+/** <module> Obtain public server location
+
+This library finds the public address of the running server. This can be
+used to construct URLs that are visible   from anywhere on the internet.
+This module was introduced to  deal  with   OpenID,  where  a  reques is
+redirected to the OpenID server, which in   turn redirects to our server
+(see http_openid.pl).
+
+The address is  established  from   the  settings  http:public_host  and
+http:public_port if provided. Otherwise it is deduced from the request.
+*/
+
+
+%%	http_current_host(+Request, -Hostname, -Port, Options) is det.
+%
+%	Current global host and port of the HTTP server.  This is the
+%	basis to form absolute address, which we need for redirection
+%	based interaction such as the OpenID protocol.  Options are:
+%
+%	    * global(+Bool)
+%	    If =true= (default =false=), try to replace a local hostname
+%	    by a world-wide accessible name.
+
+http_current_host(_, Host, Port, _) :-
+	setting(http:public_host, PublicHost), PublicHost \== '', !,
+	Host = PublicHost,
+	setting(http:public_port, Port).
+http_current_host(Request, Host, Port, Options) :-
+	(   memberchk(x_forwarded_host(Forwarded), Request)
+	->  Port = 80,
+	    primary_forwarded_host(Forwarded, Host)
+	;   memberchk(host(Host0), Request),
+	    (	option(global(true), Options, false)
+	    ->	global_host(Host0, Host)
+	    ;	Host = Host0
+	    ),
+	    option(port(Port), Request, 80)
+	->  true
+	;   gethostname(Host),
+	    http_current_server(_Pred, Port)		% TBD: May be more
+	).
+
+
+%%	primary_forwarded_host(+Spec, -Host) is det.
+%
+%	x_forwarded host contains multiple hosts seperated   by  ', ' if
+%	there are multiple proxy servers in   between.  The first one is
+%	the one the user's browser knows about.
+
+primary_forwarded_host(Spec, Host) :-
+	sub_atom(Spec, B, _, _, ','), !,
+	sub_atom(Spec, 0, B, _, Host).
+primary_forwarded_host(Host, Host).
+
+
+%%	global_host(+HostIn, -Host)
+%
+%	Globalize a hostname. Used if we need  to pass our hostname to a
+%	client and expect the client to be   able to contact us. In this
+%	case we cannot use a  name  such   as  `localhost'  or the plain
+%	hostname of the machine. We assume   (possibly  wrongly) that if
+%	the host contains a '.', it is globally accessible.
+%
+%	If the heuristics used by  this   predicate  do not suffice, the
+%	setting http:public_host can be used to override.
+
+global_host(_, Host) :-
+	setting(http:public_host, PublicHost), PublicHost \== '', !,
+	Host = PublicHost.
+global_host(localhost, Host) :- !,
+	gethostname(Host).
+global_host(Local, Host) :-
+	sub_atom(Local, _, _, _, '.'), !,
+	Host = Local.
+global_host(Local, Host) :-
+	tcp_host_to_address(Local, IP),
+	tcp_host_to_address(Host, IP).
+
+

packages/http/http_json.pl

@@ -0,0 +1,206 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_json,
+	  [ reply_json/1,		% +JSON
+	    reply_json/2,		% +JSON, Options
+	    http_read_json/2,		% +Request, -JSON
+	    http_read_json/3		% +Request, -JSON, +Options
+	  ]).
+:- use_module(http_client).
+:- use_module(http_header).
+:- use_module(http_stream).
+:- use_module(json).
+:- use_module(library(option)).
+:- use_module(library(error)).
+:- use_module(library(lists)).
+:- use_module(library(memfile)).
+
+:- multifile
+	http_client:http_convert_data/4,
+	http_client:post_data_hook/3,
+	json_type/1.
+
+
+/** <module> HTTP JSON Plugin module
+
+This  module  inserts  the  JSON  parser  for  documents  of  MIME  type
+=|application/jsonrequest|= and =|application/json|=   requested through
+the http_client.pl library.
+
+Typically JSON is used by Prolog HTTP servers.  Below is a skeleton for
+handling a JSON request, answering in JSON.
+
+==
+handle(Request) :-
+	http_read_json(Request, JSONIn),
+	json_to_prolog(JSONIn, PrologIn),
+	<compute>(PrologIn, PrologOut),		% application body
+	prolog_to_json(PrologOut, JSONOut),
+	reply_json(JSONOut).
+==
+
+This module also integrates JSON support into the http client provided
+by http_client.pl. Posting a JSON query and processing the JSON reply
+(or any other reply understood by http_read_data/3) is as simple as
+below, where Term is a JSON term as described in json.pl and reply is
+of the same format if the server replies with JSON.
+
+==
+	...,
+	http_post(URL, json(Term), Reply, [])
+==
+
+@see	JSON Requests are discussed in http://json.org/JSONRequest.html
+@see	json.pl describes how JSON objects are represented in Prolog terms.
+@see	json_convert.pl converts between more natural Prolog terms and json
+terms.
+*/
+
+http_client:http_convert_data(In, Fields, Data, Options) :-
+	memberchk(content_type(Type), Fields),
+	is_json_type(Type), !,
+	(   memberchk(content_length(Bytes), Fields)
+	->  stream_range_open(In, Range, [size(Bytes)]),
+	    set_stream(Range, encoding(utf8)),
+	    call_cleanup(json_read(Range, Data, Options), close(Range))
+	;   set_stream(In, encoding(utf8)),
+	    json_read(In, Data, Options)
+	).
+
+
+is_json_type(Type) :-
+	json_type(Type), !.
+is_json_type(ContentType) :-
+	json_type(Type),
+	sub_atom(ContentType, 0, _, _, Type), !,
+	strip_utf8(ContentType, Plain),
+	json_type(Plain).
+
+
+%%	strip_utf8(+ContentTypeIn, -ContentType) is det.
+%
+%	Strip an optional  =|;  charset=UTF-8|=.   JSON  data  is always
+%	UTF-8, but some clients seem to insist in sending this.
+
+strip_utf8(ContentType, Plain) :-
+	sub_atom(ContentType, B, _, A, ;),
+	sub_atom(ContentType, _, A, 0, Ext),
+	normalize_space(atom('charset=UTF-8'), Ext), !,
+	sub_atom(ContentType, 0, B, _, CT),
+	normalize_space(atom(Plain), CT).
+strip_utf8(ContentType, ContentType).
+
+
+%%	json_type(?MIMEType:atom) is semidet.
+%
+%	True if MIMEType is a JSON  mimetype. http_json:json_type/1 is a
+%	multifile  predicate  and  may   be    extended   to  facilitate
+%	non-conforming clients.
+
+json_type('application/jsonrequest').
+json_type('application/json').
+
+
+%	http_client:post_data_hook(+Data, +Out:stream, +HdrExtra) is semidet.
+%
+%	Hook into http_post_data/3 that allows for
+%
+%	==
+%	http_post(URL, json(Term), Reply, Options)
+%	==
+%
+%	@tbd avoid creation of intermediate data using chunked output.
+
+http_client:post_data_hook(json(Term), Out, HdrExtra) :-
+	http_client:post_data_hook(json(Term, []), Out, HdrExtra).
+http_client:post_data_hook(json(Term, Options), Out, HdrExtra) :-
+	option(content_type(Type), HdrExtra, 'application/json'),
+	new_memory_file(MemFile),
+	open_memory_file(MemFile, write, Handle),
+	format(Handle, 'Content-type: ~w~n~n', [Type]),
+	json_write(Handle, Term, Options),
+	close(Handle),
+	open_memory_file(MemFile, read, RdHandle),
+	call_cleanup(http_post_data(cgi_stream(RdHandle), Out, HdrExtra),
+		     (	 close(RdHandle),
+			 free_memory_file(MemFile))).
+
+
+%%	http_read_json(+Request, -JSON) is det.
+%%	http_read_json(+Request, -JSON, +Options) is det.
+%
+%	Extract JSON data posted to this HTTP request.
+%
+%	@error	domain_error(mimetype, Found) if the mimetype is
+%		not known (see json_type/1).
+%	@error	domain_error(method, Method) if the request is not
+%		a POST request.
+
+http_read_json(Request, JSON) :-
+	http_read_json(Request, JSON, []).
+
+http_read_json(Request, JSON, Options) :-
+	select_option(content_type(Type), Options, Rest), !,
+	delete(Request, content_type(_), Request2),
+	request_to_json([content_type(Type)|Request2], JSON, Rest).
+http_read_json(Request, JSON, Options) :-
+	request_to_json(Request, JSON, Options).
+
+request_to_json(Request, JSON, Options) :-
+	memberchk(method(Method), Request),
+	memberchk(content_type(Type), Request),
+	(   Method == post
+	->  true
+	;   domain_error(method, Method)
+	),
+	(   is_json_type(Type)
+	->  true
+	;   domain_error(mimetype, Type)
+	),
+	http_read_data(Request, JSON, Options).
+
+
+%%	reply_json(+JSONTerm) is det.
+%%	reply_json(+JSONTerm, +Options) is det.
+%
+%	Formulate a JSON  HTTP  reply.   See  json_write/2  for details.
+%	Options accepts content_type(+Type)  and   options  accepted  by
+%	json_write/3.
+
+reply_json(Term) :-
+	format('Content-type: application/json~n~n'),
+	json_write(current_output, Term).
+
+reply_json(Term, Options) :-
+	select_option(content_type(Type), Options, Rest, 'application/json'),
+	format('Content-type: ~w~n~n', [Type]),
+	json_write(current_output, Term, Rest).

packages/http/http_log.pl

@@ -0,0 +1,263 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2009, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_log,
+	  [ http_log_stream/1,		% -Stream
+	    http_log/2,			% +Format, +Args
+	    http_log_close/1		% +Reason
+	  ]).
+:- use_module(library(settings)).
+:- use_module(library(broadcast)).
+
+:- setting(http:logfile, atom, 'httpd.log',
+	   'File in which to log HTTP requests').
+
+/** <module> HTTP Logging module
+
+Simple module for logging HTTP requests to a file. Logging is enabled by
+loading this file and ensure the setting   http:logfile is not the empty
+atom. The default  file  for  writing   the  log  is  =|httpd.log|=. See
+library(settings) for details.
+
+The  level  of  logging  can  modified  using  the  multifile  predicate
+http_log:nolog/1 to hide HTTP  request  fields   from  the  logfile  and
+http_log:password_field/1   to   hide   passwords   from   HTTP   search
+specifications (e.g. =|/topsecret?password=secret|=).
+*/
+
+:- multifile
+	nolog/1,
+	password_field/1.
+
+% If the log settings change,  simply  close   the  log  and  it will be
+% reopened with the new settings.
+
+:- listen(settings(changed(http:logfile, _, New)),
+	  http_log_close(changed(New))).
+:- listen(http(Message),
+	  http_message(Message)).
+
+
+http_message(request_start(Id, Request)) :- !,
+	http_log_stream(Stream),
+	log_started(Request, Id, Stream).
+http_message(request_finished(Id, Code, Status, CPU, Bytes)) :- !,
+	http_log_stream(Stream),
+	log_completed(Code, Status, Bytes, Id, CPU, Stream).
+
+
+		 /*******************************
+		 *	   LOG ACTIVITY		*
+		 *******************************/
+
+:- dynamic
+	log_stream/1.
+
+%%	http_log_stream(-Stream) is semidet.
+%
+%	Returns handle to open logfile. Fails if no logfile is open and
+%	none is defined.
+
+http_log_stream(Stream) :-
+	log_stream(Stream), !,
+	Stream \== [].
+http_log_stream(Stream) :-
+	setting(http:logfile, File),
+	File \== '', !,
+	with_mutex(http_log,
+		   (   open(File, append, Stream,
+			    [ close_on_abort(false),
+			      encoding(utf8),
+			      buffer(line)
+			    ]),
+		       get_time(Time),
+		       format(Stream,
+			      'server(started, ~0f).~n',
+			      [ Time ]),
+		       assert(log_stream(Stream)),
+		       at_halt(close_log(stopped))
+		   )).
+http_log_stream(_) :-
+	assert(log_stream([])).
+
+%%	http_log_close(+Reason) is det.
+%
+%	If there is a currently open HTTP logfile, close it after adding
+%	a term server(Reason, Time).  to  the   logfile.  This  call  is
+%	intended for cooperation with the Unix logrotate facility
+%	using the following schema:
+%
+%	    * Move logfile (the HTTP server keeps writing to the moved
+%	    file)
+%	    * Inform the server using an HTTP request that calls
+%	    http_log_close/1
+%	    * Compress the moved logfile
+%
+%	@author Suggested by Jacco van Ossenbruggen
+
+http_log_close(Reason) :-
+	with_mutex(http_log, close_log(Reason)).
+
+close_log(Reason) :-
+	retract(log_stream(Stream)), !,
+	(   Stream == []
+	->  true
+	;   get_time(Time),
+	    format(Stream, 'server(~q, ~0f).~n', [ Reason, Time ]),
+	    close(Stream)
+	).
+close_log(_).
+
+%%	http_log(+Format, +Args) is det.
+%
+%	Write message from Format and Args   to log-stream. See format/2
+%	for details. Succeed without side  effects   if  logging  is not
+%	enabled.
+
+http_log(Format, Args) :-
+	(   http_log_stream(Stream)
+	->  format(Stream, Format, Args)
+	;   true
+	).
+
+
+%%	log_started(+Request, +Id, +Stream) is det.
+%
+%	Write log message that Request was started to Stream.
+%
+%	@param	Filled with sequence identifier for the request
+
+log_started(Request, Id, Stream) :-
+	get_time(Now),
+	log_request(Request, LogRequest),
+	format_time(string(HDate), '%+', Now),
+	format(Stream,
+	       '/*~s*/ request(~q, ~3f, ~q).~n',
+	       [HDate, Id, Now, LogRequest]).
+
+%%	log_request(+Request, -Log)
+%
+%	Remove passwords from the request to avoid sending them to the
+%	logfiles.
+
+log_request([], []).
+log_request([search(Search0)|T0], [search(Search)|T]) :- !,
+	mask_passwords(Search0, Search),
+	log_request(T0, T).
+log_request([H|T0], T) :-
+	nolog(H), !,
+	log_request(T0, T).
+log_request([H|T0], [H|T]) :-
+	log_request(T0, T).
+
+mask_passwords([], []).
+mask_passwords([Name=_|T0], [Name=xxx|T]) :-
+	password_field(Name), !,
+	mask_passwords(T0, T).
+mask_passwords([H|T0], [H|T]) :-
+	mask_passwords(T0, T).
+
+%%	password_field(+Field) is semidet.
+%
+%	Multifile predicate that can be defined to hide passwords from
+%	the logfile.
+
+password_field(password).
+password_field(pwd0).
+password_field(pwd1).
+password_field(pwd2).
+
+
+%%	nolog(+HTTPField)
+%
+%	Multifile  predicate  that  can  be   defined  to  hide  request
+%	parameters from the request logfile.
+
+nolog(input(_)).
+nolog(accept(_)).
+nolog(accept_language(_)).
+nolog(accept_encoding(_)).
+nolog(accept_charset(_)).
+nolog(pool(_)).
+nolog(protocol(_)).
+nolog(referer(R)) :-
+	sub_atom(R, _, _, _, password), !.
+
+%%	log_completed(+Code, +Status, +Bytes, +Id, +CPU, +Stream) is det.
+%
+%	Write log message to Stream from a call_cleanup/3 call.
+%
+%	@param Status	2nd argument of call_cleanup/3
+%	@param Id	Term identifying the completed request
+%	@param CPU0	CPU time at time of entrance
+%	@param Stream	Stream to write to (normally from http_log_stream/1).
+
+log_completed(Code, Status, Bytes, Id, CPU, Stream) :-
+	is_stream(Stream),
+	log_check_deleted(Stream), !,
+	log(Code, Status, Bytes, Id, CPU, Stream).
+log_completed(Code, Status, Bytes, Id, CPU0, _) :-
+	http_log_stream(Stream), !,	% Logfile has changed!
+	log_completed(Code, Status, Bytes, Id, CPU0, Stream).
+log_completed(_,_,_,_,_,_).
+
+
+%%	log_check_deleted(+Stream) is semidet.
+%
+%	If the link-count of the stream has   dropped  to zero, the file
+%	has been deleted/moved. In this case the  log file is closed and
+%	log_check_deleted/6 will open a  new   one.  This  provides some
+%	support for cleaning up the logfile   without  shutting down the
+%	server.
+%
+%	@see logrotate(1) to manage logfiles on Unix systems.
+
+log_check_deleted(Stream) :-
+	stream_property(Stream, nlink(Links)),
+	Links == 0, !,
+	http_log_close(log_file_deleted),
+	fail.
+log_check_deleted(_).
+
+
+log(Code, ok, Bytes, Id, CPU, Stream) :- !,
+	format(Stream, 'completed(~q, ~2f, ~q, ~q, ok).~n',
+	       [ Id, CPU, Bytes, Code ]).
+log(Code, Status, Bytes, Id, CPU, Stream) :-
+	(   map_exception(Status, Term)
+	->  true
+	;   message_to_string(Status, String),
+	    Term = error(String)
+	),
+	format(Stream, 'completed(~q, ~2f, ~q, ~q, ~q).~n',
+	       [ Id, CPU, Bytes, Code, Term ]).
+
+map_exception(http_reply(Reply), Reply).
+map_exception(error(existence_error(http_location, Location), _Stack),
+	      error(404, Location)).

packages/http/http_mime_plugin.pl

@@ -0,0 +1,79 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_mime_plugin, []).
+:- use_module(http_client).
+:- use_module(library(memfile)).
+:- use_module(library(mime)).
+
+/** <module> MIME client plugin
+
+This plugin for library(http_client)   automatically translates messages
+with content-type =|multipart/form-data|= into a list   of  Name = Value
+pairs, greatly simplifying the processing of   forms  with this type. It
+relies  on  library(mime),  which  in   turn    relies   on   a  foreign
+implementation of the rfc2045 (mime) specifications.
+*/
+
+:- multifile
+	http_client:http_convert_data/4,
+	http_parameters:form_data_content_type/1.
+
+http_client:http_convert_data(In, Fields, Data, Options) :-
+	memberchk(content_type(Type), Fields),
+	(   memberchk(mime_version(MimeVersion), Fields)
+	;   sub_atom(Type, 0, _, _, 'multipart/form-data'),
+	    MimeVersion = '1.0'
+	), !,
+	new_memory_file(MemFile),
+	open_memory_file(MemFile, write, Tmp),
+	format(Tmp, 'Mime-Version: ~w\n', [MimeVersion]),
+	format(Tmp, 'Content-Type: ~w\n\n', [Type]),
+	http_read_data(Fields, _, [in(In), to(stream(Tmp))|Options]),
+	close(Tmp),
+	open_memory_file(MemFile, read, MimeIn),
+	mime_parse(stream(MimeIn), Data0),
+	close(MimeIn),
+	free_memory_file(MemFile),
+	mime_to_form(Data0, Data).
+
+mime_to_form(mime(A,'',Parts), Form) :-
+	memberchk(type('multipart/form-data'), A),
+	mime_form_fields(Parts, Form), !.
+mime_to_form(Mime, Mime).
+
+mime_form_fields([], []).
+mime_form_fields([mime(A, V, [])|T0], [Name=V|T]) :-
+	memberchk(name(Name), A),
+	mime_form_fields(T0, T).
+
+http_parameters:form_data_content_type(ContentType) :-
+	sub_atom(ContentType, 0, _, _, 'multipart/form-data').

packages/http/http_open.pl

@@ -0,0 +1,644 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2008, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+
+:- module(http_open,
+	  [ http_open/3,		% +URL, -Stream, +Options
+	    http_set_authorization/2	% +URL, +Authorization
+	  ]).
+
+:- use_module(library(url)).
+:- use_module(library(readutil)).
+:- use_module(library(socket)).
+:- use_module(library(lists)).
+:- use_module(library(option)).
+:- use_module(library(error)).
+:- use_module(library(base64)).
+:- use_module(library(debug)).
+
+:- expects_dialect(swi).
+:- assert(system:swi_io).
+
+user_agent('SWI-Prolog <http://www.swi-prolog.org>').
+
+/** <module> Simple HTTP client
+
+This library provides a light-weight HTTP client library to get the data
+from a URL. The functionality of the  library can be extended by loading
+two additional modules that acts as plugins:
+
+    * library(http/http_chunked)
+    Loading this library causes http_open/3 to support chunked
+    transfer encoding.
+
+    * library(http/http_header)
+    Loading this library causes http_open/3 to support the =POST= method
+    in addition to =GET= and =HEAD=.
+
+Here is a simple example to fetch a web-page:
+
+  ==
+  ?- http_open('http://www.google.com/search?q=prolog', In, []),
+     copy_stream_data(In, user_output),
+     close(In).
+  <!doctype html><head><title>prolog - Google Search</title><script>
+  ...
+  ==
+
+The example below fetches the modification time of a web-page. Note that
+Modified is '' if the web-server does not provide a time-stamp for the
+resource. See also parse_time/2.
+
+  ==
+  modified(URL, Stamp) :-
+	  http_open(URL, In,
+		    [ method(head),
+		      header(last_modified, Modified)
+		    ]),
+	  close(In),
+	  Modified \== '',
+	  parse_time(Modified, Stamp).
+  close(In).
+  ==
+
+@see xpath/3
+@see http_get/3
+@see http_post/4
+*/
+
+:- multifile
+	http:encoding_filter/3,		  % +Encoding, +In0,  -In
+	http:current_transfer_encoding/1, % ?Encoding
+	http:http_protocol_hook/7.	  % +Protocol, +Parts, +In, +Out,
+					  % -NewIn, -NewOut, +Options
+
+
+%%	http_open(+URL, -Stream, +Options) is det.
+%
+%	Open the data at the HTTP  server   as  a  Prolog stream. URL is
+%	either an atom  specifying  a  URL   or  a  list  representing a
+%	broken-down URL compatible to parse_url/2.  After this predicate
+%	succeeds the data can be read from Stream. After completion this
+%	stream must be  closed  using   the  built-in  Prolog  predicate
+%	close/1. Options provides additional options:
+%
+%	  * authorization(+Term)
+%	  Send authorization.  Currently only supports basic(User,Password).
+%	  See also http_set_authorization/2.
+%
+%	  * final_url(-FinalURL)
+%	  Unify FinalURL} with the final  destination. This differs from
+%	  the  original  URL  if  the  returned  head  of  the  original
+%	  indicates an HTTP redirect (codes 301,  302 or 303). Without a
+%	  redirect, FinalURL is unified with   the  canonical version of
+%	  URL using:
+%
+%	      ==
+%	      parse_url(URL, Parts),
+%	      parse_url(FinalURL, Parts)
+%	      ==
+%
+%	  * header(Name, -AtomValue)
+%	  If provided, AtomValue is  unified  with   the  value  of  the
+%	  indicated  field  in  the  reply    header.  Name  is  matched
+%	  case-insensitive and the underscore  (_)   matches  the hyphen
+%	  (-). Multiple of these options  may   be  provided  to extract
+%	  multiple  header  fields.  If  the  header  is  not  available
+%	  AtomValue is unified to the empty atom ('').
+%
+%	  * method(+Method)
+%	  One of =get= (default) or =head=.   The  =head= message can be
+%	  used in combination with  the   header(Name,  Value) option to
+%	  access information on the resource   without actually fetching
+%	  the resource itself.  The  returned   stream  must  be  closed
+%	  immediately.   If   library(http/http_header)     is   loaded,
+%	  http_open/3 also supports =post=. See the post(Data) option.
+%
+%	  * size(-Size)
+%	  Size is unified with the   integer value of =|Content-Length|=
+%	  in the reply header.
+%
+%	  * timeout(+Timeout)
+%	  If provided, set a timeout on   the stream using set_stream/2.
+%	  With this option if no new data arrives within Timeout seconds
+%	  the stream raises an exception.  Default   is  to wait forever
+%	  (=infinite=).
+%
+%	  * post(+Data)
+%	  Provided if library(http/http_header) is also loaded.  Data is
+%	  handed to http_post_data/3.
+%
+%	  * proxy(+Host, +Port)
+%	  Use an HTTP proxy to connect to the outside world.
+%
+%	  * proxy_authorization(+Authorization)
+%	  Send authorization to the proxy.  Otherwise   the  same as the
+%	  =authorization= option.
+%
+%	  * request_header(Name = Value)
+%	  Additional  name-value  parts  are  added   in  the  order  of
+%	  appearance to the HTTP request   header.  No interpretation is
+%	  done.
+%
+%	  * user_agent(+Agent)
+%	  Defines the value of the  =|User-Agent|=   field  of  the HTTP
+%	  header. Default is =|SWI-Prolog (http://www.swi-prolog.org)|=.
+%
+%	@error	existence_error(url, Id)
+
+http_open(URL, Stream, Options) :-
+	atom(URL), !,
+	parse_url_ex(URL, Parts),
+	add_authorization(URL, Options, Options1),
+	http_open(Parts, Stream, Options1).
+http_open(Parts, Stream, Options0) :-
+	memberchk(proxy(Host, ProxyPort), Options0), !,
+	parse_url_ex(Location, Parts),
+	Options = [visited(Parts)|Options0],
+	open_socket(Host:ProxyPort, In, Out, Options),
+        option(protocol(Protocol), Parts, http),
+	default_port(Protocol, DefPort),
+	option(port(Port), Parts, DefPort),
+	host_and_port(Host, DefPort, Port, HostPort),
+	add_authorization(Parts, Options, Options1),
+	send_rec_header(Out, In, Stream, HostPort, Location, Parts, Options1),
+	return_final_url(Options).
+http_open(Parts, Stream, Options0) :-
+	memberchk(host(Host), Parts),
+        option(protocol(Protocol), Parts, http),
+	default_port(Protocol, DefPort),
+	option(port(Port), Parts, DefPort),
+	http_location(Parts, Location),
+	Options = [visited(Parts)|Options0],
+	open_socket(Host:Port, SocketIn, SocketOut, Options),
+        (   http:http_protocol_hook(Protocol, Parts,
+				    SocketIn, SocketOut,
+				    In, Out, Options)
+        ->  true
+        ;   In = SocketIn,
+            Out = SocketOut
+        ),
+	host_and_port(Host, DefPort, Port, HostPort),
+	add_authorization(Parts, Options, Options1),
+	send_rec_header(Out, In, Stream, HostPort, Location, Parts, Options1),
+	return_final_url(Options).
+
+http:http_protocol_hook(http, _, In, Out, In, Out, _).
+
+default_port(https, 443) :- !.
+default_port(_,	    80).
+
+host_and_port(Host, DefPort, DefPort, Host) :- !.
+host_and_port(Host, _,       Port,    Host:Port).
+
+%%	send_rec_header(+Out, +In, -InStream,
+%%			+Host, +Location, +Parts, +Options) is det.
+%
+%	Send header to Out and process reply.  If there is an error or
+%	failure, close In and Out and return the error or failure.
+
+send_rec_header(Out, In, Stream, Host, Location, Parts, Options) :-
+	(   catch(guarded_send_rec_header(Out, In, Stream,
+					  Host, Location, Parts, Options),
+		  E, true)
+	->  (   var(E)
+	    ->	close(Out)
+	    ;	force_close(In, Out),
+		throw(E)
+	    )
+	;   force_close(In, Out),
+	    fail
+	).
+
+guarded_send_rec_header(Out, In, Stream, Host, Location, Parts, Options) :-
+	user_agent(Agent, Options),
+	method(Options, MNAME),
+	http_version(Version),
+	format(Out,
+	       '~w ~w HTTP/~w\r\n\
+	       Host: ~w\r\n\
+	       User-Agent: ~w\r\n\
+	       Connection: close\r\n',
+	       [MNAME, Location, Version, Host, Agent]),
+	x_headers(Options, Out),
+        (   option(post(PostData), Options)
+        ->  http_header:http_post_data(PostData, Out, [])
+        ;   format(Out, '\r\n', [])
+        ),
+	flush_output(Out),
+					% read the reply header
+	read_header(In, Code, Comment, Lines),
+	do_open(Code, Comment, Lines, Options, Parts, In, Stream).
+
+
+%%	http_version(-Version:atom) is det.
+%
+%	HTTP version we publish. We  can  only   use  1.1  if we support
+%	chunked encoding, which means http_chunked.pl must be loaded.
+
+http_version('1.1') :-
+	http:current_transfer_encoding(chunked), !.
+http_version('1.0').
+
+force_close(S1, S2) :-
+	close(S1, [force(true)]),
+	close(S2, [force(true)]).
+
+method(Options, MNAME) :-
+	option(post(_), Options), !,
+	option(method(M), Options, post),
+	(   map_method(M, MNAME0)
+	->  MNAME = MNAME0
+	;   domain_error(method, M)
+	).
+method(Options, MNAME) :-
+	option(method(M), Options, get),
+	(   map_method(M, MNAME0)
+	->  MNAME = MNAME0
+	;   domain_error(method, M)
+	).
+
+map_method(get,  'GET').
+map_method(head, 'HEAD').
+map_method(post, 'POST') :-
+	current_predicate(http_header:http_post_data/3).
+
+
+%%	x_headers(+Options, +Out) is det.
+%
+%	Emit extra headers from   request_header(Name=Value)  options in
+%	Options.
+
+x_headers([], _).
+x_headers([H|T], Out) :- !,
+	x_header(H, Out),
+	x_headers(T, Out).
+
+x_header(request_header(Name=Value), Out) :- !,
+	format(Out, '~w: ~w\r\n', [Name, Value]).
+x_header(proxy_authorization(ProxyAuthorization), Out) :- !,
+	auth_header(ProxyAuthorization, 'Proxy-Authorization', Out).
+x_header(authorization(Authorization), Out) :- !,
+	auth_header(Authorization, 'Authorization', Out).
+x_header(_, _).
+
+auth_header(basic(User, Password), Header, Out) :- !,
+	format(codes(Codes), '~w:~w', [User, Password]),
+	phrase(base64(Codes), Base64Codes),
+	format(Out, '~w: basic ~s\r\n', [Header, Base64Codes]).
+auth_header(Auth, _, _) :-
+	domain_error(authorization, Auth).
+
+user_agent(Agent, Options) :-
+	(   option(user_agent(Agent), Options)
+	->  true
+	;   user_agent(Agent)
+	).
+
+%%	do_open(+HTTPStatusCode, +HTTPStatusComment, +Header,
+%%		+Options, +Parts, +In, -FinalIn) is det.
+%
+%	Handle the HTTP status. If 200, we   are ok. If a redirect, redo
+%	the open, returning a new stream. Else issue an error.
+%
+%	@error	existence_error(url, URL)
+
+do_open(200, _, Lines, Options, Parts, In0, In) :- !,
+	return_size(Options, Lines),
+	return_fields(Options, Lines),
+	transfer_encoding_filter(Lines, In0, In),
+					% properly re-initialise the stream
+	parse_url_ex(Id, Parts),
+	set_stream(In, file_name(Id)),
+	set_stream(In, record_position(true)).
+					% Handle redirections
+do_open(Code, _, Lines, Options, Parts, In, Stream) :-
+	redirect_code(Code),
+	location(Lines, Location), !,
+	debug(http(redirect), 'http_open: redirecting to ~w', [Location]),
+	parse_url_ex(Location, Parts, Redirected),
+	close(In),
+	http_open(Redirected, Stream, [visited(Redirected)|Options]).
+					% report anything else as error
+do_open(Code, Comment, _,  _, Parts, _, _) :-
+	parse_url_ex(Id, Parts),
+	(   map_error_code(Code, Error)
+	->  Formal =.. [Error, url, Id]
+	;   Formal = existence_error(url, Id)
+	),
+	throw(error(Formal, context(_, status(Code, Comment)))).
+
+%%	map_error_code(+HTTPCode, -PrologError) is semidet.
+%
+%	Map HTTP error codes to Prolog errors.
+%
+%	@tbd	Many more maps. Unfortunately many have no sensible Prolog
+%		counterpart.
+
+map_error_code(401, permission_error).
+map_error_code(403, permission_error).
+map_error_code(404, existence_error).
+map_error_code(405, permission_error).
+map_error_code(407, permission_error).
+map_error_code(410, existence_error).
+
+redirect_code(301).			% moved permanently
+redirect_code(302).			% moved temporary
+redirect_code(303).			% see also
+
+%%	open_socket(+Address, -In, -Out, +Options) is det.
+%
+%	Create and connect a client socket to Address.  Options
+%
+%	    * timeout(+Timeout)
+%	    Sets timeout on the stream, *after* connecting the
+%	    socket.
+%
+%	@tbd	Make timeout also work on tcp_connect/4.
+%	@tbd	This is the same as do_connect/4 in http_client.pl
+
+open_socket(Address, In, Out, Options) :-
+	debug(http(open), 'http_open: Connecting to ~p ...', [Address]),
+	tcp_socket(Socket),
+	catch(tcp_connect(Socket, Address, In, Out),
+	      E,
+	      (	  tcp_close_socket(Socket),
+		  throw(E)
+	      )),
+	debug(http(open), '\tok ~p --> ~p', [In, Out]),
+	set_stream(In, record_position(false)),
+	(   memberchk(Options, timeout(Timeout))
+	->  set_stream(In, timeout(Timeout))
+	;   true
+	).
+
+
+return_size(Options, Lines) :-
+	memberchk(size(Size), Options), !,
+	content_length(Lines, Size).
+return_size(_, _).
+
+return_fields([], _).
+return_fields([header(Name, Value)|T], Lines) :- !,
+	atom_codes(Name, Codes),
+	(   member(Line, Lines),
+	    phrase(atom_field(Codes, Value), Line)
+	->  true
+	;   Value = ''
+	),
+	return_fields(T, Lines).
+return_fields([_|T], Lines) :-
+	return_fields(T, Lines).
+
+
+%%	return_final_url(+Options) is semidet.
+%
+%	If Options contains final_url(URL), unify URL with the final
+%	URL after redirections.
+
+return_final_url(Options) :-
+	memberchk(final_url(URL), Options),
+	var(URL), !,
+	memberchk(visited(Parts), Options),
+	parse_url_ex(URL, Parts).
+return_final_url(_).
+
+
+%%	transfer_encoding_filter(+Lines, +In0, -In) is det.
+%
+%	Install filters depending on the encoding.
+
+transfer_encoding_filter(Lines, In0, In) :-
+	transfer_encoding(Lines, Encoding), !,
+	(   http:encoding_filter(Encoding, In0, In)
+	->  true
+	;   	domain_error(http_encoding, Encoding)
+	).
+transfer_encoding_filter(_, In, In).
+
+
+%%	transfer_encoding(+Lines, -Encoding) is semidet.
+%
+%	True if Encoding is the value of the =|Transfer-encoding|=
+%	header.
+
+transfer_encoding(Lines, Encoding) :-
+	member(Line, Lines),
+	phrase(transfer_encoding(Encoding0), Line), !,
+	debug(http(transfer_encoding), 'Transfer-encoding: ~w', [Encoding0]),
+	Encoding = Encoding0.
+
+transfer_encoding(Encoding) -->
+	field("transfer-encoding"),
+	rest(Encoding).
+
+%%	read_header(+In:stream, -Code:int, -Comment:atom, -Lines:list)
+%
+%	Read the HTTP reply-header.
+%
+%	@param Code	Numeric HTTP reply-code
+%	@param Comment	Comment of reply-code as atom
+%	@param Lines	Remaining header lines as code-lists.
+
+read_header(In, Code, Comment, Lines) :-
+	read_line_to_codes(In, Line),
+	phrase(first_line(Code, Comment), Line),
+	read_line_to_codes(In, Line2),
+	rest_header(Line2, In, Lines).
+
+rest_header("", _, []) :- !.		% blank line: end of header
+rest_header(L0, In, [L0|L]) :-
+	read_line_to_codes(In, L1),
+	rest_header(L1, In, L).
+
+%%	content_length(+Header, -Length:int) is semidet.
+%
+%	Find the Content-Length in an HTTP reply-header.
+
+content_length(Lines, Length) :-
+	member(Line, Lines),
+	phrase(content_length(Length0), Line), !,
+	Length = Length0.
+
+location(Lines, Location) :-
+	member(Line, Lines),
+	phrase(atom_field("location", Location), Line), !.
+
+first_line(Code, Comment) -->
+	"HTTP/", [_], ".", [_],
+	skip_blanks,
+	integer(Code),
+	skip_blanks,
+	rest(Comment).
+
+atom_field(Name, Value) -->
+	field(Name),
+	rest(Value).
+
+content_length(Len) -->
+	field("content-length"),
+	integer(Len).
+
+field([]) -->
+	":",
+	skip_blanks.
+field([H|T]) -->
+	[C],
+	{ match_header_char(H, C)
+	},
+	field(T).
+
+match_header_char(C, C) :- !.
+match_header_char(C, U) :-
+	code_type(C, to_lower(U)), !.
+match_header_char(0'_, 0'-).
+
+
+skip_blanks -->
+	[C],
+	{ code_type(C, white)
+	}, !,
+	skip_blanks.
+skip_blanks -->
+	[].
+
+%%	integer(-Int)//
+%
+%	Read 1 or more digits and return as integer.
+
+integer(Code) -->
+	digit(D0),
+	digits(D),
+	{ number_codes(Code, [D0|D])
+	}.
+
+digit(C) -->
+	[C],
+	{ code_type(C, digit)
+	}.
+
+digits([D0|D]) -->
+	digit(D0), !,
+	digits(D).
+digits([]) -->
+	[].
+
+%%	rest(-Atom:atom)//
+%
+%	Get rest of input as an atom.
+
+rest(A,L,[]) :-
+	atom_codes(A, L).
+
+
+		 /*******************************
+		 *   AUTHORIZATION MANAGEMENT	*
+		 *******************************/
+
+%%	http_set_authorization(+URL, +Authorization) is det.
+%
+%	Set user/password to supply with URLs   that have URL as prefix.
+%	If  Authorization  is  the   atom    =|-|=,   possibly   defined
+%	authorization is cleared.  For example:
+%
+%	==
+%	?- http_set_authorization('http://www.example.com/private/',
+%				  basic('John', 'Secret'))
+%	==
+%
+%	@tbd	Move to a separate module, so http_get/3, etc. can use this
+%		too.
+
+:- dynamic
+	stored_authorization/2,
+	cached_authorization/2.
+
+http_set_authorization(URL, Authorization) :-
+	must_be(atom, URL),
+	retractall(stored_authorization(URL, _)),
+	(   Authorization = (-)
+	->  true
+	;   check_authorization(Authorization),
+	    assert(stored_authorization(URL, Authorization))
+	),
+	retractall(cached_authorization(_,_)).
+
+check_authorization(Var) :-
+	var(Var), !,
+	instantiation_error(Var).
+check_authorization(basic(User, Password)) :-
+	must_be(atom, User),
+	must_be(atom, Password).
+
+%%	authorization(+URL, -Authorization) is semdet.
+%
+%	True if Authorization must be supplied for URL.
+%
+%	@tbd	Cleanup cache if it gets too big.
+
+authorization(_, _) :-
+	\+ stored_authorization(_, _), !,
+	fail.
+authorization(URL, Authorization) :-
+	cached_authorization(URL, Authorization), !,
+	Authorization \== (-).
+authorization(URL, Authorization) :-
+	(   stored_authorization(Prefix, Authorization),
+	    sub_atom(URL, 0, _, _, Prefix)
+	->  assert(cached_authorization(URL, Authorization))
+	;   assert(cached_authorization(URL, -)),
+	    fail
+	).
+
+add_authorization(_, Options, Options) :-
+	option(authorization(_), Options), !.
+add_authorization(For, Options0, Options) :-
+	stored_authorization(_, _) ->	% quick test to avoid work
+	(   atom(For)
+	->  URL = For
+	;   parse_url_ex(URL, For)
+	),
+	authorization(URL, Auth), !,
+	Options = [authorization(Auth)|Options0].
+add_authorization(_, Options, Options).
+
+
+parse_url_ex(URL, Parts) :-
+	parse_url(URL, Parts), !.
+parse_url_ex(URL, _) :-
+	domain_error(url, URL).		% Syntax error?
+
+parse_url_ex(URL, RelativeTo, Parts) :-
+	parse_url(URL, RelativeTo, Parts), !.
+parse_url_ex(URL, _, _) :-
+	domain_error(url, URL).		% Syntax error?
+
+:- retract(system:swi_io).

packages/http/http_parameters.pl

@@ -0,0 +1,283 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2004-2009, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+
+:- module(http_parameters,
+	  [ http_parameters/2,		% +Request, -Params
+	    http_parameters/3		% +Request, -Params, +TypeG
+	  ]).
+:- use_module(http_client).
+:- use_module(http_mime_plugin).
+:- use_module(http_hook).
+:- use_module(library(debug)).
+:- use_module(library(option)).
+:- use_module(library(lists)).
+:- use_module(library(error)).
+
+:- meta_predicate
+	http_parameters(+, ?, :).
+
+%%	http_parameters(+Request, ?Parms) is det.
+%%	http_parameters(+Request, ?Parms, :Options) is det.
+%
+%	Get HTTP GET  or  POST   form-data,  applying  type  validation,
+%	default values, etc.  Provided options are:
+%
+%		* attribute_declarations(:Goal)
+%		Causes the declarations for an attributed named A to be
+%		fetched using call(Goal, A, Declarations).
+%
+%		* form_data(-Data)
+%		Return the data read from the GET por POST request as a
+%		list Name = Value.  All data, including name/value pairs
+%		used for Parms, is unified with Data.
+
+http_parameters(Request, Params) :-
+	http_parameters(Request, Params, []).
+
+http_parameters(Request, Params, Options) :-
+	must_be(list, Params),
+	meta_options(is_meta, Options, QOptions),
+	option(attribute_declarations(DeclGoal), QOptions, -),
+	http_parms(Request, Params, DeclGoal, Form),
+	(   memberchk(form_data(RForm), QOptions)
+	->  RForm = Form
+	;   true
+	).
+
+is_meta(attribute_declarations).
+
+
+http_parms(Request, Params, DeclGoal, Data) :-
+	memberchk(method(post), Request),
+	memberchk(content_type(Content), Request),
+	form_data_content_type(Content), !,
+	debug(post_request, 'POST Request: ~p', [Request]),
+	http_read_data(Request, Data, []),
+	debug(post, 'POST Data: ~p', [Data]),
+	fill_parameters(Params, Data, DeclGoal).
+http_parms(Request, Params, DeclGoal, Search) :-
+	(   memberchk(search(Search), Request)
+	->  true
+	;   Search = []
+	),
+	fill_parameters(Params, Search, DeclGoal).
+
+:- multifile
+	form_data_content_type/1.
+
+form_data_content_type('application/x-www-form-urlencoded').
+
+%%	fill_parameters(+ParamDecls, +FormData, +DeclGoal)
+%
+%	Fill values from the parameter list
+
+fill_parameters([], _, _).
+fill_parameters([H|T], FormData, DeclGoal) :-
+	fill_parameter(H, FormData, DeclGoal),
+	fill_parameters(T, FormData, DeclGoal).
+
+fill_parameter(H, _, _) :-
+	var(H), !,
+	instantiation_error(H).
+fill_parameter(group(Members, _Options), FormData, DeclGoal) :- !,
+	fill_parameters(Members, FormData, DeclGoal).
+fill_parameter(H, FormData, _) :-
+	H =.. [Name,Value,Options], !,
+	fill_param(Name, Value, Options, FormData).
+fill_parameter(H, FormData, DeclGoal) :-
+	H =.. [Name,Value],
+	(   call(DeclGoal, Name, Options)
+	->  true
+	;   throw(error(existence_error(attribute_declaration, Name), _))
+	),
+	fill_param(Name, Value, Options, FormData).
+
+fill_param(Name, Values, Options, FormData) :-
+	memberchk(zero_or_more, Options), !,
+	fill_param_list(FormData, Name, Values, Options).
+fill_param(Name, Values, Options, FormData) :-
+	memberchk(list(Type), Options), !,
+	fill_param_list(FormData, Name, Values, [Type|Options]).
+fill_param(Name, Value, Options, FormData) :-
+	(   memberchk(Name=Value0, FormData),
+	    Value0 \== ''		% Not sure
+	->  check_type(Options, Name, Value0, Value)
+	;   memberchk(default(Value), Options)
+	->  true
+	;   memberchk(optional(true), Options)
+	->  true
+	;   throw(error(existence_error(form_data, Name), _))
+	).
+
+
+fill_param_list([], _, [], _).
+fill_param_list([Name=Value0|Form], Name, [Value|VT], Options) :- !,
+	check_type(Options, Name, Value0, Value),
+	fill_param_list(Form, Name, VT, Options).
+fill_param_list([_|Form], Name, VT, Options) :-
+	fill_param_list(Form, Name, VT, Options).
+
+
+%%	check_type(+Options, +FieldName, +ValueIn, -ValueOut) is det.
+%
+%	Conversion of an HTTP form value. First tries the multifile hook
+%	http:convert_parameter/3 and next the built-in checks.
+%
+%	@param Option		List as provided with the parameter
+%	@param FieldName	Name of the HTTP field (for better message)
+%	@param ValueIn		Atom value as received from HTTP layer
+%	@param ValueOut		Possibly converted final value
+%	@error type_error(Type, Value)
+
+check_type([], _, Value, Value).
+check_type([H|T], Field, Value0, Value) :-
+	(   check_type_no_error(H, Value0, Value1)
+	->  check_type(T, Field, Value1, Value)
+	;   format(string(Msg), 'HTTP parameter ~w', [Field]),
+	    throw(error(type_error(H, Value0),
+			context(_, Msg)))
+	).
+
+check_type_no_error(Type, In, Out) :-
+	http:convert_parameter(Type, In, Out), !.
+check_type_no_error(Type, In, Out) :-
+	check_type3(Type, In, Out).
+
+%%	check_type3(+Type, +ValueIn, -ValueOut) is semidet.
+%
+%	HTTP parameter type-check for types that need converting.
+
+check_type3((T1;T2), In, Out) :- !,
+	(   check_type_no_error(T1, In, Out)
+	->  true
+	;   check_type_no_error(T2, In, Out)
+	).
+check_type3(number, Atom, Number) :- !,
+	catch(atom_number(Atom, Number), _, fail).
+check_type3(integer, Atom, Integer) :- !,
+	catch(atom_number(Atom, Integer), _, fail),
+	integer(Integer).
+check_type3(nonneg, Atom, Integer) :- !,
+	catch(atom_number(Atom, Integer), _, fail),
+	integer(Integer),
+	Integer >= 0.
+check_type3(float, Atom, Float) :- !,
+	catch(atom_number(Atom, Number), _, fail),
+	Float is float(Number).
+check_type3(between(Low, High), Atom, Value) :- !,
+	atom_number(Atom, Number),
+	(   (float(Low) ; float(High))
+	->  Value is float(Number)
+	;   Value = Number
+	),
+	must_be(between(Low, High), Value).
+check_type3(boolean, Atom, Bool) :- !,
+	truth(Atom, Bool).
+check_type3(Type, Atom, Atom) :-
+	check_type2(Type, Atom).
+
+%%	check_type2(+Type, +ValueIn) is semidet.
+%
+%	HTTP parameter type-check for types that need no conversion.
+
+check_type2(oneof(Set), Value) :- !,
+	memberchk(Value, Set).
+check_type2(length > N, Value) :- !,
+	atom_length(Value, Len),
+	Len > N.
+check_type2(length >= N, Value) :- !,
+	atom_length(Value, Len),
+	Len >= N.
+check_type2(length < N, Value) :- !,
+	atom_length(Value, Len),
+	Len < N.
+check_type2(length =< N, Value) :- !,
+	atom_length(Value, Len),
+	Len =< N.
+check_type2(_, _).
+
+%%	truth(+In, -Boolean) is semidet.
+%
+%	Translate some commonly used textual   representations  for true
+%	and false into their canonical representation.
+
+truth(true,  true).
+truth(yes,   true).
+truth(on,    true).
+truth('1',   true).
+
+truth(false, false).
+truth(no,    false).
+truth(off,   false).
+truth('0',   false).
+
+
+		 /*******************************
+		 *	   XREF SUPPORT		*
+		 *******************************/
+
+:- multifile
+	prolog:called_by/2,
+	emacs_prolog_colours:goal_colours/2.
+
+prolog:called_by(http_parameters(_,_,Options), [G+2]) :-
+	option(attribute_declarations(G), Options, _),
+	callable(G), !.
+
+emacs_prolog_colours:goal_colours(http_parameters(_,_,Options),
+				  built_in-[classify, classify, Colours]) :-
+	option_list_colours(Options, Colours).
+
+option_list_colours(Var, error) :-
+	var(Var), !.
+option_list_colours([], classify) :- !.
+option_list_colours(Term, list-Elements) :-
+	Term = [_|_], !,
+	option_list_colours_2(Term, Elements).
+option_list_colours(_, error).
+
+option_list_colours_2(Var, classify) :-
+	var(Var).
+option_list_colours_2([], []).
+option_list_colours_2([H0|T0], [H|T]) :-
+	option_colours(H0, H),
+	option_list_colours_2(T0, T).
+
+option_colours(Var,  classify) :-
+	var(Var), !.
+option_colours(_=_,  built_in-[classify,classify]) :- !.
+option_colours(attribute_declarations(_), 		% DCG = is a hack!
+	       option(attribute_declarations)-[dcg]) :- !.
+option_colours(Term, option(Name)-[classify]) :-
+	compound(Term),
+	Term =.. [Name,_Value], !.
+option_colours(_, error).

packages/http/http_path.pl

@@ -0,0 +1,287 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2008, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_path,
+	  [ http_absolute_location/3	% +Spec, -Path, +Options
+	  ]).
+:- use_module(library(lists)).
+:- use_module(library(error)).
+:- use_module(library(apply)).
+:- use_module(library(debug)).
+:- use_module(library(option)).
+:- use_module(library(settings)).
+:- use_module(library(broadcast)).
+:- use_module(library(url)).
+
+
+/** <module> Abstract specification of HTTP server locations
+
+This module provides an abstract specification  of HTTP server locations
+that is inspired on absolute_file_name/3. The   specification is done by
+adding rules to the  dynamic   multifile  predicate http:location/3. The
+speficiation is very similar to   user:file_search_path/2,  but takes an
+additional argument with options. Currently only one option is defined:
+
+    * priority(+Integer)
+    If two rules match, take the one with highest priority.  Using
+    priorities is needed because we want to be able to overrule
+    paths, but we do not want to become dependent on clause ordering.
+
+    The default priority is 0. Note however that notably libraries may
+    decide to provide a fall-back using a negative priority.  We suggest
+    -100 for such cases.
+
+This library predefines three locations at   priority  -100: The =icons=
+and =css= aliases are intended for images   and css files and are backed
+up by file a file-search-path that  allows   finding  the  icons and css
+files that belong to the server infrastructure (e.g., http_dirindex/2).
+
+    * root
+    The root of the server.  Default is /, but this may be overruled
+    the the setting (see setting/2) =|http:prefix|=
+
+Here is an example that binds =|/login|=  to login/1. The user can reuse
+this application while moving all locations  using   a  new rule for the
+admin location with the option =|[priority(10)]|=.
+
+==
+:- multifile http:location/3.
+:- dynamic   http:location/3.
+
+http:location(admin, /, []).
+
+:- http_handler(admin(login), login, []).
+
+login(Request) :-
+	...
+==
+
+@tbd	Make this module replace the http:prefix option.
+@tbd	Remove hard-wired support for prefix().
+*/
+
+:- multifile
+	http:location/3.		% Alias, Expansion, Options
+:- dynamic
+	http:location/3.		% Alias, Expansion, Options
+
+http:location(root, Root, [priority(-100)]) :-
+	(   catch(setting(http:prefix, Prefix), _, fail),
+	    Prefix \== ''
+	->  Root = Prefix
+	;   Root = (/)
+	).
+
+
+%%	http_absolute_location(+Spec, -Path, +Options) is det.
+%
+%	Path is the HTTP location for the abstract specification Spec.
+%	Options:
+%
+%	    * relative_to(Base)
+%	    Path is made relative to Base.  Default is to generate
+%	    absolute URLs.
+
+:- dynamic
+	location_cache/3.
+
+http_absolute_location(Spec, Path, Options) :-
+	must_be(ground, Spec),
+	option(relative_to(Base), Options, /),
+	absolute_location(Spec, Base, Path, Options),
+	debug(http_path, '~q (~q) --> ~q', [Spec, Base, Path]).
+
+absolute_location(Spec, Base, Path, _Options) :-
+	location_cache(Spec, Base, Cache), !,
+	Path = Cache.
+absolute_location(Spec, Base, Path, Options) :-
+	expand_location(Spec, Base, L, Options),
+	assert(location_cache(Spec, Base, L)),
+	Path = L.
+
+expand_location(Spec, Base, Path, _Options) :-
+	atomic(Spec), !,
+	relative_to(Base, Spec, Path).
+expand_location(Spec, _Base, Path, Options) :-
+	Spec =.. [Alias, Sub],
+	http_location_path(Alias, Parent),
+	absolute_location(Parent, /, ParentLocation, Options),
+	phrase(path_list(Sub), List),
+	atomic_list_concat(List, /, SubAtom),
+	(   ParentLocation == ''
+	->  Path = SubAtom
+	;   sub_atom(ParentLocation, _, _, 0, /)
+	->  atom_concat(ParentLocation, SubAtom, Path)
+	;   atomic_list_concat([ParentLocation, SubAtom], /, Path)
+	).
+
+
+%%	http_location_path(+Alias, -Expansion) is det.
+%
+%	Expansion is the expanded HTTP location for Alias. As we have no
+%	condition search, we demand a single  expansion for an alias. An
+%	ambiguous alias results in a printed   warning.  A lacking alias
+%	results in an exception.
+%
+%	@error	existence_error(http_alias, Alias)
+
+http_location_path(Alias, Path) :-
+	findall(P-L, http_location_path(Alias, L, P), Pairs),
+	keysort(Pairs, Sorted0),
+	reverse(Sorted0, Result),
+	(   Result = [_-One]
+	->  Path = One
+	;   Result == []
+	->  existence_error(http_location, Spec)
+	;   Result = [P-Best,P2-_|_],
+	    P \== P2
+	->  Path = Best
+	;   Result = [_-First|_],
+	    pairs_values(Result, Paths),
+	    print_message(warning, http(ambiguous_location(Spec, Paths))),
+	    Path = First
+	).
+
+
+%%	http_location_path(+Alias, -Path, -Priority) is nondet.
+%
+%	@tbd	prefix(Path) is discouraged; use root(Path)
+
+http_location_path(Alias, Path, Priority) :-
+	http:location(Alias, Path, Options),
+	option(priority(Priority), Options, 0).
+http_location_path(prefix, Path, 0) :-
+	(   catch(setting(http:prefix, Prefix), _, fail),
+	    Prefix \== ''
+	->  (	sub_atom(Prefix, 0, _, _, /)
+	    ->  Path = Prefix
+	    ;	atom_concat(/, Prefix, Path)
+	    )
+	;   Path = /
+	).
+
+
+%%	relative_to(+Base, +Path, -AbsPath) is det.
+%
+%	AbsPath is an absolute URL location created from Base and Path.
+%	The result is cleaned
+
+relative_to(/, Path, Path) :- !.
+relative_to(_Base, Path, Path) :-
+	sub_atom(Path, 0, _, _, /), !.
+relative_to(Base, Local, Path) :-
+	sub_atom(Base, 0, _, _, /), !,	% file version
+	path_segments(Base, BaseSegments),
+	append(BaseDir, [_], BaseSegments) ->
+	path_segments(Local, LocalSegments),
+	append(BaseDir, LocalSegments, Segments0),
+	clean_segments(Segments0, Segments),
+	path_segments(Path, Segments).
+relative_to(Base, Local, Global) :-
+	global_url(Local, Base, Global).
+
+path_segments(Path, Segments) :-
+	atomic_list_concat(Segments, /, Path).
+
+%%	clean_segments(+SegmentsIn, -SegmentsOut) is det.
+%
+%	Clean a path represented  as  a   segment  list,  removing empty
+%	segments and resolving .. based on syntax.
+
+clean_segments([''|T0], [''|T]) :- !,
+	exclude(empty_segment, T0, T1),
+	clean_parent_segments(T1, T).
+clean_segments(T0, T) :-
+	exclude(empty_segment, T0, T1),
+	clean_parent_segments(T1, T).
+
+clean_parent_segments([], []).
+clean_parent_segments([..|T0], T) :- !,
+	clean_parent_segments(T0, T).
+clean_parent_segments([_,..|T0], T) :- !,
+	clean_parent_segments(T0, T).
+clean_parent_segments([H|T0], [H|T]) :-
+	clean_parent_segments(T0, T).
+
+empty_segment('').
+empty_segment('.').
+
+
+%%	path_list(+Spec, -List) is det.
+%
+%	Translate seg1/seg2/... into [seg1,seg2,...].
+%
+%	@error	instantiation_error
+%	@error	type_error(atomic, X)
+
+path_list(Var) -->
+	{ var(Var), !,
+	  instantiation_error(Var)
+	}.
+path_list(A/B) --> !,
+	path_list(A),
+	path_list(B).
+path_list(.) --> !,
+	[].
+path_list(A) -->
+	{ must_be(atomic, A) },
+	[A].
+
+
+		 /*******************************
+		 *	      MESSAGES		*
+		 *******************************/
+
+:- multifile
+	prolog:message/3.
+
+prolog:message(http(ambiguous_location(Spec, Paths))) -->
+	[ 'http_absolute_location/2: ambiguous specification: ~q: ~p'-[Spec, Paths]
+	].
+
+
+		 /*******************************
+		 *	  CACHE CLEANUP		*
+		 *******************************/
+
+clean_location_cache :-
+	retractall(location_cache(_,_,_)).
+
+:- listen(settings(changed(http:prefix, _, _)),
+	  clean_location_cache).
+
+:- multifile
+	user:message_hook/3.
+:- dynamic
+	user:message_hook/3.
+
+user:message_hook(make(done(Reload)), _Level, _Lines) :-
+	Reload \== [],
+	clean_location_cache,
+	fail.

packages/http/http_pwp.pl

@@ -0,0 +1,271 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2009, VU University, Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_pwp,
+	  [ reply_pwp_page/3,		% :File, +Options, +Request
+	    pwp_handler/2		% +Options, +Request
+	  ]).
+:- use_module(library(http/http_dispatch)).
+:- use_module(library(sgml)).
+:- use_module(library(sgml_write)).
+:- use_module(library(option)).
+:- use_module(library(error)).
+:- use_module(library(lists)).
+:- use_module(library(pwp)).
+
+/** <module> Serve PWP pages through the HTTP server
+
+This  module  provides  convience  predicates  to  include  PWP  (Prolog
+Well-formed Pages) in a Prolog  web-server.   It  provides the following
+predicates:
+
+    * pwp_handler/2
+    This is a complete web-server aimed at serving static pages, some
+    of which include PWP.  This API is intended to allow for programming
+    the web-server from a hierarchy of pwp files, prolog files and static
+    web-pages.
+
+    * reply_pwp_page/3
+    Return a single PWP page that is executed in the context of the calling
+    module.  This API is intended for individual pages that include so much
+    text that generating from Prolog is undesirable.
+
+@tbd	Support elements in the HTML header that allow controlling the
+	page, such as setting the CGI-header, authorization, etc.
+@tbd	Allow external styling.  Pass through reply_html_page/2?  Allow
+	filtering the DOM before/after PWP?
+*/
+
+%%	pwp_handler(+Options, +Request)
+%
+%	Handle PWP files. This predicate is   defined to create a simple
+%	HTTP server from a hierarchy of PWP,   HTML and other files. The
+%	interface      is      kept      compatible        with      the
+%	library(http/http_dispatch). In the typical  usage scenario, one
+%	needs to define an http location and  a file-search path that is
+%	used as the root of the server.  E.g., the following declarations
+%	create a self-contained web-server for files in =|/web/pwp/|=.
+%
+%	    ==
+%	    user:file_search_path(pwp, '/web/pwp').
+%
+%	    :- http_handler(root(.), pwp_handler([path_alias(pwp)]), [prefix]).
+%	    ==
+%
+%	Options include:
+%
+%	    * path_alias(+Alias)
+%	    Search for PWP files as Alias(Path).  See absolute_file_name/3.
+%	    * index(+Index)
+%	    Name of the directory index (pwp) file.  This option may
+%	    appear multiple times.  If no such option is provided,
+%	    pwp_handler/2 looks for =|index.pwp|=.
+%	    * view(+Boolean)
+%	    If =true= (default is =false=), allow for ?view=source to serve
+%	    PWP file as source.
+%	    * index_hook(:Hook)
+%	    If a directory has no index-file, pwp_handler/2 calls
+%	    Hook(PhysicalDir, Options, Request).  If this semidet
+%	    predicate succeeds, the request is considered handled.
+%	    * hide_extensions(+List)
+%	    Hide files of the given extensions.  The default is to
+%	    hide .pl files.
+%
+%	@see reply_pwp_page/3
+%	@error permission_error(index, http_location, Location) is
+%	raised if the handler resolves to a directory that has no
+%	index.
+
+:- meta_predicate
+	pwp_handler(:, +).
+
+pwp_handler(QOptions, Request) :-
+	meta_options(is_meta, QOptions, Options),
+	(   memberchk(path_info(Spec), Request)
+	->  true
+	;   Spec = '.'
+	),
+	(   option(path_alias(Alias), Options)
+	->  Term =.. [Alias,Spec]
+	;   Term = Spec
+	),
+	http_safe_file(Term, Options),
+	absolute_file_name(Term, Path, [access(read)]),
+	(   exists_directory(Path)
+	->  ensure_slash(Path, Dir),
+	    (	(   member(index(Index), Options)
+		*-> true
+		;   Index = 'index.pwp'
+		),
+		atom_concat(Dir, Index, File),
+		access_file(File, read)
+	    ->	true
+	    ;	option(index_hook(Hook), Options),
+	    	call(Hook, Path, Options, Request)
+	    ->	true
+	    ;	memberchk(path(Location), Request),
+		permission_error(index, http_location, Location)
+	    )
+	;   File = Path
+	),
+	server_file(File, Request, Options).
+
+is_meta(index_hook).
+
+server_file(File, _, _) :-		% index-hook did the work
+	var(File), !.
+server_file(File, Request, Options) :-
+	file_name_extension(_, pwp, File), !,
+	(   option(view(true), Options),
+	    memberchk(search(Query), Request),
+	    memberchk(view=source, Query)
+	->  http_reply_file(File, [ mime_type(text/plain),
+				    unsafe(true)
+				  ], Request)
+	;   merge_options(Options,
+			  [ pwp_module(true)
+			  ], Opts),
+	    reply_pwp_page(File, [unsafe(true)|Opts], Request)
+	).
+server_file(File, Request, Options) :-
+	option(hide_extensions(Exts), Options, [pl]),
+	file_name_extension(_, Ext, File),
+	(   memberchk(Ext, Exts)
+	->  memberchk(path(Location), Request),
+	    permission_error(read, http_location, Location)
+	;   http_reply_file(File, [unsafe(true)|Options], Request)
+	).
+
+
+ensure_slash(Path, Dir) :-
+	(   sub_atom(Path, _, _, 0, /)
+	->  Dir = Path
+	;   atom_concat(Path, /, Dir)
+	).
+
+
+%%	reply_pwp_page(:File, +Options, +Request)
+%
+%	Reply  a  PWP  file.  This  interface   is  provided  to  server
+%	individual locations from PWP files.  Using   a  PWP file rather
+%	than generating the page from Prolog   may  be desirable because
+%	the page contains a lot of text (which is cumbersome to generate
+%	from Prolog) or because the  maintainer   is  not  familiar with
+%	Prolog.
+%
+%	Options supported are:
+%
+%	    * mime_type(+Type)
+%	    Serve the file using the given mime-type.  Default is
+%	    text/html.
+%	    * unsafe(+Boolean)
+%	    Passed to http_safe_file/2 to check for unsafe paths.
+%	    * pwp_module(+Boolean)
+%	    If =true=, (default =false=), process the PWP file in
+%	    a module constructed from its canonical absolute path.
+%	    Otherwise, the PWP file is processed in the calling
+%	    module.
+%
+%	Initial context:
+%
+%	    * SCRIPT_NAME
+%	    Virtual path of the script.
+%	    * SCRIPT_DIRECTORY
+%	    Physical directory where the script lives
+%	    * QUERY
+%	    Var=Value list representing the query-parameters
+%	    * REMOTE_USER
+%	    If access has been authenticated, this is the authenticated
+%	    user.
+%	    * REQUEST_METHOD
+%	    One of =get=, =post=, =put= or =head=
+%	    * CONTENT_TYPE
+%	    Content-type provided with HTTP POST and PUT requests
+%	    * CONTENT_LENGTH
+%	    Content-length provided with HTTP POST and PUT requests
+%
+%	While processing the script, the file-search-path pwp includes
+%	the current location of the script.  I.e., the following will
+%	find myprolog in the same directory as where the PWP file
+%	resides.
+%
+%	    ==
+%	    pwp:ask="ensure_loaded(pwp(myprolog))"
+%	    ==
+%
+%	@tbd complete the initial context, as far as possible from CGI
+%	     variables.  See http://hoohoo.ncsa.illinois.edu/docs/cgi/env.html
+%	@see pwp_handler/2.
+
+:- meta_predicate
+	reply_pwp_page(:, +, +).
+
+reply_pwp_page(M:File, Options, Request) :-
+	http_safe_file(File, Options),
+	absolute_file_name(File, Path,
+			   [ access(read)
+			   ]),
+	memberchk(method(Method), Request),
+	file_directory_name(Path, Dir),
+	load_xml_file(Path, Contents),
+	findall(C, pwp_context(Request, C), Context),
+	(   option(pwp_module(true), Options)
+	->  PWP_M = Path
+	;   PWP_M = M
+	),
+	setup_call_cleanup(asserta(script_dir(Dir), Ref),
+			   pwp_xml(PWP_M:Contents, Transformed,
+				   [ 'REQUEST_METHOD' = Method,
+				     'SCRIPT_DIRECTORY' = Dir
+				   | Context
+				   ]),
+			   erase(Ref)),
+	option(mime_type(Type), Options, text/html),
+	format('Content-type: ~w~n~n', [Type]),
+	xml_write(current_output, Transformed, []).
+
+pwp_context(Request, 'REMOTE_USER' = User) :-
+	memberchk(user(User), Request).
+pwp_context(Request, 'QUERY' = Query) :-
+	memberchk(search(Query), Request).
+pwp_context(Request, 'SCRIPT_NAME' = Path) :-
+	memberchk(path(Path), Request).
+pwp_context(Request, 'CONTENT_TYPE' = ContentType) :-
+	memberchk(content_type(ContentType), Request).
+pwp_context(Request, 'CONTENT_LENGTH' = Length) :-
+	memberchk(content_length(Length), Request).
+
+:- multifile user:file_search_path/2.
+:- dynamic   user:file_search_path/2.
+:- thread_local script_dir/1.
+
+user:file_search_path(pwp, ScriptDir) :-
+	script_dir(ScriptDir).
+
+

packages/http/http_server_files.pl

@@ -0,0 +1,90 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2009, VU University, Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_server_files,
+	  [ serve_files_in_directory/2	% +Alias, +HTTPRequest
+	  ]).
+:- use_module(library(http/http_path)).
+:- use_module(library(http/http_dispatch)).
+
+/** <module> Serve files needed by modules from the server
+
+This module provides an infrastructure   for serving resource-files such
+as icons, JavaScript, CSS files, etc.   The default configuration serves
+the    HTTP    locations    =icons=,     =css=      and     =js=    (see
+http_absolute_location/3)
+
+The location for these services  can  be   changed  by  adding rules for
+http:location/3.  Directories  providing  additional    or   alternative
+resources can be achieved by adding rules for user:file_search_path/2.
+*/
+
+:- multifile
+	http:location/3.		% Alias, Expansion, Options
+:- dynamic
+	http:location/3.		% Alias, Expansion, Options
+
+http:location(icons, root(icons), [ priority(-100) ]).
+http:location(css,   root(css),   [ priority(-100) ]).
+http:location(js,    root(js),    [ priority(-100) ]).
+
+:- multifile
+	user:file_search_path/2.
+:- dynamic
+	user:file_search_path/2.
+
+user:file_search_path(icons, library('http/web/icons')).
+user:file_search_path(css,   library('http/web/css')).
+user:file_search_path(js,    library('http/web/js')).
+
+:- http_handler(icons(.), serve_files_in_directory(icons), [prefix]).
+:- http_handler(css(.),   serve_files_in_directory(css),   [prefix]).
+:- http_handler(js(.),    serve_files_in_directory(js),    [prefix]).
+
+%%	serve_files_in_directory(+Alias, +Request)
+%
+%	Serve files from the directory  Alias   from  the path-info from
+%	Request.    This    predicate    is     used    together    with
+%	file_search_path/2. Note that multiple  clauses   for  the  same
+%	file_search_path alias can be used to merge files from different
+%	physical locations onto the same HTTP   directory. Note that the
+%	handler must be declared as =prefix=. Here is an example:
+%
+%	    ==
+%	    user:file_search_path(icons, library('http/web/icons')).
+%
+%	    :- http_handler(icons(.), serve_files_in_directory(icons), [prefix]).
+%	    ==
+%
+%	@see http_reply_file/3
+
+serve_files_in_directory(Alias, Request) :-
+	memberchk(path_info(PathInfo), Request),
+	Term =.. [Alias,PathInfo],
+	http_reply_file(Term, [], Request).

packages/http/http_session.pl

@@ -0,0 +1,512 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2006, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+
+:- module(http_session,
+	  [ http_set_session_options/1,	% +Options
+
+	    http_session_id/1,		% -SessionId
+	    http_in_session/1,		% -SessionId
+	    http_current_session/2,	% ?SessionId, ?Data
+	    http_close_session/1,	% +SessionId
+
+	    http_session_asserta/1,	% +Data
+	    http_session_assert/1,	% +Data
+	    http_session_retract/1,	% ?Data
+	    http_session_retractall/1,	% +Data
+	    http_session_data/1		% ?Data
+	  ]).
+:- use_module(http_wrapper).
+:- use_module(library(error)).
+:- use_module(library(debug)).
+:- use_module(library(socket)).
+:- use_module(library(broadcast)).
+:- use_module(library(lists)).
+
+/** <module> HTTP Session management
+
+This library defines session management based   on HTTP cookies. Session
+management is enabled simply by  loading   this  module.  Details can be
+modified using http_set_session_options/1.  If   sessions  are  enabled,
+http_session_id/1 produces the current session and http_session_assert/1
+and  friends  maintain  data  about  the  session.  If  the  session  is
+reclaimed, all associated data is reclaimed too.
+
+Begin and end of sessions can be monitored using library(broadcast). The
+broadcasted messages are:
+
+    * http_session(begin(SessionID, Peer))
+    Broadcasted if a session is started
+    * http_session(end(SessionId, Peer))
+    Broadcasted if a session is ended. See http_close_session/1.
+
+For example, the  following  calls   end_session(SessionId)  whenever  a
+session terminates. Please note that sessions  ends are not scheduled to
+happen at the actual timeout moment of  the session. Instead, creating a
+new session scans the  active  list   for  timed-out  sessions. This may
+change in future versions of this library.
+
+    ==
+    :- listen(http_session(end(SessionId, Peer)),
+	      end_session(SessionId)).
+    ==
+*/
+
+:- dynamic
+	session_setting/1,		% Name(Value)
+	current_session/2,		% SessionId, Peer
+	last_used/2,			% SessionId, Time
+	session_data/2.			% SessionId, Data
+
+session_setting(timeout(600)).		% timeout in seconds
+session_setting(cookie('swipl_session')).
+session_setting(path(/)).
+session_setting(enabled(true)).
+
+session_option(timeout, integer).
+session_option(cookie, atom).
+session_option(path, atom).
+session_option(route, atom).
+session_option(enabled, boolean).
+
+%%	http_set_session_options(+Options) is det.
+%
+%	Set options for the session library.  Provided options are:
+%
+%		* timeout(+Seconds)
+%		Session timeout in seconds.  Default is 600 (10 min).
+%
+%		* cookie(+Cookiekname)
+%		Name to use for the cookie to identify the session.
+%		Default =swipl_session=.
+%
+%		* path(+Path)
+%		Path to which the cookie is associated.  Default is
+%		=|/|=.	Cookies are only sent if the HTTP request path
+%		is a refinement of Path.
+%
+%		* route(+Route)
+%		Set the route name. Default is the unqualified
+%		hostname. To cancel adding a route, use the empty
+%		atom.  See route/1.
+%
+%		* enabled(+Boolean)
+%		Enable/disable session management.  Sesion management
+%		is enabled by default after loading this file.
+
+http_set_session_options([]).
+http_set_session_options([H|T]) :-
+	http_session_option(H),
+	http_set_session_options(T).
+
+http_session_option(Option) :-
+	functor(Option, Name, Arity),
+	arg(1, Option, Value),
+	(   session_option(Name, Type)
+	->  must_be(Type, Value)
+	;   domain_error(http_session_option, Option)
+	),
+	functor(Free, Name, Arity),
+	retractall(session_setting(Free)),
+	assert(session_setting(Option)).
+
+%%	http_session_id(-SessionId) is det.
+%
+%	True if SessionId is an identifier for the current session.
+%
+%	@param SessionId is an atom.
+%	@error existence_error(http_session, _)
+%	@see   http_in_session/1 for a version that fails if there is
+%	       no session.
+
+http_session_id(SessionID) :-
+	(   http_in_session(ID)
+	->  SessionID = ID
+	;   throw(error(existence_error(http_session, _), _))
+	).
+
+%%	http_in_session(-SessionId) is semidet.
+%
+%	True if SessionId is an identifier  for the current session. The
+%	current session is extracted from   session(ID) from the current
+%	HTTP request (see http_current_request/1). The   value is cached
+%	in a backtrackable global variable   =http_session_id=.  Using a
+%	backtrackable global variable is safe  because continuous worker
+%	threads use a failure driven  look   and  spawned  threads start
+%	without any global variables. This variable  can be set from the
+%	commandline to fake running a goal   from the commandline in the
+%	context of a session.
+%
+%	@see http_session_id/1
+
+http_in_session(SessionID) :-
+	(   nb_current(http_session_id, ID),
+	    ID \== []
+	->  true
+	;   http_current_request(Request),
+	    memberchk(session(ID), Request),
+	    b_setval(http_session_id, ID)
+	;   b_setval(http_session_id, no_session),
+	    fail
+	),
+	ID \== no_session,
+	SessionID = ID.
+
+%%	http_session(+RequestIn, -RequestOut, -SessionID) is semidet.
+%
+%	Maintain the notion of a  session   using  a client-side cookie.
+%	This must be called first when handling a request that wishes to
+%	do session management, after which the possibly modified request
+%	must be used for further processing.
+
+http_session(Request, Request, SessionID) :-
+	memberchk(session(SessionID0), Request), !,
+	SessionID = SessionID0.
+http_session(Request0, Request, SessionID) :-
+	memberchk(cookie(Cookies), Request0),
+	session_setting(cookie(Cookie)),
+	memberchk(Cookie=SessionID0, Cookies),
+	peer(Request0, Peer),
+	valid_session_id(SessionID0, Peer), !,
+	SessionID = SessionID0,
+	Request = [session(SessionID)|Request0],
+	b_setval(http_session_id, SessionID).
+http_session(Request0, Request, SessionID) :-
+	session_setting(path(Path)),
+	memberchk(path(ReqPath), Request0),
+	sub_atom(ReqPath, 0, _, _, Path), !,
+	http_gc_sessions,		% GC dead sessions
+	gen_cookie(SessionID),
+	session_setting(cookie(Cookie)),
+	format('Set-Cookie: ~w=~w; path=~w~n', [Cookie, SessionID, Path]),
+	Request = [session(SessionID)|Request0],
+	peer(Request0, Peer),
+	open_session(SessionID, Peer),
+	b_setval(http_session_id, SessionID).
+
+:- multifile
+	http:request_expansion/2.
+
+http:request_expansion(Request0, Request) :-
+	session_setting(enabled(true)),
+	http_session(Request0, Request, _SessionID).
+
+%%	peer(+Request, -Peer)
+%
+%	Find peer for current request. If   unknown we leave it unbound.
+%	Alternatively we should treat this as an error.
+
+peer(Request, Peer) :-
+	(   memberchk(peer(Peer), Request)
+	->  true
+	;   true
+	).
+
+%%	open_session(+SessionID, +Peer)
+%
+%	Open a new session.  Uses broadcast/1 with the term
+%	http_session(begin(SessionID, Peer)).
+
+open_session(SessionID, Peer) :-
+	get_time(Now),
+	assert(current_session(SessionID, Peer)),
+	assert(last_used(SessionID, Now)),
+	broadcast(http_session(begin(SessionID, Peer))).
+
+
+%%	valid_session_id(+SessionID, +Peer)
+%
+%	Check if this sessionID is known. If so, check the idle time and
+%	update the last_used for this session.
+
+valid_session_id(SessionID, Peer) :-
+	current_session(SessionID, SessionPeer),
+	get_time(Now),
+	(   session_setting(timeout(Timeout)),
+	    Timeout > 0
+	->  get_last_used(SessionID, Last),
+	    Idle is Now - Last,
+	    (	Idle =< Timeout
+	    ->  true
+	    ;   http_close_session(SessionID),
+		fail
+	    )
+	;   Peer \== SessionPeer
+	->  http_close_session(SessionID),
+	    fail
+	;   true
+	),
+	set_last_used(SessionID, Now).
+
+get_last_used(SessionID, Last) :-
+	atom(SessionID), !,
+	with_mutex(http_session, last_used(SessionID, Last)).
+get_last_used(SessionID, Last) :-
+	with_mutex(http_session,
+		   findall(SessionID-Last,
+			   last_used(SessionID, Last),
+			   Pairs)),
+	member(SessionID-Last, Pairs).
+
+set_last_used(SessionID, Now) :-
+	with_mutex(http_session,
+		  (   retractall(last_used(SessionID, _)),
+		      assert(last_used(SessionID, Now)))).
+
+
+
+		 /*******************************
+		 *	   SESSION DATA		*
+		 *******************************/
+
+%%	http_session_asserta(+Data) is det.
+%%	http_session_assert(+Data) is det.
+%%	http_session_retract(?Data) is nondet.
+%%	http_session_retractall(?Data) is det.
+%
+%	Versions of assert/1, retract/1 and retractall/1 that associate
+%	data with the current HTTP session.
+
+http_session_asserta(Data) :-
+	http_session_id(SessionId),
+	asserta(session_data(SessionId, Data)).
+
+http_session_assert(Data) :-
+	http_session_id(SessionId),
+	assert(session_data(SessionId, Data)).
+
+http_session_retract(Data) :-
+	http_session_id(SessionId),
+	retract(session_data(SessionId, Data)).
+
+http_session_retractall(Data) :-
+	http_session_id(SessionId),
+	retractall(session_data(SessionId, Data)).
+
+%	http_session_data(?Data) is nondet.
+%
+%	True if Data is associated using http_session_assert/1 to the
+%	current HTTP session.
+
+http_session_data(Data) :-
+	http_session_id(SessionId),
+	session_data(SessionId, Data).
+
+
+		 /*******************************
+		 *	     ENUMERATE		*
+		 *******************************/
+
+%%	http_current_session(?SessionID, ?Data) is nondet.
+%
+%	Enumerate the current sessions and   associated data.  There are
+%	two _Pseudo_ data elements:
+%
+%		* idle(Seconds)
+%		Session has been idle for Seconds.
+%
+%		* peer(Peer)
+%		Peer of the connection.
+
+http_current_session(SessionID, Data) :-
+	get_time(Now),
+	get_last_used(SessionID, Last),
+	Idle is Now - Last,
+	(   session_setting(timeout(Timeout)),
+	    Timeout > 0
+	->  Idle =< Timeout
+	;   true
+	),
+	(   Data = idle(Idle)
+	;   Data = peer(Peer),
+	    current_session(SessionID, Peer)
+	;   session_data(SessionID, Data)
+	).
+
+
+		 /*******************************
+		 *	    GC SESSIONS		*
+		 *******************************/
+
+%%	http_close_session(+SessionID) is det.
+%
+%	Closes an HTTP session. This predicate   can  be called from any
+%	thread to terminate a session.  It uses the broadcast/1 service
+%	with the message below.
+%
+%		http_session(end(SessionId, Peer))
+%
+%	The broadcast is done *before* the session data is destroyed and
+%	the listen-handlers are executed in context  of the session that
+%	is being closed. Here  is  an   example  that  destroys a Prolog
+%	thread that is associated to a thread:
+%
+%	==
+%	:- listen(http_session(end(SessionId, _Peer)),
+%		  kill_session_thread(SessionID)).
+%
+%	kill_session_thread(SessionID) :-
+%		http_session_data(thread(ThreadID)),
+%		thread_signal(ThreadID, throw(session_closed)).
+%	==
+%
+%	Succeed without any effect if  SessionID   does  not refer to an
+%	active session.
+%
+%	@error	type_error(atom, SessionID)
+%	@see	listen/2 for acting upon closed sessions
+
+http_close_session(SessionId) :-
+	must_be(atom, SessionId),
+	(   current_session(SessionId, Peer),
+	    (	b_setval(http_session_id, SessionId),
+		broadcast(http_session(end(SessionId, Peer))),
+		fail
+	    ;	true
+	    ),
+	    retractall(current_session(SessionId, _)),
+	    retractall(last_used(SessionId, _)),
+	    retractall(session_data(SessionId, _)),
+	    fail
+	;   true
+	).
+
+%	http_gc_sessions/0
+%
+%	Delete dead sessions. When  should  we   be  calling  this? This
+%	assumes that updated sessions are at the end of the clause list,
+%	so we can break  as  soon   as  we  encounter  a no-yet-timedout
+%	session.
+
+http_gc_sessions :-
+	session_setting(timeout(Timeout)),
+	Timeout > 0, !,
+	get_time(Now),
+	(   last_used(SessionID, Last),
+	    Idle is Now - Last,
+	    (	Idle > Timeout
+	    ->	http_close_session(SessionID),
+		fail
+	    ;	!
+	    )
+	;   true
+	).
+http_gc_sessions.
+
+
+		 /*******************************
+		 *	       UTIL		*
+		 *******************************/
+
+%%	gen_cookie(-Cookie) is det.
+%
+%	Generate a random cookie that  can  be   used  by  a  browser to
+%	identify  the  current  session.  The   cookie  has  the  format
+%	XXXX-XXXX-XXXX-XXXX[.<route>], where XXXX are random hexadecimal
+%	numbers  and  [.<route>]  is  the    optionally   added  routing
+%	information.
+
+gen_cookie(Cookie) :-
+	route(Route), !,
+	random_4(R1,R2,R3,R4),
+	format(atom(Cookie),
+		'~`0t~16r~4|-~`0t~16r~9|-~`0t~16r~14|-~`0t~16r~19|.~w',
+		[R1,R2,R3,R4,Route]).
+gen_cookie(Cookie) :-
+	random_4(R1,R2,R3,R4),
+	format(atom(Cookie),
+		'~`0t~16r~4|-~`0t~16r~9|-~`0t~16r~14|-~`0t~16r~19|',
+		[R1,R2,R3,R4]).
+
+:- thread_local
+	route_cache/1.
+
+%%	route(-RouteID) is semidet.
+%
+%	Fetch the route identifier. This value   is added as .<route> to
+%	the session cookie and used  by   -for  example- the apache load
+%	balanching module. The default route is   the  local name of the
+%	host.     Alternatives     may      be       provided      using
+%	http_set_session_options/1.
+
+route(Route) :-
+	route_cache(Route), !,
+	Route \== ''.
+route(Route) :-
+	route_no_cache(Route),
+	assert(route_cache(Route)),
+	Route \== ''.
+
+route_no_cache(Route) :-
+	session_setting(route(Route)), !.
+route_no_cache(Route) :-
+	gethostname(Host),
+	(   sub_atom(Host, Before, _, _, '.')
+	->  sub_atom(Host, 0, Before, _, Route)
+	;   Route = Host
+	).
+
+
+%%	random_4(-R1,-R2,-R3,-R4) is det.
+%
+%	Generate 4 2-byte random  numbers.   Uses  =|/dev/urandom|= when
+%	available to make prediction of the session IDs hard.
+
+random_4(R1,R2,R3,R4) :-
+	urandom(In), !,
+	get_pair(In, R1),
+	get_pair(In, R2),
+	get_pair(In, R3),
+	get_pair(In, R4).
+random_4(R1,R2,R3,R4) :-
+	R1 is random(65536),
+	R2 is random(65536),
+	R3 is random(65536),
+	R4 is random(65536).
+
+:- dynamic
+	urandom_handle/1.
+
+urandom(Handle) :-
+	urandom_handle(Handle), !,
+	Handle \== [].
+urandom(Handle) :-
+	catch(open('/dev/urandom', read, In, [type(binary)]), _, fail), !,
+	assert(urandom_handle(In)),
+	Handle = In.
+urandom(_) :-
+	assert(urandom_handle([])),
+	fail.
+
+get_pair(In, Value) :-
+	get_byte(In, B1),
+	get_byte(In, B2),
+	Value is B1<<8+B2.

packages/http/http_sgml_plugin.pl

@@ -0,0 +1,128 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2010, University of Amsterdam, VU University Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_sgml_plugin, []).
+:- use_module(http_client).
+:- use_module(library(memfile)).
+:- use_module(library(sgml)).
+:- use_module(library(lists)).
+:- use_module(library(debug)).
+
+:- multifile
+	http_client:http_convert_data/4.
+
+:- multifile
+	markup_type/2.			% +MimeType, -ParseOptions
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+This module provides a plugin for the   HTTP  client to handle xml, html
+and sgml files using  the   SWI-Prolog  sgml-parser  from library(sgml).
+Using this library avoids unnecessary copying of data as the sgml-parser
+reads directly from the stream that established the HTTP connection.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+http_client:http_convert_data(In, Fields, Data, Options) :-
+	memberchk(content_type(Type), Fields),
+	debug(sgml_plugin, 'Content type: ~w', [Type]),
+	(   markup_type(Type, ParseOptions)
+	->  true
+	;   type_major_props(Type, Major, Props),
+	    default_markup_type(Major, ParseOptions0),
+	    type_props(Props, ParseOptions0, ParseOptions)
+	),
+	merge_options([ max_errors(-1),
+			syntax_errors(quiet)
+		      | ParseOptions
+		      ], Options, Merged),
+	markup_options(Fields, Merged, MarkupOptions),
+	debug(sgml_plugin, 'Markup options: ~p', [MarkupOptions]),
+	load_structure(stream(In), Data, MarkupOptions).
+
+
+type_major_props(Type0, Type, Props) :-
+	sub_atom(Type0, B, _, A, ;), !,
+	sub_atom(Type0, 0, B, _, Major),
+	sub_atom(Type0, _, A, 0, Props),
+	normalize_space(atom(Type), Major).
+type_major_props(Type, Type, '').
+
+type_props('', L, L).
+type_props(Props, L0, L) :-
+	sub_atom(Props, _, _, A, 'charset='),
+	sub_atom(Props, _, A, 0, CharSet0),
+	downcase_atom(CharSet0, CharSet),
+	known_charset(CharSet),
+	L = [encoding(CharSet)|L0].
+type_props(_, L, L).
+
+known_charset('iso-8859-1').
+known_charset('us-ascii').
+known_charset('utf-8').
+
+
+%%	default_markup_type(+MimeType, -ParseOptions)
+%
+%	State that the HTTP contents should be parsed with
+%	load_structure/3 using the returned options. This predicate may
+%	be hooked using the multifile predicate markup_type/2.
+
+default_markup_type('text/xml',
+	    [ dialect(xmlns)
+	    ]).
+default_markup_type('text/html',
+	    [ dtd(DTD),
+	      dialect(sgml),
+	      shorttag(false)
+	    ]) :-
+	dtd(html, DTD).
+default_markup_type('text/x-sgml',
+	    [ dialect(sgml)
+	    ]).
+
+markup_options(Fields, Opt0, Options) :-
+	(   memberchk(content_length(Bytes), Fields)
+	->  Options = [content_length(Bytes)|Opt0]
+	;   Options = Opt0
+	).
+
+%%	merge_options(+Defaults, +GivenOptions, -Options)
+%
+%	If an option is not in GivenOptions, use the one from
+%	Defaults.
+
+merge_options([], Options, Options).
+merge_options([H|T], Options0, Options) :-
+	functor(H, Name, Arity),
+	functor(H0, Name, Arity),
+	memberchk(H0, Options0), !,
+	merge_options(T, Options0, Options).
+merge_options([H|T], Options0, Options) :-
+	merge_options(T, [H|Options0], Options).

packages/http/http_stream.c

@@ -0,0 +1,36 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2007, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*/
+
+#include "http_error.c"
+#include "http_chunked.c"
+#include "cgi_stream.c"
+#include "stream_range.c"
+
+install_t
+install_http_stream()
+{ init_errors();
+  install_http_chunked();
+  install_cgi_stream();
+  install_stream_range();
+}

packages/http/http_stream.pl

@@ -0,0 +1,250 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_stream,
+	  [ http_chunked_open/3,	% +Stream, -DataStream, +Options
+	    stream_range_open/3,	% +Stream, -DataStream, +Options
+					% CGI Stream interaction
+	    cgi_open/4,			% +Stream, -DataStream, :Hook, +Options
+	    cgi_property/2,		% +Stream, -Property
+	    cgi_set/2,			% +Stream, -Property
+	    cgi_discard/1,		% +Stream
+	    is_cgi_stream/1		% +Stream
+	  ]).
+
+:- expects_dialect(swi).
+:- assert(system:swi_io).
+
+:- use_module(library(shlib)).
+
+:- use_foreign_library(foreign(http_stream)).
+
+/** <module> HTTP Streams
+
+This module realises  encoding  and   decoding  filters,  implemented as
+Prolog streams that read/write to an  underlying stream. This allows for
+sequences of streams acting as an in-process pipeline.
+
+The predicate http_chunked_open/3 realises encoding  and decoding of the
+HTTP _Chunked_ encoding. This encoding is an obligatory part of the HTTP
+1.1 specification. Messages are split into chunks, each preceeded by the
+length of the chunk. Chunked  encoding   allows  sending messages over a
+serial link (typically a TCP/IP stream) for  which the reader knows when
+the message is ended. Unlike standard HTTP   though, the sender does not
+need to know the message length  in   advance.  The  protocol allows for
+sending short chunks. This is  supported   totally  transparent  using a
+flush on the output stream.
+
+The predicate stream_range_open/3 handles the Content-length on an input
+stream for handlers that are designed  to   process  an entire file. The
+filtering stream claims end-of-file after reading  a specified number of
+bytes, dispite the fact that the underlying stream may be longer.
+
+@see	The HTTP 1.1 protocol http://www.w3.org/Protocols/rfc2616/rfc2616.html
+@author Jan Wielemaker
+*/
+
+%%	http_chunked_open(+RawStream, -DataStream, +Options) is det.
+%
+%	Create a stream to realise HTTP   chunked  encoding or decoding.
+%	The technique is similar to library(zlib), using a Prolog stream
+%	as a filter on another stream.  Options:
+%
+%		* close_parent(+Bool)
+%		If =true= (default =false=), the parent stream is closed
+%		if DataStream is closed.
+%
+%		* max_chunk_size(+PosInt)
+%		Define the maximum size of a chunk.  Default is the
+%		default buffer size of fully buffered streams (4096).
+%		Larger values may improve throughput.  It is also
+%		allowed to use =|set_stream(DataStream, buffer(line))|=
+%		on the data stream to get line-buffered output. See
+%		set_stream/2 for details. Switching buffering to =false=
+%		is supported.
+%
+%	Here is example code to write a chunked data to a stream
+%
+%	==
+%		http_chunked_open(Out, S, []),
+%		format(S, 'Hello world~n', []),
+%		close(S).
+%	==
+%
+%	If a stream is known to contain chunked data, we can extract
+%	this data using
+%
+%	==
+%		http_chunked_open(In, S, []),
+%		read_stream_to_codes(S, Codes),
+%		close(S).
+%	==
+%
+%	The current implementation does not  generate chunked extensions
+%	or an HTTP trailer. If such extensions  appear on the input they
+%	are silently ignored. This  is  compatible   with  the  HTTP 1.1
+%	specifications. Although a filtering  stream   is  an  excellent
+%	mechanism for encoding and decoding   the core chunked protocol,
+%	it does not well support out-of-band data.
+%
+%	After http_chunked_open/3, the encoding  of   DataStream  is the
+%	same as the  encoding  of  RawStream,   while  the  encoding  of
+%	RawStream is =octet=, the only value   allowed  for HTTP chunked
+%	streams. Closing the DataStream  restores   the  old encoding on
+%	RawStream.
+%
+%	@error	io_error(read, Stream) where the message context provides
+%		an indication of the problem.  This error is raised if
+%		the input is not valid HTTP chunked data.
+
+%%	stream_range_open(+RawStream, -DataStream, +Options) is det.
+%
+%	DataStream is a stream  whose  size   is  defined  by the option
+%	size(ContentLength).   Closing   DataStream   does   not   close
+%	RawStream.
+
+%%	cgi_open(+OutStream, -CGIStream, :Hook, +Options) is det.
+%
+%	Process CGI output. OutStream is   normally the socket returning
+%	data to the HTTP client. CGIStream   is  the stream the (Prolog)
+%	code writes to. The CGIStream provides the following functions:
+%
+%	    * At the end of the header, it calls Hook using
+%	    call(Hook, header, Stream), where Stream is a stream holding
+%	    the buffered header.
+%
+%	    * If the stream is closed, it calls Hook using
+%	    call(Hook, data, Stream), where Stream holds the buffered
+%	    data.
+%
+%	The stream calls Hook, adding  the   event  and CGIStream to the
+%	closure. Defined events are:
+%
+%	    * header
+%	    Called  if  the  header  is   complete.  Typically  it  uses
+%	    cgi_property/2 to extract the collected  header and combines
+%	    these with the request and policies   to decide on encoding,
+%	    transfer-encoding, connection parameters and   the  complete
+%	    header (as a Prolog term). Typically   it  uses cgi_set/2 to
+%	    associate these with the stream.
+%
+%	    * send_header
+%	    Called if the HTTP header must  be sent. This is immediately
+%	    after setting the transfer encoding to =chunked= or when the
+%	    CGI stream is closed.  Typically   it  requests  the current
+%	    header, optionally the content-length and   sends the header
+%	    to the original (client) stream.
+%
+%	    * close
+%	    Called from close/1 on the CGI   stream  after everything is
+%	    complete.
+%
+%	The predicates cgi_property/2  and  cgi_set/2   can  be  used to
+%	control the stream and store status   info.  Terms are stored as
+%	Prolog records and can thus be transferred between threads.
+
+%%	cgi_property(+CGIStream, ?Property) is det.
+%
+%	Inquire the status of the CGI stream.  Defined properties are:
+%
+%	    * request(-Term)
+%	    The original request
+%	    * header(-Term)
+%	    Term is the header term as registered using cgi_set/2
+%	    * client(-Stream)
+%	    Stream is the original output stream used to create
+%	    this stream.
+%	    * thread(-ThreadID)
+%	    ThreadID is the identifier of the `owning thread'
+%	    * transfer_encoding(-Tranfer)
+%	    One of =chunked= or =none=.
+%	    * connection(-Connection)
+%	    One of =Keep-Alife= or =close=
+%	    * content_length(-ContentLength)
+%	    Total byte-size of the content.  Available in the close
+%	    handler if the transfer_encoding is =none=.
+%	    * header_codes(-Codes)
+%	    Codes represents the header collected.  Available in the
+%	    header handler.
+%	    * state(-State)
+%	    One of =header=, =data= or =discarded=
+
+%%	cgi_set(+CGIStream, ?Property) is det.
+%
+%	Change one of the properies.  Supported properties are:
+%
+%	    * request(+Term)
+%	    Associate a request to the stream.
+%	    * header(+Term)
+%	    Register a reply header.  This header is normally retrieved
+%	    from the =send_header= hook to send the reply header to the
+%	    client.
+%	    * connection(-Connection)
+%	    One of =Keep-Alife= or =close=.
+%	    * transfer_encoding(-Tranfer)
+%	    One of =chunked= or =none=.  Initially set to =none=.  When
+%	    switching to =chunked= from the =header= hook, it calls the
+%	    =send_header= hook and if there is data queed this is send
+%	    as first chunk.  Each subsequent write to the CGI stream
+%	    emits a chunk.
+
+%%	cgi_discard(+CGIStream) is det.
+%
+%	Discard content produced sofar. It sets   the  state property to
+%	=discarded=, causing close to omit the   writing  the data. This
+%	must be to use an alternate output   (e.g. an error page) if the
+%	page generator fails.
+
+%%	is_cgi_stream(+Stream) is semidet.
+%
+%	True if Stream is a CGI stream created using cgi_open/4.
+
+:- multifile
+	http:encoding_filter/3.		% +Encoding, +In0,  -In
+:- multifile
+	http:current_transfer_encoding/1. % ?Encoding
+
+%	http:encoding_filter(+Encoding, +In0, -In) is semidet.
+%
+%	Install a filter to deal with =chunked= encoded messages.
+
+http:encoding_filter(chunked, In0, In) :-
+	http_chunked_open(In0, In,
+			  [ close_parent(true)
+			  ]).
+
+%	http:current_transfer_encoding(?Encoding) is semidet.
+%
+%	True if Encoding is supported
+
+http:current_transfer_encoding(chunked).
+
+:- retract(system:swi_io).

packages/http/http_wrapper.pl

@@ -0,0 +1,405 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2009, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(httpd_wrapper,
+	  [ http_wrapper/5,		% :Goal, +In, +Out, -Conn, +Options
+	    http_current_request/1,	% -Request
+	    http_send_header/1,		% +Term
+	    http_relative_path/2,	% +AbsPath, -RelPath
+					% Internal API
+	    http_wrap_spawned/3,	% :Goal, -Request, -Connection
+	    http_spawned/1		% +ThreadId
+	  ]).
+:- use_module(http_header).
+:- use_module(http_stream).
+:- use_module(http_exception).
+:- use_module(library(lists)).
+:- use_module(library(debug)).
+:- use_module(library(broadcast)).
+
+:- meta_predicate
+	http_wrapper(0, +, +, -, +).
+:- multifile
+	http:request_expansion/2.
+
+%%	http_wrapper(:Goal, +In, +Out, -Close, +Options) is det.
+%
+%	Simple wrapper to read and decode an HTTP header from `In', call
+%	:Goal while watching for exceptions and send the result to the
+%	stream `Out'.
+%
+%	The goal is assumed  to  write   the  reply  to =current_output=
+%	preceeded by an HTTP header, closed by  a blank line. The header
+%	*must* contain a Content-type: <type>   line.  It may optionally
+%	contain a line =|Transfer-encoding: chunked|= to request chunked
+%	encoding.
+%
+%	Options:
+%
+%		* request(-Request)
+%		Return the full request to the caller
+%		* peer(+Peer)
+%		IP address of client
+%
+%	@param Close	Unified to one of =close=, =|Keep-Alife|= or
+%			spawned(ThreadId).
+
+http_wrapper(Goal, In, Out, Close, Options) :-
+	status(Id, State0),
+	catch(http_read_request(In, Request0), ReqError, true),
+	(   Request0 == end_of_file
+	->  Close = close,
+	    extend_request(Options, [], _) % return request
+	;   var(ReqError)
+	->  extend_request(Options, Request0, Request1),
+	    memberchk(method(Method), Request1),
+	    memberchk(path(Location), Request1),
+	    cgi_open(Out, CGI, cgi_hook, [request(Request1)]),
+	    cgi_property(CGI, id(Id)),
+	    debug(http(request), '[~D] ~w ~w ...', [Id, Method, Location]),
+	    handler_with_output_to(Goal, Id, Request1, CGI, Error),
+	    cgi_close(CGI, State0, Error, Close)
+	;   Id = 0,
+	    send_error(Out, State0, ReqError, Close),
+	    extend_request(Options, [], _)
+	).
+
+status(Id, state0(Thread, CPU, Id)) :-
+	thread_self(Thread),
+	thread_cputime(CPU).
+
+
+%%	http_wrap_spawned(:Goal, -Request, -Close) is det.
+%
+%	Internal  use  only.  Helper  for    wrapping  the  handler  for
+%	http_spawn/2.
+%
+%	@see http_spawned/1, http_spawn/2.
+
+http_wrap_spawned(Goal, Request, Close) :-
+	current_output(CGI),
+	cgi_property(CGI, id(Id)),
+	handler_with_output_to(Goal, Id, -, current_output, Error),
+	(   retract(spawned(ThreadId))
+	->  Close = spawned(ThreadId),
+	    Request = []
+	;   cgi_property(CGI, request(Request)),
+	    status(Id, State0),
+	    catch(cgi_close(CGI, State0, Error, Close),
+		  _,
+		  Close = close)
+	).
+
+
+:- thread_local
+	spawned/1.
+
+%%	http_spawned(+ThreadId)
+%
+%	Internal use only. Indicate that the request is handed to thread
+%	ThreadId.
+
+http_spawned(ThreadId) :-
+	assert(spawned(ThreadId)).
+
+
+%%	cgi_close(+CGI, +State0, +Error, -Close) is det.
+%
+%	The wrapper has completed. Finish the  CGI output. We have three
+%	cases:
+%
+%	    * The wrapper delegated the request to a new thread
+%	    * The wrapper succeeded
+%	    * The wrapper threw an error, non-200 status reply
+%	    (e.g., =not_modified=, =moved=) or a request to reply with
+%	    the content of a file.
+%
+%	@error socket I/O errors.
+
+cgi_close(_, _, _, Close) :-
+	retract(spawned(ThreadId)), !,
+	Close = spawned(ThreadId).
+cgi_close(CGI, State0, ok, Close) :- !,
+	catch(cgi_finish(CGI, Close, Bytes), E, true),
+	(   var(E)
+	->  http_done(200, ok, Bytes, State0)
+	;   http_done(500, E, 0, State0),	% TBD: amount written?
+	    throw(E)
+	).
+cgi_close(CGI, Id, Error, Close) :-
+	cgi_property(CGI, client(Out)),
+	cgi_discard(CGI),
+	close(CGI),
+	send_error(Out, Id, Error, Close).
+
+cgi_finish(CGI, Close, Bytes) :-
+	flush_output,			% update the content-length
+	cgi_property(CGI, connection(Close)),
+	cgi_property(CGI, content_length(Bytes)),
+	close(CGI).
+
+%%	send_error(+Out, +State0, +Error, -Close)
+%
+%	Send status replies and  reply   files.  The =current_output= no
+%	longer points to the CGI stream, but   simply to the socket that
+%	connects us to the client.
+%
+%	@param	State0 is start-status as returned by status/1.  Used to
+%		find CPU usage, etc.
+
+send_error(Out, State0, Error, Close) :-
+	map_exception_to_http_status(Error, Reply, HdrExtra),
+	catch(http_reply(Reply, Out,
+			 [ content_length(CLen)
+			 | HdrExtra
+			 ],
+			 Code),
+	      E, true),
+	(   var(E)
+	->  http_done(Code, Error, CLen, State0)
+	;   http_done(500,  E, 0, State0),
+	    throw(E)			% is that wise?
+	),
+	(   memberchk(connection(Close), HdrExtra)
+	->  true
+	;   Close = close
+	).
+
+
+%%	http_done(+Code, +Status, +BytesSent, +State0) is det.
+%
+%	Provide feedback for logging and debugging   on  how the request
+%	has been completed.
+
+http_done(Code, Status, Bytes, state0(_Thread, CPU0, Id)) :-
+	thread_cputime(CPU1),
+	CPU is CPU1 - CPU0,
+	(   debugging(http(request))
+	->  debug_request(Code, Status, Id, CPU, Bytes)
+	;   true
+	),
+	broadcast(http(request_finished(Id, Code, Status, CPU, Bytes))).
+
+
+%%	handler_with_output_to(:Goal, +Id, +Request, +Output, -Status) is det.
+%
+%	Run Goal with output redirected to   Output. Unifies Status with
+%	=ok=, the error from catch/3  or a term error(goal_failed(Goal),
+%	_).
+%
+%	@param Request	The HTTP request read or '-' for a continuation
+%			using http_spawn/2.
+
+handler_with_output_to(Goal, Id, Request, current_output, Status) :- !,
+	(   catch(call_handler(Goal, Id, Request), Status, true)
+	->  (   var(Status)
+	    ->	Status = ok
+	    ;	true
+	    )
+	;   Status = error(goal_failed(Goal),_)
+	).
+handler_with_output_to(Goal, Id, Request, Output, Error) :-
+	current_output(OldOut),
+	set_output(Output),
+	handler_with_output_to(Goal, Id, Request, current_output, Error),
+	set_output(OldOut).
+
+call_handler(Goal, _, -) :- !,		% continuation through http_spawn/2
+	call(Goal).
+call_handler(Goal, Id, Request0) :-
+	expand_request(Request0, Request),
+	current_output(CGI),
+	cgi_set(CGI, request(Request)),
+	broadcast(http(request_start(Id, Request))),
+	call(Goal, Request).
+
+%%	thread_cputime(-CPU) is det.
+%
+%	CPU is the CPU time used by the calling thread.
+%
+%	@tbd	This does not work on MacOS X!
+
+:- if(current_prolog_flag(threads, true)).
+thread_cputime(CPU) :-
+	thread_self(Me),
+	thread_statistics(Me, cputime, CPU).
+:- else.
+thread_cputime(CPU) :-
+	statistics(cputime, CPU).
+:- endif.
+
+
+%%	cgi_hook(+Event, +CGI) is det.
+%
+%	Hook called from the CGI   processing stream. See http_stream.pl
+%	for details.
+
+cgi_hook(What, _CGI) :-
+	debug(http(hook), 'Running hook: ~q', [What]),
+	fail.
+cgi_hook(header, CGI) :-
+	cgi_property(CGI, header_codes(HeadText)),
+	cgi_property(CGI, header(Header0)), % see http_send_header/1
+	http_parse_header(HeadText, CgiHeader0),
+	append(Header0, CgiHeader0, CgiHeader),
+	cgi_property(CGI, request(Request)),
+	http_update_connection(CgiHeader, Request, Connection, Header1),
+	http_update_transfer(Request, Header1, Transfer, Header2),
+	http_update_encoding(Header2, Encoding, Header),
+	set_stream(CGI, encoding(Encoding)),
+	cgi_set(CGI, connection(Connection)),
+	cgi_set(CGI, header(Header)),
+	debug(http(transfer_encoding), 'Transfer-encoding: ~w', [Transfer]),
+	cgi_set(CGI, transfer_encoding(Transfer)). % must be LAST
+cgi_hook(send_header, CGI) :-
+	cgi_property(CGI, header(Header)),
+	cgi_property(CGI, client(Out)),
+	(   cgi_property(CGI, transfer_encoding(chunked))
+	->  http_reply_header(Out, chunked_data, Header)
+	;   cgi_property(CGI, content_length(Len))
+	->  http_reply_header(Out, cgi_data(Len), Header)
+	).
+cgi_hook(close, _).
+
+
+%%	http_send_header(+Header)
+%
+%	This API provides an alternative for writing the header field as
+%	a CGI header. Header has the  format Name(Value), as produced by
+%	http_read_header/2.
+%
+%	@deprecated	Use CGI lines instead
+
+http_send_header(Header) :-
+	current_output(CGI),
+	cgi_property(CGI, header(Header0)),
+	cgi_set(CGI, header([Header|Header0])).
+
+
+%%	expand_request(+Request0, -Request)
+%
+%	Allow  for  general   rewrites   of    a   request   by  calling
+%	http:request_expansion/2.
+
+expand_request(R0, R) :-
+	http:request_expansion(R0, R1),		% Hook
+	R1 \== R0, !,
+	expand_request(R1, R).
+expand_request(R, R).
+
+
+%%	extend_request(+Options, +RequestIn, -Request)
+%
+%	Merge options in the request.
+
+extend_request([], R, R).
+extend_request([request(R)|T], R0, R) :- !,
+	extend_request(T, R0, R).
+extend_request([H|T], R0, R) :-
+	request_option(H), !,
+	extend_request(T, [H|R0], R).
+extend_request([_|T], R0, R) :-
+	extend_request(T, R0, R).
+
+request_option(peer(_)).
+request_option(protocol(_)).
+request_option(pool(_)).
+
+
+%%	http_current_request(-Request) is semidet.
+%
+%	Returns  the  HTTP  request  currently  being  processed.  Fails
+%	silently if there is no current  request. This typically happens
+%	if a goal is run outside the HTTP server context.
+
+http_current_request(Request) :-
+	current_output(CGI),
+	is_cgi_stream(CGI),
+	cgi_property(CGI, request(Request)).
+
+
+%%	http_relative_path(+AbsPath, -RelPath) is det.
+%
+%	Convert an absolute path (without host, fragment or search) into
+%	a path relative to the current page.   This  call is intended to
+%	create reusable components returning relative   paths for easier
+%	support of reverse proxies.
+
+http_relative_path(Path, RelPath) :-
+	http_current_request(Request),
+	memberchk(path(RelTo), Request),
+	http_relative_path(Path, RelTo, RelPath), !.
+http_relative_path(Path, Path).
+
+http_relative_path(Path, RelTo, RelPath) :-
+	atomic_list_concat(PL, /, Path),
+	atomic_list_concat(RL, /, RelTo),
+	delete_common_prefix(PL, RL, PL1, PL2),
+	to_dot_dot(PL2, DotDot, PL1),
+	atomic_list_concat(DotDot, /, RelPath).
+
+delete_common_prefix([H|T01], [H|T02], T1, T2) :- !,
+	delete_common_prefix(T01, T02, T1, T2).
+delete_common_prefix(T1, T2, T1, T2).
+
+to_dot_dot([], Tail, Tail).
+to_dot_dot([_], Tail, Tail) :- !.
+to_dot_dot([_|T0], ['..'|T], Tail) :-
+	to_dot_dot(T0, T, Tail).
+
+
+		 /*******************************
+		 *	   DEBUG SUPPORT	*
+		 *******************************/
+
+%%	debug_request(+Code, +Status, +Id, +CPU0, Bytes)
+%
+%	Emit debugging info after a request completed with Status.
+
+debug_request(Code, ok, Id, CPU, Bytes) :- !,
+	debug(http(request), '[~D] ~w OK (~3f seconds; ~D bytes)',
+	      [Id, Code, CPU, Bytes]).
+debug_request(Code, Status, Id, _, Bytes) :-
+	map_exception(Status, Reply), !,
+	debug(http(request), '[~D] ~w ~w; ~D bytes',
+	      [Id, Code, Reply, Bytes]).
+debug_request(Code, Except, Id, _, _) :- !,
+	Except = error(_,_), !,
+	message_to_string(Except, Message),
+	debug(http(request), '[~D] ~w ERROR: ~w',
+	      [Id, Code, Message]).
+debug_request(Code, Status, Id, _, Bytes) :-
+	debug(http(request), '[~D] ~w ~w; ~D bytes',
+	      [Id, Code, Status, Bytes]).
+
+map_exception(http_reply(Reply), Reply).
+map_exception(error(existence_error(http_location, Location), _Stack),
+	      error(404, Location)).

packages/http/inetd_httpd.pl

@@ -0,0 +1,65 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(http_test,
+	  [ http_server/2		% :Goal, +Options
+	  ]).
+:- use_module(http_wrapper).
+
+:- meta_predicate
+	http_server(:, +),
+	server_loop(:, +).
+
+%%	http_server(:Goal, +Options)
+%
+%	Start the server from inetd. This is really easy as user_input
+%	is connected to the HTTP input and user_output is the place to
+%	write our reply to.
+
+http_server(Goal, Options) :-
+	prompt(_, ''),
+	set_stream(user_output, buffer(full)),
+	set_stream(user_output, encoding(octet)),
+	set_stream(user_input, buffer(full)),
+	set_stream(user_input, encoding(octet)),
+	server_loop(Goal, Options).
+
+server_loop(_, _) :-
+	at_end_of_stream(user_input), !,
+	halt.
+server_loop(Goal, Options) :-
+	http_wrapper(Goal, user_input, user_output, Connection, []),
+	(   downcase_atom(Connection, 'keep-alive')
+	->  server_loop(Goal, Options)
+	;   halt
+	).
+server_loop(_, _) :-			% wrapper failed
+	halt.

packages/http/install-sh

@@ -0,0 +1,238 @@
+#!/bin/sh
+#
+# install - install a program, script, or datafile
+# This comes from X11R5.
+#
+# Calling this script install-sh is preferred over install.sh, to prevent
+# `make' implicit rules from creating a file called install from it
+# when there is no Makefile.
+#
+# This script is compatible with the BSD install script, but was written
+# from scratch.
+#
+
+
+# set DOITPROG to echo to test this script
+
+# Don't use :- since 4.3BSD and earlier shells don't like it.
+doit="${DOITPROG-}"
+
+
+# put in absolute paths if you don't have them in your path; or use env. vars.
+
+mvprog="${MVPROG-mv}"
+cpprog="${CPPROG-cp}"
+chmodprog="${CHMODPROG-chmod}"
+chownprog="${CHOWNPROG-chown}"
+chgrpprog="${CHGRPPROG-chgrp}"
+stripprog="${STRIPPROG-strip}"
+rmprog="${RMPROG-rm}"
+mkdirprog="${MKDIRPROG-mkdir}"
+
+tranformbasename=""
+transform_arg=""
+instcmd="$mvprog"
+chmodcmd="$chmodprog 0755"
+chowncmd=""
+chgrpcmd=""
+stripcmd=""
+rmcmd="$rmprog -f"
+mvcmd="$mvprog"
+src=""
+dst=""
+dir_arg=""
+
+while [ x"$1" != x ]; do
+    case $1 in
+	-c) instcmd="$cpprog"
+	    shift
+	    continue;;
+
+	-d) dir_arg=true
+	    shift
+	    continue;;
+
+	-m) chmodcmd="$chmodprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-o) chowncmd="$chownprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-g) chgrpcmd="$chgrpprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-s) stripcmd="$stripprog"
+	    shift
+	    continue;;
+
+	-t=*) transformarg=`echo $1 | sed 's/-t=//'`
+	    shift
+	    continue;;
+
+	-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
+	    shift
+	    continue;;
+
+	*)  if [ x"$src" = x ]
+	    then
+		src=$1
+	    else
+		# this colon is to work around a 386BSD /bin/sh bug
+		:
+		dst=$1
+	    fi
+	    shift
+	    continue;;
+    esac
+done
+
+if [ x"$src" = x ]
+then
+	echo "install:	no input file specified"
+	exit 1
+else
+	true
+fi
+
+if [ x"$dir_arg" != x ]; then
+	dst=$src
+	src=""
+	
+	if [ -d $dst ]; then
+		instcmd=:
+	else
+		instcmd=mkdir
+	fi
+else
+
+# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
+# might cause directories to be created, which would be especially bad 
+# if $src (and thus $dsttmp) contains '*'.
+
+	if [ -f $src -o -d $src ]
+	then
+		true
+	else
+		echo "install:  $src does not exist"
+		exit 1
+	fi
+	
+	if [ x"$dst" = x ]
+	then
+		echo "install:	no destination specified"
+		exit 1
+	else
+		true
+	fi
+
+# If destination is a directory, append the input filename; if your system
+# does not like double slashes in filenames, you may need to add some logic
+
+	if [ -d $dst ]
+	then
+		dst="$dst"/`basename $src`
+	else
+		true
+	fi
+fi
+
+## this sed command emulates the dirname command
+dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
+
+# Make sure that the destination directory exists.
+#  this part is taken from Noah Friedman's mkinstalldirs script
+
+# Skip lots of stat calls in the usual case.
+if [ ! -d "$dstdir" ]; then
+defaultIFS='	
+'
+IFS="${IFS-${defaultIFS}}"
+
+oIFS="${IFS}"
+# Some sh's can't handle IFS=/ for some reason.
+IFS='%'
+set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
+IFS="${oIFS}"
+
+pathcomp=''
+
+while [ $# -ne 0 ] ; do
+	pathcomp="${pathcomp}${1}"
+	shift
+
+	if [ ! -d "${pathcomp}" ] ;
+        then
+		$mkdirprog "${pathcomp}"
+	else
+		true
+	fi
+
+	pathcomp="${pathcomp}/"
+done
+fi
+
+if [ x"$dir_arg" != x ]
+then
+	$doit $instcmd $dst &&
+
+	if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
+	if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
+	if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
+	if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
+else
+
+# If we're going to rename the final executable, determine the name now.
+
+	if [ x"$transformarg" = x ] 
+	then
+		dstfile=`basename $dst`
+	else
+		dstfile=`basename $dst $transformbasename | 
+			sed $transformarg`$transformbasename
+	fi
+
+# don't allow the sed command to completely eliminate the filename
+
+	if [ x"$dstfile" = x ] 
+	then
+		dstfile=`basename $dst`
+	else
+		true
+	fi
+
+# Make a temp file name in the proper directory.
+
+	dsttmp=$dstdir/#inst.$$#
+
+# Move or copy the file name to the temp name
+
+	$doit $instcmd $src $dsttmp &&
+
+	trap "rm -f ${dsttmp}" 0 &&
+
+# and set any options; do chmod last to preserve setuid bits
+
+# If any of these fail, we abort the whole thing.  If we want to
+# ignore errors from any of these, just make sure not to ignore
+# errors from the above "$doit $instcmd $src $dsttmp" command.
+
+	if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
+	if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
+	if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
+	if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
+
+# Now rename the file to the real destination.
+
+	$doit $rmcmd -f $dstdir/$dstfile &&
+	$doit $mvcmd $dsttmp $dstdir/$dstfile 
+
+fi &&
+
+
+exit 0

packages/http/js_write.pl

@@ -0,0 +1,231 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker, Michiel Hildebrand
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2007-2010, University of Amsterdam
+			      VU University Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(javascript,
+	  [ js_call//1,			% +Function(Arg..)
+	    js_new//2,			% +Id, +Function(+Args)
+	    js_args//1			% +Args
+	  ]).
+
+:- use_module(library(http/html_write)).
+:- use_module(library(http/json_convert)).
+:- use_module(library(http/json)).
+:- use_module(library(error)).
+:- use_module(library(debug)).
+
+/** <module> Utilities for including javascript
+
+This library is a supplement   to library(http/html_write) for producing
+JavaScript fragments. Its main role is  to   be  able to call JavaScript
+functions with valid  arguments  constructed   from  Prolog  data.  E.g.
+suppose you want to call a  JavaScript   functions  to process a list of
+names represented as Prolog atoms.  This  can   be  done  using the call
+below, while without this library  you  would   have  to  be  careful to
+properly escape special characters.
+
+    ==
+    numbers_script(Names) -->
+	html(script(type('text/javascript'),
+	     [ \js_call('ProcessNumbers'(Names)
+	     ]),
+    ==
+
+The accepted arguments are described with js_args//1.
+*/
+
+%%	js_call(+Term)// is det.
+%
+%	Emit a call to a Javascript function.  The Prolog functor is the
+%	name of the function. The arguments are converted from Prolog to
+%	JavaScript using js_args//1. Please not that Prolog functors can
+%	be quoted atom and thus the following is legal:
+%
+%	    ==
+%	    	...
+%	    	html(script(type('text/javascript'),
+%	    	     [ \js_call('x.y.z'(hello, 42)
+%	    	     ]),
+%	    ==
+
+js_call(Term) -->
+	{ Term =.. [Function|Args] },
+	html([Function, '(']),
+	js_args(Args),
+	html(');\n').
+
+
+%%	js_new(+Id, +Term)// is det.
+%
+%	Emit a call to a Javascript object declaration. This is the same
+%	as:
+%
+%	    ==
+%	    ['var ', Id, ' = new ', \js_call(Term)]
+%	    ==
+
+
+js_new(Id, Term) -->
+	{ Term =.. [Function|Args] },
+	html(['var ', Id, ' = new ', Function, '(']),
+	js_args(Args),
+	html(');\n').
+
+%%	js_args(+Args:list)// is det.
+%
+%	Write javascript function arguments. Each  argument is separated
+%	by a comma. Elements  of  the   list  may  contain the following
+%	terms:
+%
+%	    $ Variable :
+%	    Emitted as Javascript =null=
+%	    $ List :
+%	    Produces a Javascript list, where each element is processed
+%	    by this library.
+%	    $ object(Attributes) :
+%	    Where Attributes is a Key-Value list where each pair can be
+%	    written as Key-Value, Key=Value or Key(Value), accomodating
+%	    all common constructs for this used in Prolog.
+%	    $ json(Term) :
+%	    Emits a term using json_write/3.
+%	    $ @(true), @(false), @(null) :
+%	    Emits these constants without quotes.
+%	    $ Number :
+%	    Emited literally
+%	    $ symbol(Atom) :
+%	    Emitted without quotes.  Can be used for JavaScript symbols
+%	    (e.i., function and variable-names)
+%	    $ Atom or String :
+%	    Emitted as quoted JavaScript string.
+
+js_args([]) -->
+	[].
+js_args([H|T]) -->
+	(   js_arg(H)
+	->  (   { T == [] }
+	    ->  []
+	    ;   html(', '),
+		js_args(T)
+	    )
+	;   { type_error(javascript_argument, H) }
+	).
+
+js_arg(H) -->
+	{ var(H) }, !,
+	[null].
+js_arg(object(H)) -->
+	{ is_list(H) }, !,
+	html([ '{', \js_kv_list(H), '}' ]).
+js_arg(@(true)) -->  [true].
+js_arg(@(false)) --> [false].
+js_arg(@(null)) -->  [null].
+js_arg(symbol(H)) -->
+	[H].
+js_arg(json(Term)) -->
+	{ json_to_string(json(Term), String),
+	  debug(json_arg, '~w~n', String)
+	},
+	[ String ].
+js_arg(H) -->
+	{ is_list(H) }, !,
+	html([ '[', \js_args(H), ']' ]).
+js_arg(H) -->
+	{ number(H) }, !,
+	[H].
+js_arg(H) -->
+	{ atomic(H), !,
+	  js_quoted_string(H, Q)
+	},
+	[ '\'', Q, '\''
+	].
+
+js_kv_list([]) --> [].
+js_kv_list([H|T]) -->
+	(   js_kv(H)
+	->  (   { T == [] }
+	    ->	[]
+	    ;	html(', '),
+		js_kv_list(T)
+	    )
+	;   { type_error(javascript_key_value, H) }
+	).
+
+js_kv(Key-Value) -->
+	html(['\'',Key,'\':',\js_arg(Value)]).
+js_kv(Key=Value) -->
+	html(['\'',Key,'\':',\js_arg(Value)]).
+js_kv(Term) -->
+	{ compound(Term),
+	  Term =.. [Key,Value]
+	}, !,
+	html(['\'',Key,'\':',\js_arg(Value)]).
+
+%%	js_quoted_string(+Raw, -Quoted)
+%
+%	Quote text for use in JavaScript. Quoted does _not_ include the
+%	leading and trailing quotes.
+%
+%	@tbd	Join with json stuff.
+
+js_quoted_string(Raw, Quoted) :-
+	atom_codes(Raw, Codes),
+	phrase(js_quote_codes(Codes), QuotedCodes),
+	atom_codes(Quoted, QuotedCodes).
+
+js_quote_codes([]) -->
+	[].
+js_quote_codes([0'\r,0'\n|T]) --> !,
+	"\\n",
+	js_quote_codes(T).
+js_quote_codes([H|T]) -->
+	js_quote_code(H),
+	js_quote_codes(T).
+
+js_quote_code(0'') --> !,
+	"\\'".
+js_quote_code(34) --> !,
+	[92,34].
+js_quote_code(0'\\) --> !,
+	"\\\\".
+js_quote_code(0'\n) --> !,
+	"\\n".
+js_quote_code(0'\r) --> !,
+	"\\r".
+js_quote_code(0'\t) --> !,
+	"\\t".
+js_quote_code(C) -->
+	[C].
+
+%%	json_to_string(+JSONTerm, -String)
+%
+%	Write JSONTerm to String.
+
+json_to_string(JSON, String) :-
+	with_output_to(string(String),
+		       json_write(current_output,JSON,[width(0)])).

packages/http/json.c

@@ -0,0 +1,152 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*/
+
+#include <SWI-Stream.h>
+#include <SWI-Prolog.h>
+#include <string.h>
+
+#define TRYPUTC(c, s) if ( Sputcode(c, s) < 0 ) { return -1; }
+
+static int
+json_put_code(IOSTREAM *out, int c)
+{ static char escape[128];
+  static int escape_initialized = FALSE;
+
+  if ( !escape_initialized )
+  { memset(escape, 0, sizeof(escape));
+
+    escape['"']  = '"';
+    escape['\\'] = '\\';
+    escape['\b'] = 'b';
+    escape['\f'] = 'f';
+    escape['\n'] = 'n';
+    escape['\r'] = 'r';
+    escape['\t'] = 't';
+
+    escape_initialized = TRUE;
+  }
+
+  if ( c < 128 )
+  { if ( escape[c] )
+    { TRYPUTC('\\', out);
+      TRYPUTC(escape[c], out);
+    } else if ( c < ' ' )	/* control characters *must* be escaped */
+    { TRYPUTC('\\', out);
+      if ( Sfprintf(out, "u%04x", c) < 0 )
+	return -1;
+    } else
+    { TRYPUTC(c, out);
+    }
+  } else
+  { TRYPUTC(c, out);
+  }
+
+  return 0;
+}
+
+#undef TRYPUTC
+#define TRYPUTC(c, s) if ( Sputcode(c, s) < 0 ) { rc = FALSE; goto out; }
+
+static foreign_t
+json_write_string(term_t stream, term_t text)
+{ IOSTREAM *out;
+  char *a;
+  pl_wchar_t *w;
+  size_t len;
+  int rc = TRUE;
+
+  if ( !PL_get_stream_handle(stream, &out) )
+    return FALSE;
+
+  if ( PL_get_nchars(text, &len, &a, CVT_ATOM|CVT_STRING|CVT_LIST) )
+  { const char *ap;
+    size_t todo;
+
+    TRYPUTC('"', out);
+    for(todo=len, ap=a; todo-- > 0; ap++)
+    { int c = *ap&0xff;
+
+      if ( json_put_code(out, c) < 0 )
+      { rc = FALSE; goto out;
+      }
+    }
+    TRYPUTC('"', out);
+  } else if ( PL_get_wchars(text, &len, &w, CVT_ATOM|CVT_STRING|CVT_LIST|CVT_EXCEPTION) )
+  { const pl_wchar_t *wp;
+    size_t todo;
+
+    TRYPUTC('"', out);
+    for(todo=len, wp=w; todo-- > 0; wp++)
+    { int c = *wp;
+
+      if ( json_put_code(out, c) < 0 )
+      { rc = FALSE; goto out;
+      }
+    }
+    TRYPUTC('"', out);
+  } else
+  { rc = FALSE;
+  }
+
+out:
+  PL_release_stream(out);
+
+  return rc;
+}
+
+
+static foreign_t
+json_write_indent(term_t stream, term_t indent, term_t tab)
+{ int i, t, n;
+  IOSTREAM *out;
+
+  if ( !PL_get_integer(indent, &i) ||
+       !PL_get_integer(tab, &t) )
+    return FALSE;
+
+  if ( PL_get_stream_handle(stream, &out) )
+  { int rc = TRUE;
+
+    if ( !out->position || out->position->linepos > 0 )
+    { TRYPUTC('\n', out);
+    }
+    for(n=0; n<i/t; n++)
+      TRYPUTC('\t', out);
+    for(n=0; n<i%t; n++)
+      TRYPUTC(' ', out);
+out:
+    PL_release_stream(out);
+    return rc;
+  }
+
+  return FALSE;
+}
+
+
+
+install_t
+install_json()
+{ PL_register_foreign("json_write_string", 2, json_write_string, 0);
+  PL_register_foreign("json_write_indent", 3, json_write_indent, 0);
+}

packages/http/json.pl

@@ -0,0 +1,654 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2009, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(json,
+	  [ json_read/2,		% +Stream, -JSONTerm
+	    json_read/3,		% +Stream, -JSONTerm, +Options
+	    atom_json_term/3,		% ?Atom, ?JSONTerm, +Options
+	    json_write/2,		% +Stream, +Term
+	    json_write/3,		% +Stream, +Term, +Options
+	    is_json_term/1,		% @Term
+	    is_json_term/2		% @Term, +Options
+	  ]).
+:- use_module(library(record)).
+:- use_module(library(memfile)).
+:- use_module(library(error)).
+:- use_module(library(option)).
+
+:- use_foreign_library(foreign(json)).
+
+/** <module> Reading and writing JSON serialization
+
+This module supports reading and writing JSON objects. The canonical
+Prolog representation for a JSON value is defined as:
+
+    * A JSON object is mapped to a term json(NameValueList), where
+    NameValueList is a list of Name=Value. Name is an atom created from
+    the JSON string.
+
+    * A JSON array is mapped to a Prolog list of JSON values.
+
+    * A JSON string is mapped to a Prolog atom
+
+    * A JSON number is mapped to a Prolog number
+
+    * The JSON constants =true= and =false= are mapped -like JPL- to
+    @(true) and @(false).
+
+    * The JSON constant =null= is mapped to the Prolog term @(null)
+
+Here is a complete example in JSON and its corresponding Prolog term.
+
+==
+{ "name":"Demo term",
+  "created": {
+    "day":null,
+    "month":"December",
+    "year":2007
+  },
+  "confirmed":true,
+  "members":[1,2,3]
+}
+==
+
+==
+json([ name='Demo term',
+       created=json([day= @null, month='December', year=2007]),
+       confirmed= @true,
+       members=[1, 2, 3]
+     ])
+==
+
+@author Jan Wielemaker
+@see	http_json.pl links JSON to the HTTP client and server modules.
+@see	json_convert.pl converts JSON Prolog terms to more comfortable
+terms.
+*/
+
+:- record json_options(null:ground = @(null),
+		       true:ground = @(true),
+		       false:ground = @(false),
+		       value_string_as:oneof([atom,string]) = atom).
+
+
+		 /*******************************
+		 *	       MAP		*
+		 *******************************/
+
+%%	atom_json_term(+Atom, -JSONTerm, +Options) is det.
+%%	atom_json_term(-Text, +JSONTerm, +Options) is det.
+%
+%	Convert between textual  representation  and   a  JSON  term. In
+%	_write_ mode, the option as(Type) defines the output type, which
+%	is one of =atom=, =string= or =codes=.
+
+atom_json_term(Atom, Term, Options) :-
+	ground(Atom), !,
+	atom_to_memory_file(Atom, MF),
+	open_memory_file(MF, read, In),
+	call_cleanup(json_read(In, Term, Options),
+		     (	 close(In),
+			 free_memory_file(MF))).
+atom_json_term(Result, Term, Options) :-
+	select_option(as(Type), Options, Options1),
+	(   type_term(Type, Result, Out)
+	->  true
+	;   must_be(oneof([atom,string,codes]), Type)
+	),
+	with_output_to(Out,
+		       json_write(current_output, Term, Options1)).
+
+type_term(atom,   Result, atom(Result)).
+type_term(string, Result, string(Result)).
+type_term(codes,  Result, codes(Result)).
+
+
+		 /*******************************
+		 *	     READING		*
+		 *******************************/
+
+%%	json_read(+Stream, -Term) is det.
+%%	json_read(+Stream, -Term, +Options) is det.
+%
+%	Read next JSON value from Stream into a Prolog term. Options
+%	are:
+%
+%		* null(NullTerm)
+%		Term used to represent JSON =null=.  Default @(null)
+%		* true(TrueTerm)
+%		Term used to represent JSON =true=.  Default @(true)
+%		* false(FalsTerm)
+%		Term used to represent JSON =false=.  Default @(false)
+%		* value_string_as(Type)
+%		Prolog type used for strings used as value.  Default
+%		is =atom=.  The alternative is =string=, producing a
+%		packed string object.  Please note that =codes= or
+%		=chars= would produce ambiguous output and is therefore
+%		not supported.
+
+json_read(Stream, Term) :-
+	default_json_options(Options),
+	json_value(Stream, Term, _, Options).
+
+json_read(Stream, Term, Options) :-
+	make_json_options(Options, OptionTerm, _RestOptions),
+	json_value(Stream, Term, _, OptionTerm).
+
+
+json_value(Stream, Term, Next, Options) :-
+	get_code(Stream, C0),
+	ws(C0, Stream, C1),
+	json_term(C1, Stream, Term, Next, Options).
+
+json_term(0'{, Stream, json(Pairs), Next, Options) :- !,
+	ws(Stream, C),
+	json_pairs(C, Stream, Pairs, Options),
+	get_code(Stream, Next).
+json_term(0'[, Stream, Array, Next, Options) :- !,
+	ws(Stream, C),
+	json_array(C, Stream, Array, Options),
+	get_code(Stream, Next).
+json_term(0'", Stream, String, Next, Options) :- !,
+	get_code(Stream, C1),
+	json_string_codes(C1, Stream, Codes),
+	json_options_value_string_as(Options, Type),
+	codes_to_type(Type, Codes, String),
+	get_code(Stream, Next).
+json_term(0'-, Stream, Number, Next, _Options) :- !,
+	json_number_codes(Stream, Codes, Next),
+	number_codes(Number, [0'-|Codes]).
+json_term(D, Stream, Number, Next, _Options) :-
+	between(0'0, 0'9, D), !,
+	json_number_codes(Stream, Codes, Next),
+	number_codes(Number, [D|Codes]).
+json_term(C, Stream, Constant, Next, Options) :-
+	get_code(Stream, C1),
+	json_identifier_codes(C1, Stream, Codes, Next),
+	atom_codes(ID, [C|Codes]),
+	json_constant(ID, Constant, Options).
+
+json_pairs(0'}, _, [], _) :- !.
+json_pairs(C0, Stream, [Pair|Tail], Options) :-
+	json_pair(C0, Stream, Pair, C, Options),
+	ws(C, Stream, Next),
+	(   Next == 0',
+	->  ws(Stream, C2),
+	    json_pairs(C2, Stream, Tail, Options)
+	;   Next == 0'}
+	->  Tail = []
+	;   syntax_error(illegal_object, Stream)
+	).
+
+json_pair(C0, Stream, Name=Value, Next, Options) :-
+	json_string_as_atom(C0, Stream, Name),
+	ws(Stream, C),
+	C == 0':,
+	json_value(Stream, Value, Next, Options).
+
+
+json_array(0'], _, [], _) :- !.
+json_array(C0, Stream, [Value|Tail], Options) :-
+	json_term(C0, Stream, Value, C, Options),
+	ws(C, Stream, Next),
+	(   Next == 0',
+	->  ws(Stream, C1),
+	    json_array(C1, Stream, Tail, Options)
+	;   Next == 0']
+	->  Tail = []
+	).
+
+codes_to_type(atom, Codes, Atom) :-
+	atom_codes(Atom, Codes).
+codes_to_type(string, Codes, Atom) :-
+	string_to_list(Atom, Codes).
+codes_to_type(codes, Codes, Codes).
+
+json_string_as_atom(0'", Stream, Atom) :-
+	get_code(Stream, C1),
+	json_string_codes(C1, Stream, Codes),
+	atom_codes(Atom, Codes).
+
+json_string_codes(0'", _, []) :- !.
+json_string_codes(0'\\, Stream, [H|T]) :- !,
+	get_code(Stream, C0),
+	(   escape(C0, Stream, H)
+	->  true
+	;   syntax_error(illegal_string_escape, Stream)
+	),
+	get_code(Stream, C1),
+	json_string_codes(C1, Stream, T).
+json_string_codes(C, Stream, [C|T]) :-
+	get_code(Stream, C1),
+	json_string_codes(C1, Stream, T).
+
+escape(0'", _, 0'") :- !.
+escape(0'\\, _, 0'\\) :- !.
+escape(0'/, _, 0'/) :- !.
+escape(0'b, _, 0'\b) :- !.
+escape(0'f, _, 0'\f) :- !.
+escape(0'n, _, 0'\n) :- !.
+escape(0'r, _, 0'\r) :- !.
+escape(0't, _, 0'\t) :- !.
+escape(0'u, Stream, C) :- !,
+	get_code(Stream, C1),
+	get_code(Stream, C2),
+	get_code(Stream, C3),
+	get_code(Stream, C4),
+	code_type(C1, xdigit(D1)),
+	code_type(C2, xdigit(D2)),
+	code_type(C3, xdigit(D3)),
+	code_type(C4, xdigit(D4)),
+	C is D1<<12+D2<<8+D3<<4+D4.
+
+json_number_codes(Stream, Codes, Next) :-
+	get_code(Stream, C1),
+	json_number_codes(C1, Stream, Codes, Next).
+
+json_number_codes(C1, Stream, [C1|Codes], Next) :-
+	number_code(C1), !,
+	get_code(Stream, C2),
+	json_number_codes(C2, Stream, Codes, Next).
+json_number_codes(C, _, [], C).
+
+number_code(C) :-
+	between(0'0, 0'9, C), !.
+number_code(0'.).
+number_code(0'-).
+number_code(0'e).
+number_code(0'E).
+
+json_identifier_codes(C1, Stream, [C1|T], Next) :-
+	between(0'a, 0'z, C1), !,
+	get_code(Stream, C2),
+	json_identifier_codes(C2, Stream, T, Next).
+json_identifier_codes(C, _, [], C).
+
+
+json_constant(true, Constant, Options) :- !,
+	json_options_true(Options, Constant).
+json_constant(false, Constant, Options) :- !,
+	json_options_false(Options, Constant).
+json_constant(null, Constant, Options) :- !,
+	json_options_null(Options, Constant).
+
+%%	ws(+Stream, -Next) is det.
+%%	ws(+C0, +Stream, -Next)
+%
+%	Skip white space on the Stream, returning the first non-ws
+%	character.  Also skips =|//|= ... comments.
+
+ws(Stream, Next) :-
+	get_code(Stream, C0),
+	ws(C0, Stream, Next).
+
+ws(C0, Stream, C) :-
+	ws(C0), !,
+	get_code(Stream, C1),
+	ws(C1, Stream, C).
+ws(0'/, Stream, C) :- !,
+	get_code(Stream, Cmt1), !,
+	expect(Cmt1, 0'/, Stream),
+	skip(Stream, 0'\n),
+	get_code(Stream, C).
+ws(C, _, C).
+
+ws(0' ).
+ws(0'\t).
+ws(0'\n).
+ws(0'\r).
+
+expect(C, C, _) :- !.
+expect(_, 0'/, Stream) :- !,
+	syntax_error(illegal_comment, Stream).
+
+syntax_error(Message, Stream) :-
+	stream_error_context(Stream, Context),
+	throw(error(syntax_error(json(Message)), Context)).
+
+stream_error_context(Stream, stream(Stream, Line, LinePos, CharNo)) :-
+	character_count(Stream, CharNo),
+	line_position(Stream, LinePos),
+	line_count(Stream, Line).
+
+
+		 /*******************************
+		 *	    JSON OUTPUT		*
+		 *******************************/
+
+%%	json_write_string(+Stream, +Text) is det.
+%
+%	Write a JSON string to  Stream.  Stream   must  be  opened  in a
+%	Unicode capable encoding, typically UTF-8.
+
+% foreign json_write_string/2.
+
+%%	json_write_indent(+Stream, +Indent, +TabDistance) is det.
+%
+%	Newline and indent to  Indent.  A   Newline  is  only written if
+%	line_position(Stream, Pos) is not 0. Then   it  writes Indent //
+%	TabDistance tab characters and Indent mode TabDistance spaces.
+
+% foreign json_write_indent/3.
+
+%%	json_write(+Stream, +Term) is det.
+%%	json_write(+Stream, +Term, +Options) is det.
+%
+%	Write a JSON term to Stream.  The   JSON  object  is of the same
+%	format as produced by json_read/2, though we allow for some more
+%	flexibility with regard to pairs in  objects. All of Name=Value,
+%	Name-Value and Name(Value) produce the  same output. In addition
+%	to  the  options  recognised  by  json_read/3,  we  process  the
+%	following options are recognised:
+%
+%	    * width(+Width)
+%	    Width in which we try to format the result.  Too long lines
+%	    switch from _horizontal_ to _vertical_ layout for better
+%	    readability. If performance is critical and human
+%	    readability is not an issue use Width = 0, which causes a
+%	    single-line output.
+%
+%	    * step(+Step)
+%	    Indentation increnment for next level.  Default is 2.
+%
+%	    * tab(+TabDistance)
+%	    Distance between tab-stops.  If equal to Step, layout
+%	    is generated with one tab per level.
+
+:- record json_write_state(indent:nonneg = 0,
+			   step:positive_integer = 2,
+			   tab:positive_integer = 8,
+			   width:nonneg = 72).
+
+json_write(Stream, Term) :-
+	json_write(Stream, Term, []).
+json_write(Stream, Term, Options) :-
+	make_json_write_state(Options, State, Options1),
+	make_json_options(Options1, OptionTerm, _RestOptions),
+	json_write_term(Term, Stream, State, OptionTerm).
+
+json_write_term(Var, _, _, _) :-
+	var(Var), !,
+	instantiation_error(Var).
+json_write_term(json(Pairs), Stream, State, Options) :- !,
+	space_if_not_at_left_margin(Stream),
+	write(Stream, '{'),
+	(   json_write_state_width(State, Width),
+	    (   Width == 0
+	    ->  true
+	    ;   json_write_state_indent(State, Indent),
+		json_print_length(json(Pairs), Options, Width, Indent, _)
+	    )
+	->  set_width_of_json_write_state(0, State, State2),
+	    write_pairs_hor(Pairs, Stream, State2, Options),
+	    write(Stream, '}')
+	;   step_indent(State, State2),
+	    write_pairs_ver(Pairs, Stream, State2, Options),
+	    indent(Stream, State),
+	    write(Stream, '}')
+	).
+json_write_term(List, Stream, State, Options) :-
+	is_list(List), !,
+	space_if_not_at_left_margin(Stream),
+	write(Stream, '['),
+	(   json_write_state_width(State, Width),
+	    (   Width == 0
+	    ->  true
+	    ;   json_write_state_indent(State, Indent),
+		json_print_length(List, Options, Width, Indent, _)
+	    )
+	->  set_width_of_json_write_state(0, State, State2),
+	    write_array_hor(List, Stream, State2, Options),
+	    write(Stream, ']')
+	;   step_indent(State, State2),
+	    write_array_ver(List, Stream, State2, Options),
+	    indent(Stream, State),
+	    write(Stream, ']')
+	).
+json_write_term(Number, Stream, _State, _Options) :-
+	number(Number), !,
+	write(Stream, Number).
+json_write_term(True, Stream, _State, Options) :-
+	json_options_true(Options, True), !,
+	write(Stream, true).
+json_write_term(False, Stream, _State, Options) :-
+	json_options_false(Options, False), !,
+	write(Stream, false).
+json_write_term(Null, Stream, _State, Options) :-
+	json_options_null(Options, Null), !,
+	write(Stream, null).
+json_write_term(String, Stream, _State, _Options) :-
+	json_write_string(Stream, String).
+
+write_pairs_hor([], _, _, _).
+write_pairs_hor([H|T], Stream, State, Options) :-
+	json_pair(H, Name, Value),
+	json_write_string(Stream, Name),
+	write(Stream, ':'),
+	json_write_term(Value, Stream, State, Options),
+	(   T == []
+	->  true
+	;   write(Stream, ', '),
+	    write_pairs_hor(T, Stream, State, Options)
+	).
+
+write_pairs_ver([], _, _, _).
+write_pairs_ver([H|T], Stream, State, Options) :-
+	indent(Stream, State),
+	json_pair(H, Name, Value),
+	json_write_string(Stream, Name),
+	write(Stream, ':'),
+	json_write_term(Value, Stream, State, Options),
+	(   T == []
+	->  true
+	;   write(Stream, ','),
+	    write_pairs_ver(T, Stream, State, Options)
+	).
+
+
+json_pair(Var, _, _) :-
+	var(Var), !,
+	instantiation_error(Var).
+json_pair(Name=Value, Name, Value) :- !.
+json_pair(Name-Value, Name, Value) :- !.
+json_pair(NameValue, Name, Value) :-
+	compound(NameValue),
+	NameValue =.. [Name, Value], !.
+json_pair(Pair, _, _) :-
+	type_error(json_pair, Pair).
+
+
+write_array_hor([], _, _, _).
+write_array_hor([H|T], Stream, State, Options) :-
+	json_write_term(H, Stream, State, Options),
+	(   T == []
+	->  true
+	;   write(Stream, ', '),
+	    write_array_hor(T, Stream, State, Options)
+	).
+
+write_array_ver([], _, _, _).
+write_array_ver([H|T], Stream, State, Options) :-
+	indent(Stream, State),
+	json_write_term(H, Stream, State, Options),
+	(   T == []
+	->  true
+	;   write(Stream, ','),
+	    write_array_ver(T, Stream, State, Options)
+	).
+
+
+indent(Stream, State) :-
+	json_write_state_indent(State, Indent),
+	json_write_state_tab(State, Tab),
+	json_write_indent(Stream, Indent, Tab).
+
+step_indent(State0, State) :-
+	json_write_state_indent(State0, Indent),
+	json_write_state_step(State0, Step),
+	NewIndent is Indent+Step,
+	set_indent_of_json_write_state(NewIndent, State0, State).
+
+space_if_not_at_left_margin(Stream) :-
+	line_position(Stream, 0), !.
+space_if_not_at_left_margin(Stream) :-
+	put_char(Stream, ' ').
+
+
+%%	json_print_length(+Value, +Options, +Max, +Len0, +Len) is semidet.
+%
+%	True if Len-Len0 is the print-length of Value on a single line
+%	and Len-Len0 =< Max.
+%
+%	@tbd	Escape sequences in strings are not considered.
+
+json_print_length(json(Pairs), Options, Max, Len0, Len) :- !,
+	Len1 is Len0 + 2,
+	Len1 =< Max,
+	pairs_print_length(Pairs, Options, Max, Len1, Len).
+json_print_length(Array, Options, Max, Len0, Len) :-
+	is_list(Array), !,
+	Len1 is Len0 + 2,
+	Len1 =< Max,
+	array_print_length(Array, Options, Max, Len1, Len).
+json_print_length(Null, Options, Max, Len0, Len) :-
+  json_options_null(Options, Null), !,
+	Len is Len0 + 4,
+	Len =< Max.
+json_print_length(False, Options, Max, Len0, Len) :-
+  json_options_false(Options, False), !,
+	Len is Len0 + 5,
+	Len =< Max.
+json_print_length(True, Options, Max, Len0, Len) :-
+  json_options_true(Options, True), !,
+	Len is Len0 + 4,
+	Len =< Max.
+json_print_length(Number, _Options, Max, Len0, Len) :-
+	number(Number), !,
+	atom_length(Number, AL),
+	Len is Len0 + AL,
+	Len =< Max.
+json_print_length(@(Id), _Options, Max, Len0, Len) :- !,
+	atom_length(Id, IdLen),
+	Len is Len0+IdLen,
+	Len =< Max.
+json_print_length(String, _Options, Max, Len0, Len) :-
+	string_len(String, Len0, Len),
+	Len =< Max.
+
+pairs_print_length([], _, _, Len, Len).
+pairs_print_length([H|T], Options, Max, Len0, Len) :-
+	pair_len(H, Options, Max, Len0, Len1),
+	(   T == []
+	->  Len = Len1
+	;   Len2 is Len1 + 2,
+	    Len2 =< Max,
+	    pairs_print_length(T, Options, Max, Len2, Len)
+	).
+
+pair_len(Name=Value, Options, Max, Len0, Len) :-
+	string_len(Name, Len0, Len1),
+	Len2 is Len1+2,
+	Len2 =< Max,
+	json_print_length(Value, Options, Max, Len2, Len).
+
+array_print_length([], _, _, Len, Len).
+array_print_length([H|T], Options, Max, Len0, Len) :-
+	json_print_length(H, Options, Max, Len0, Len1),
+	(   T == []
+	->  Len = Len1
+	;   Len2 is Len1+2,
+	    Len2 =< Max,
+	    array_print_length(T, Options, Max, Len2, Len)
+	).
+
+string_len(String, Len0, Len) :-
+	atom_length(String, AL),
+	Len is Len0 + AL + 2.
+
+
+		 /*******************************
+		 *	       TEST		*
+		 *******************************/
+
+%%	is_json_term(@Term) is semidet.
+%%	is_json_term(@Term, +Options) is semidet.
+%
+%	True if Term is  a  json  term.   Options  are  the  same as for
+%	json_read/2, defining the Prolog  representation   for  the JSON
+%	=true=, =false= and =null= constants.
+
+is_json_term(Term) :-
+	default_json_options(Options),
+	is_json_term2(Options, Term).
+
+is_json_term(Term, Options) :-
+	make_json_options(Options, OptionTerm, _RestOptions),
+	is_json_term2(OptionTerm, Term).
+
+is_json_term2(_, Var) :-
+	var(Var), !, fail.
+is_json_term2(Options, json(Pairs)) :- !,
+	is_list(Pairs),
+	maplist(is_json_pair(Options), Pairs).
+is_json_term2(Options, List) :-
+	is_list(List), !,
+	maplist(is_json_term2(Options), List).
+is_json_term2(_, Primitive) :-
+	atomic(Primitive), !.		% atom, string or number
+is_json_term2(Options, True) :-
+	json_options_true(Options, True).
+is_json_term2(Options, False) :-
+	json_options_false(Options, False).
+is_json_term2(Options, Null) :-
+	json_options_null(Options, Null).
+
+is_json_pair(_, Var) :-
+	var(Var), !, fail.
+is_json_pair(Options, Name=Value) :-
+	atom(Name),
+	is_json_term2(Options, Value).
+
+
+		 /*******************************
+		 *	     MESSAGES		*
+		 *******************************/
+
+:- multifile
+	prolog:error_message/3.
+
+prolog:error_message(syntax_error(json(Id))) -->
+	[ 'JSON syntax error: ' ],
+	json_syntax_error(Id).
+
+json_syntax_error(illegal_comment) -->
+	[ 'Illegal comment' ].
+json_syntax_error(illegal_string_escape) -->
+	[ 'Illegal escape sequence in string' ].

packages/http/json.txt

@@ -0,0 +1,30 @@
+---+ [json] Supporting JSON
+
+From  http://json.org, "
+JSON (JavaScript Object Notation) is a lightweight data-interchange
+format. It is easy for humans to read and write. It is easy for machines
+to parse and generate. It is based on a subset of the JavaScript
+Programming Language, Standard ECMA-262 3rd Edition - December 1999.
+JSON is a text format that is completely language independent but uses
+conventions that are familiar to programmers of the C-family of
+languages, including C, C++, C#, Java, JavaScript, Perl, Python, and
+many others. These properties make JSON an ideal data-interchange
+language."
+
+JSON is interesting to Prolog because using AJAX web technology we can
+easily created web-enabled user interfaces where we implement the server
+side using the SWI-Prolog HTTP services provided by this package.
+The interface consists of three libraries:
+
+    * library(http/json) provides support for the core JSON object
+      serialization.
+    * library(http/json_convert) converts between the primary
+      representation of JSON terms in Prolog and more application
+      oriented Prolog terms.  E.g. point(X,Y) vs. object([x=X,y=Y]).
+    * library(http/http_json) hooks the conversion libraries into
+      the HTTP client and server libraries.
+	
+    [[json.pl]]
+    [[json_convert.pl]]
+    [[http_json.pl]]
+

packages/http/json_convert.pl

@@ -0,0 +1,548 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(json_convert,
+	  [ prolog_to_json/2,		% :Term, -JSON object
+	    json_to_prolog/2,		% +JSON, :Term
+	    (json_object)/1,		% +Definition
+	    op(1150, fx, (json_object))
+	  ]).
+:- use_module(library(error)).
+:- use_module(json).
+
+:- meta_predicate
+	prolog_to_json(:, -),
+	json_to_prolog(+, :).
+
+/** <module> Convert between JSON terms and Prolog application terms
+
+The idea behind this module is to  provide a flexible high-level mapping
+between Prolog terms as you would like   to see them in your application
+and the standard representation of a JSON   object as a Prolog term. For
+example,  an  X-Y  point  may  be  represented  in  JSON  as  =|{"x":25,
+"y":50}|=. Represented in Prolog this   becomes json([x=25,y=50]), but
+this is a pretty non-natural  representation   from  the Prolog point of
+view.
+
+This module allows for defining records (just like library(record)) that
+provide   transparent   two-way   transformation     between   the   two
+representations.
+
+==
+:- json_object
+	point(x:integer, y:integer).
+==
+
+This declaration causes prolog_to_json/2 to translate the native Prolog
+representation into a JSON Term:
+
+==
+?- prolog_to_json(point(25,50), X).
+
+X = json([x=25, y=50])
+==
+
+A json_object/1 declaration can define multiple   objects separated by a
+comma (,), similar to the dynamic/1 directive. Optionally, a declaration
+can  be  qualified  using   a    module.   The   converstion  predicates
+prolog_to_json/2 and json_to_prolog/2 first try  a conversion associated
+with the calling  module.  If  not   successful,  they  try  conversions
+associated with the module =user=.
+
+JSON objects have no _type_. This can be solved by adding an extra field
+to the JSON object, e.g. =|{"type":"point", "x":25, "y":50}|=. As Prolog
+records are typed by their functor we need some notation to handle this
+gracefully. This is achieved by adding +Fields to the declaration. I.e.
+
+==
+:- json_object
+	point(x:integer, y:integer) + [type=point].
+==
+
+Using this declaration, the conversion becomes:
+
+==
+?- prolog_to_json(point(25,50), X).
+
+X = json([x=25, y=50, type=point])
+==
+
+The predicate json_to_prolog/2 is often  used after http_read_json/2 and
+prolog_to_json/2 before reply_json/1. For now  we consider them seperate
+predicates because the transformation may be   too  general, too slow or
+not needed for dedicated  applications.  Using   a  seperate  step  also
+simplifies debugging this rather complicated process.
+
+@tbd	Ignore extra fields.  Using a partial list of _extra_?
+@tbd	Consider a sensible default for handling JSON =null=.  Conversion
+	to Prolog could translate @null into a variable if the desired type
+	is not =any=.  Conversion to JSON could map variables to =null=,
+	though this may be unsafe.  If the Prolog term is known to be
+	non-ground and JSON @null is a sensible mapping, we can also use
+	this simple snipit to deal with that fact.
+
+	==
+		term_variables(Term, Vars),
+		maplist(=(@null), Vars).
+	==
+*/
+
+%%	current_json_object(Term, Module, Fields)
+%
+%	Multifile   predicate   computed   from     the    json_object/1
+%	declarations.  Term is the most general Prolog term representing
+%	the object.  Module is the module in which the object is defined
+%	and Fields is a list of f(Name, Type, Var), sorted by Name.  Var
+%	is the corresponding variable in Term.
+
+:- multifile
+	json_object_to_pairs/3,		% Term, Module, Pairs
+	current_json_object/3.		% Term, Module, Fields
+
+%%	json_object(+Declaration)
+%
+%	Declare a JSON object.  The declaration takes the same format as
+%	using in record/1 from library(record).  E.g.
+%
+%	==
+%	?- json_object
+%		point(x:int, y:int, z:int=0).
+%	==
+
+json_object(Declaration) :-
+	throw(error(context_error(nodirective, json_object(Declaration)), _)).
+
+
+%%	compile_json_objects(+Spec, -Clauses) is det.
+%
+%	Compiles a :- json_object directive into Clauses. Clauses are of
+%	the form:
+%
+%	==
+%	json_object_to_pairs(Term, Module, Pairs) :-
+%		<type-checks on Term>,
+%		<make Pairs from Term>.
+%	==
+
+compile_json_objects(Spec, Clauses) :-
+	phrase(compile_objects(Spec), Clauses).
+
+compile_objects(A) -->
+	{ var(A), !,
+	  instantiation_error(A)
+	}.
+compile_objects((A,B)) --> !,
+	compile_objects(A),
+	compile_objects(B).
+compile_objects(Term) -->
+	compile_object(Term).
+
+compile_object(ObjectDef) -->
+	{ prolog_load_context(module, CM),
+	  strip_module(CM:ObjectDef, M, Def),
+	  extra_defs(Def, Term, ExtraFields),
+	  Term =.. [Constructor|Args],
+	  defaults(Args, _Defs, TypedArgs),
+	  types(TypedArgs, Names, Types)
+	},
+	record_to_json_clause(Constructor, M, Types, Names, ExtraFields),
+	current_clause(Constructor, M, Types, Names, ExtraFields),
+	[ (:- json_convert:clear_cache) ].
+
+extra_defs(Term+Extra0, Term, Extra) :- !,
+	must_be(list, Extra0),
+	maplist(canonical_pair, Extra0, Extra).
+extra_defs(Term,       Term, []).
+
+
+canonical_pair(Var, _) :-
+	var(Var), !,
+	instantiation_error(Var).
+canonical_pair(Name=Value, Name=Value) :- !,
+	must_be(atom, Name).
+canonical_pair(Name-Value, Name=Value) :- !,
+	must_be(atom, Name).
+canonical_pair(NameValue, Name=Value) :-
+	NameValue =.. [Name,Value], !.
+canonical_pair(Pair, _) :-
+	type_error(pair, Pair).
+
+
+%%	record_to_json_clause(+Constructor, +Module, +Type, +Names)
+%
+%	Create a clause translating the record   definition into a pairs
+%	representation.
+
+record_to_json_clause(Constructor, Module, Types, Names, Extra) -->
+	{ type_checks(Types, VarsHead, VarsBody, Body0, Module),
+	  clean_body(Body0, Body),
+	  Term =.. [Constructor|VarsHead],
+	  make_pairs(Names, VarsBody, Pairs, Extra),
+	  Head =.. [json_object_to_pairs,Term,Module,json(Pairs)]
+	},
+	[ (json_convert:(Head :- Body)) ].
+
+
+%%	type_checks(+Types, -VarsIn, -VarsOut, -Goal, +Module) is det.
+%
+%	Goal is a body-term  that  validates   Vars  satisfy  Types.  In
+%	addition to the types accepted by   must_be/2,  it accepts =any=
+%	and Name/Arity. The latter demands  a   json_object  term of the
+%	given Name and Arity.
+%
+%	@tbd	Compile list(Type) specification.  Currently Type is
+%		handled like =any=
+
+type_checks([], [], [], true, _).
+type_checks([Type|T], [IV|IVars], [OV|OVars], (Goal, Body), M) :- !,
+	type_check(Type, IV, OV, M, Goal),
+	type_checks(T, IVars, OVars, Body, M).
+
+type_check(any, IV, OV, M, prolog_to_json(IV, OV, M)) :- !.
+type_check(Name/Arity, IV, OV, M, prolog_to_json(IV, OV, M)) :- !,
+	functor(IV, Name, Arity).
+type_check(boolean, IV, OV, _, prolog_bool_to_json(IV, OV)) :- !.
+type_check(list, IV, OV, M, prolog_list_to_json(IV, OV, M)) :- !.
+type_check(list(any), IV, OV, M, prolog_list_to_json(IV, OV, M)) :- !.
+type_check(list(_Type), IV, OV, M, prolog_list_to_json(IV, OV, M)) :- !.
+type_check(Type, V, V, _, Goal) :-
+	type_goal(Type, V, Goal).
+
+
+%%	prolog_bool_to_json(+Prolog, -JSON) is semidet.
+%
+%	JSON is the JSON boolean for Prolog. It is a flexible the Prolog
+%	notation for thruth-value, accepting one of  =true=, =on= or =1=
+%	for @true and one of =false=, =fail=, =off= or =0= for @false.
+%
+%	@error	instantiation_error if Prolog is unbound.
+
+prolog_bool_to_json(Var, _) :-
+	var(Var),
+	instantiation_error(Var).
+prolog_bool_to_json(true, @(true)).
+prolog_bool_to_json(false, @(false)).
+prolog_bool_to_json(fail, @(false)).
+prolog_bool_to_json(0, @(false)).
+prolog_bool_to_json(on, @(true)).
+prolog_bool_to_json(off, @(false)).
+prolog_bool_to_json(1, @(false)).
+prolog_bool_to_json(@(True), True) :-
+	prolog_bool_to_json(True, True).
+
+
+%%	type_goal(+Type, +Var, -BodyTerm) is det.
+%
+%	Inline type checking calls.
+
+type_goal(Type, Var, Body) :-
+	clause(error:has_type(Type, Var), Body),
+	primitive(Body), !.
+type_goal(Type, Var, is_of_type(Type, Var)).
+
+primitive((A,B)) :- !,
+	primitive(A),
+	primitive(B).
+primitive((A;B)) :- !,
+	primitive(A),
+	primitive(B).
+primitive((A->B)) :- !,
+	primitive(A),
+	primitive(B).
+primitive(G) :-
+	predicate_property(system:G, built_in).
+
+
+%%	clean_body(+BodyIn, -BodyOut) is det.
+%
+%	Cleanup a body goal. Eliminate   redundant =true= statements and
+%	perform partial evaluation on some  commonly constructs that are
+%	generated from the has_type/2 clauses in library(error).
+
+clean_body(Var, Var) :-
+	var(Var), !.
+clean_body((A0,B0), G) :- !,
+	clean_body(A0, A),
+	clean_body(B0, B),
+	conj(A, B, G).
+clean_body(ground(X), true) :-		% Generated from checking extra fields.
+	ground(X), !.
+clean_body(memberchk(V, Values), true) :- % generated from oneof(List)
+	ground(V), ground(Values),
+	memberchk(V, Values), !.
+clean_body((integer(Low) -> If ; Then), Goal) :- % generated from between(Low,High)
+	number(Low), !,
+	(   integer(Low)
+	->  Goal = If
+	;   Goal = Then
+	).
+clean_body(A, A).
+
+conj(T, A, A) :- T == true, !.
+conj(A, T, A) :- T == true, !.
+conj(A, B, (A,B)).
+
+make_pairs([], [], L, L).
+make_pairs([N|TN], [V|TV], [N=V|T], Tail) :-
+	make_pairs(TN, TV, T, Tail).
+
+%%	current_clause(+Constructor, +Module, +Type, +Names)
+%
+%	Create the clause current_json_object/3.
+
+current_clause(Constructor, Module, Types, Names, Extra) -->
+	{ length(Types, Arity),
+	  functor(Term, Constructor, Arity),
+	  extra_fields(Extra, EF),
+	  Term =.. [_|Vars],
+	  mk_fields(Names, Types, Vars, Fields0, EF),
+	  sort(Fields0, Fields),
+	  Head =.. [current_json_object, Term, Module, Fields]
+	},
+	[ json_convert:Head ].
+
+extra_fields([], []).
+extra_fields([Name=Value|T0], [f(Name, oneof([Value]), Value)|T]) :-
+	extra_fields(T0, T).
+
+mk_fields([], [], [], Fields, Fields).
+mk_fields([Name|TN], [Type|TT], [Var|VT], [f(Name, Type, Var)|T], Tail) :-
+	mk_fields(TN, TT, VT, T, Tail).
+
+
+/* The code below is copied from library(record) */
+
+%%	defaults(+ArgsSpecs, -Defaults, -Args)
+%
+%	Strip the default specification from the argument specification.
+
+defaults([], [], []).
+defaults([Arg=Default|T0], [Default|TD], [Arg|TA]) :- !,
+	defaults(T0, TD, TA).
+defaults([Arg|T0], [_|TD], [Arg|TA]) :-
+	defaults(T0, TD, TA).
+
+
+%%	types(+ArgsSpecs, -Defaults, -Args)
+%
+%	Strip the default specification from the argument specification.
+
+types([], [], []).
+types([Name:Type|T0], [Name|TN], [Type|TT]) :- !,
+	must_be(atom, Name),
+	types(T0, TN, TT).
+types([Name|T0], [Name|TN], [any|TT]) :-
+	must_be(atom, Name),
+	types(T0, TN, TT).
+
+
+		 /*******************************
+		 *       PROLOG --> JSON	*
+		 *******************************/
+
+%%	prolog_to_json(:Term, -JSONObject) is det.
+%
+%	Translate a Prolog application Term  into   a  JSON object term.
+%	This transformation is based on   :- json_object/1 declarations.
+%	If  a  json_object/1  declaration  declares   a  field  of  type
+%	=boolean=, commonly used thruth-values in   Prolog are converted
+%	to JSON booleans. Boolean  translation   accepts  one of =true=,
+%	=on=, =1=, @true, =false=, =fail=, =off= or =0=, @false.
+%
+%	@error	type_error(json_term, X)
+%	@error	instantiation_error
+
+prolog_to_json(Module:Term, JSON) :-
+	prolog_to_json(Term, JSON, Module).
+
+prolog_to_json(Var, _, _) :-
+	var(Var), !,
+	instantiation_error(Var).
+prolog_to_json(Atomic, Atomic, _) :-
+	atomic(Atomic), !.
+prolog_to_json(List, JSON, Module) :-
+	is_list(List), !,
+	prolog_list_to_json(List, JSON, Module).
+prolog_to_json(Record, JSON, Module) :-
+	record_to_pairs(Record, JSON, Module), !.
+prolog_to_json(Term, Term, _) :-
+	is_json_term(Term), !.
+prolog_to_json(Term, _, _) :-
+	type_error(json_term, Term).
+
+record_to_pairs(T, _, _) :-
+	var(T), !,
+	instantiation_error(T).
+record_to_pairs(T, JSON, M) :-
+	object_module(M, Module),
+	json_object_to_pairs(T, Module, JSON), !.
+
+object_module(user, user) :- !.
+object_module(M, M).
+object_module(_, user).
+
+prolog_list_to_json([], [], _).
+prolog_list_to_json([H0|T0], [H|T], M) :-
+	prolog_to_json(H0, H, M),
+	prolog_list_to_json(T0, T, M).
+
+
+		 /*******************************
+		 *       JSON --> PROLOG	*
+		 *******************************/
+
+:- dynamic
+	json_to_prolog_rule/3,		% Module, Pairs, Term
+	created_rules_for_pairs/2.	% Module, Pairs
+
+clear_cache :-
+	retractall(json_to_prolog_rule(_,_,_)),
+	retractall(created_rules_for_pairs(_,_)).
+
+:- clear_cache.
+
+%%	json_to_prolog(+JSON, -Term) is det.
+%
+%	Translate  a  JSON  term   into    an   application  term.  This
+%	transformation is based on  :-   json_object/1  declarations. An
+%	efficient transformation is non-trivial,  but   we  rely  on the
+%	assumption that, although the order of   fields in JSON terms is
+%	irrelevant and can therefore vary  a lot, practical applications
+%	will normally generate the JSON objects in a consistent order.
+%
+%	If a field in a json_object is declared of type =boolean=, @true
+%	and @false are  translated  to  =true=   or  =false=,  the  most
+%	commonly used Prolog representation for truth-values.
+
+json_to_prolog(JSON, Module:Term) :-
+	json_to_prolog(JSON, Term, Module).
+
+json_to_prolog(json(Pairs), Term, Module) :- !,
+	(   pairs_to_term(Pairs, Term, Module)
+	->  true
+	;   json_pairs_to_prolog(Pairs, Prolog, Module),
+	    Term = json(Prolog)
+	).
+json_to_prolog(List, Prolog, Module) :-
+	is_list(List), !,
+	json_list_to_prolog(List, Prolog, Module).
+json_to_prolog(@(Special), @(Special), _).
+json_to_prolog(Atomic, Atomic, _).
+
+json_pairs_to_prolog([], [], _).
+json_pairs_to_prolog([Name=JSONValue|T0], [Name=PrologValue|T], Module) :-
+	json_to_prolog(JSONValue, PrologValue, Module),
+	json_pairs_to_prolog(T0, T, Module).
+
+json_list_to_prolog([], [], _).
+json_list_to_prolog([JSONValue|T0], [PrologValue|T], Module) :-
+	json_to_prolog(JSONValue, PrologValue, Module),
+	json_list_to_prolog(T0, T, Module).
+
+
+%%	json_object_to_prolog(+JSONObject, ?Term, +Module) is semidet.
+%
+%	Translate a JSON json(Pairs) term into a Prolog application term.
+
+json_object_to_prolog(json(Pairs), Term, Module) :-
+	pairs_to_term(Pairs, Term, Module).
+
+
+%%	pairs_to_term(+Pairs, ?Term, +Module) is semidet.
+%
+%	Convert a Name=Value set into a Prolog application term based on
+%	json_object/1 declarations.
+%
+%	@tbd	Ignore extra pairs if term is partially given?
+
+pairs_to_term(Pairs, Term, Module) :-
+	object_module(Module, M),
+	(   json_to_prolog_rule(M, Pairs, Term)
+	->  !
+	;   created_rules_for_pairs(M, Pairs)
+	->  !, fail
+	;   pairs_args(Pairs, PairArgs),
+	    sort(PairArgs, SortedPairArgs),
+	    forall(create_rule(SortedPairArgs, Module, M, Term0, Body),
+		   asserta((json_to_prolog_rule(M, PairArgs, Term0) :- Body))),
+	    asserta(created_rules_for_pairs(M, PairArgs)),
+	    json_to_prolog_rule(M, Pairs, Term), !
+	).
+
+pairs_args([], []).
+pairs_args([Name=_Value|T0], [Name=_|T]) :-
+	pairs_args(T0, T).
+
+%%	create_rule(+PairArgs, +Vars, -Term, -Body) is det.
+%
+%	Create a new rule for dealing with Pairs, a Name=Value list of a
+%	particular order.  Here is an example rule:
+%
+%	==
+%	json_to_prolog_rule([x=X, y=Y], point(X,Y)) :-
+%		integer(X),
+%		integer(Y).
+%	==
+
+create_rule(PairArgs, Module, M, Term, Body) :-
+	current_json_object(Term, M, Fields),
+	match_fields(PairArgs, Fields, Body0, Module),
+	clean_body(Body0, Body).
+
+match_fields([], [], true, _).
+match_fields([Name=JSON|TP], [f(Name, Type, Prolog)|TF], (Goal,Body), M) :- !,
+	match_field(Type, JSON, Prolog, M, Goal),
+	match_fields(TP, TF, Body, M).
+
+match_field(any, JSON, Prolog, M, json_to_prolog(JSON,Prolog,M)) :- !.
+match_field(F/A, JSON, Prolog, M, json_to_prolog(JSON,Prolog,M)) :- !,
+	functor(Prolog, F, A).
+match_field(boolean, JSON, Prolog, _, json_bool_to_prolog(JSON, Prolog)) :- !.
+match_field(list(Type), JSON, Prolog, M, json_list_to_prolog(JSON, Prolog, M)) :-
+	current_json_object(Term, M, _Fields),
+	functor(Term, Type, _), !.
+match_field(Type, Var, Var, _, Goal) :-
+	type_goal(Type, Var, Goal).
+
+json_bool_to_prolog(@(True), True).
+
+
+		 /*******************************
+		 *	      EXPANSION		*
+		 *******************************/
+
+:- multifile
+	system:term_expansion/2.
+:- dynamic
+	system:term_expansion/2.
+
+system:term_expansion((:- json_object(Spec)), Clauses) :-
+	compile_json_objects(Spec, Clauses).

packages/http/mimepack.pl

@@ -0,0 +1,146 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(mime_pack,
+	  [ mime_pack/3			% +Input, +Stream, ?Boundary
+	  ]).
+:- use_module(mimetype).
+:- use_module(html_write).
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Simple and partial implementation of MIME   encoding. MIME is covered by
+RFC 2045 which I've read from
+
+	http://www.cis.ohio-state.edu/cgi-bin/rfc/rfc2045.html
+
+MIME decoding is now  arranged  through   library(mime)  from  the  clib
+package, based on the  external  librfc2045   library.  Most  likely the
+functionality of this package will be moved to the same library someday.
+Packing however is a lot simpler then parsing.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+%%	mime_pack(+Inputs, +Out:stream, ?Boundary) is det.
+%
+%	Pack a number of inputs into a MIME package using a specified or
+%	generated boundary. The  generated  boundary   consists  of  the
+%	current  time  in  seconds  since  the    epoch  and  10  random
+%	hexadecimal numbers.
+%
+%	@bug	Does not validate that the boundary is unique.
+
+mime_pack(Inputs, OutputStream, Boundary) :-
+	make_boundary(Inputs, Boundary),
+	pack_list(Inputs, OutputStream, Boundary).
+
+pack_list([], Out, Boundary) :-
+	format(Out, '--~w--\r\n', [Boundary]).
+pack_list([H|T], Out, Boundary) :-
+	format(Out, '--~w\r\n', [Boundary]),
+	pack(H, Out),
+	format(Out, '\r\n', []),
+	pack_list(T, Out, Boundary).
+
+pack(X, _Out) :-
+	var(X), !,
+	throw(error(instantiation_error, _)).
+pack(Name=Value, Out) :- !,
+	(   Value = file(FileName)
+	->  format(Out, 'Content-Disposition: form-data; name="~w"; filename="~w"\r\n',
+		   [Name, FileName])
+	;   format(Out, 'Content-Disposition: form-data; name="~w"\r\n', [Name])
+	),
+	pack(Value, Out).
+pack(html(HTML), Out) :-
+	format(Out, 'Content-Type: text/html\r\n\r\n', []),
+	print_html(Out, HTML).
+pack(file(File), Out) :- !,
+	(   file_mime_type(File, Type)
+	->  true
+	;   Type = text/plain
+	),
+	format(Out, 'Content-Type: ~w\r\n\r\n', [Type]),
+	(   Type = text/_
+	->  OpenOptions = []
+	;   OpenOptions = [type(binary)]
+	),
+	open(File, read, In, OpenOptions),
+	copy_stream_data(In, Out),
+	close(In).
+pack(stream(In, Len), Out) :- !,
+	copy_stream_data(In, Out, Len).
+pack(stream(In), Out) :- !,
+	copy_stream_data(In, Out).
+pack(mime(Atts, Data, []), Out) :- !,		% mime_parse compatibility
+	write_mime_attributes(Atts, Out),
+	write(Out, Data).
+pack(mime(_Atts, '', Parts), Out) :-
+	make_boundary(Parts, Boundary),
+	format('Content-type: multipart/mixed; boundary=~w\r\n\r\n',
+	       [Boundary]),
+	mime_pack(Parts, Out, Boundary).
+pack(Atom, Out) :-
+	atomic(Atom), !,
+	format(Out, '\r\n', []),
+	write(Out, Atom).
+pack(Value, _) :-
+	throw(error(type_error(mime_part, Value), _)).
+
+write_mime_attributes([], Out) :- !,
+	format(Out, '\r\n', []).
+write_mime_attributes(Atts, Out) :-
+	select(type(Type), Atts, A1), !,
+	(   select(character_set(CharSet), A1, A2)
+	->  format(Out, 'Content-type: ~w; charset=~w\r\n', [Type, CharSet]),
+	    write_mime_attributes(A2, Out)
+	;   format(Out, 'Content-type: ~w\r\n', [Type]),
+	    write_mime_attributes(A1, Out)
+	).
+write_mime_attributes([_|T], Out) :-
+	write_mime_attributes(T, Out).
+
+
+%%	make_boundary(+Inputs, ?Boundary) is det.
+%
+%	Generate a boundary.  This should check all input sources whether
+%	the boundary is enclosed.
+
+make_boundary(_, Boundary) :-
+	atomic(Boundary), !.
+make_boundary(_, Boundary) :-
+	get_time(Now),
+	A is random(1<<16),
+	B is random(1<<16),
+	C is random(1<<16),
+	D is random(1<<16),
+	E is random(1<<16),
+	sformat(Boundary, '------~0f~16r~16r~16r~16r~16r',
+		[Now, A, B, C, D, E]).
+

packages/http/mimetype.pl

@@ -0,0 +1,111 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2009, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(mimetype,
+	  [ file_mime_type/2		% +Path, -Type
+	  ]).
+
+%%	file_mime_type(+FileName, -MimeType) is semidet.
+%
+%	Simple library to guess the mime-type   from  the extension of a
+%	file.  As  various  applications  need  to    do  this  type  of
+%	inferencing it seems worthwhile to   place this functionality in
+%	an extensible library.
+%
+%	Please add clauses to mime:mime_extension/2 to add your own types.
+
+file_mime_type(File, MimeType) :-
+	file_name_extension(_, Ext, File),
+	(   current_prolog_flag(windows, true)
+	->  downcase_atom(Ext, Lower),
+	    mime_extension(Lower, MimeType)
+	;   mime_extension(Ext, M0)
+	->  MimeType = M0
+	;   downcase_atom(Ext, Lower),
+	    mime_extension(Lower, MimeType)
+	).
+
+:- multifile
+	mime:mime_extension/2.
+
+mime_extension(Ext, Mime) :-
+	mime:mime_extension(Ext, Mime), !.
+					% plain text
+mime_extension(txt,  text/plain).
+					% markup
+mime_extension(htm,  text/html).
+mime_extension(html, text/html).
+mime_extension(xhtml, application/'xhtml+xml').
+mime_extension(sgml, text/'x-sgml').
+mime_extension(sgm,  text/'x-sgml').
+mime_extension(xml,  text/xml).
+mime_extension(css,  text/css).
+					% semantic web stuff
+mime_extension(rdf,  application/'rdf+xml').
+mime_extension(rdfs, application/'rdf+xml').
+mime_extension(owl,  application/'rdf+xml').
+					% Prolog source
+mime_extension(pl,   text/plain).
+					% Packaged formats
+mime_extension(gz,   application/'x-gzip').
+mime_extension(zip,  application/zip).
+mime_extension(tgz,  application/'x-gtar').
+					% Some document formats
+mime_extension(pdf,  application/pdf).
+mime_extension(doc,  application/msword).
+					% Java classes
+mime_extension(class, application/'octet-stream').
+mime_extension(jar,  application/'java-archive').
+mime_extension(js,   text/javascript).
+					% Visual Basic Script :-(
+mime_extension(vbs,  text/vbscript).
+					% Some image formats
+mime_extension(jpg,  image/jpeg).
+mime_extension(jpeg, image/jpeg).
+mime_extension(gif,  image/gif).
+mime_extension(png,  image/png).
+mime_extension(tif,  image/tiff).
+mime_extension(tiff, image/tiff).
+mime_extension(xpm,  image/'x-xpixmap').
+mime_extension(ico,  image/'x-ico').
+mime_extension(svg,  image/'svg+xml').
+					% Google earth
+mime_extension(kml,  application/'vnd.google-earth.kml+xml').
+mime_extension(kmz,  application/'vnd.google-earth.kmz').
+
+					% Flash
+mime_extension(swf,  application/'x-shockwave-flash').
+mime_extension(flv,  video/'x-flv').
+					% MP3
+mime_extension(mp3,  audio/mpeg).
+					% Downloads
+mime_extension(rpm,  application/'x-rpm').
+mime_extension(exe,  application/'x-executable').

packages/http/pltotex.pl

@@ -0,0 +1,60 @@
+:- module(pltotex,
+	  [ pltotex/2,
+	    pltotex/0
+	  ]).
+:- use_module(library(doc_latex)).
+:- use_module(library(main)).
+:- use_module(library(error)).
+:- use_module(library(apply)).
+:- use_module(library(lists)).
+
+pltotex(Lib, Options) :-
+	(   file_name_extension(_, pl, Lib)
+	->  Spec = Lib
+	;   atom_to_term(Lib, Spec, _)
+	),
+	absolute_file_name(Spec, File,
+			   [ access(read),
+			     file_type(prolog)
+			   ]),
+	tex_file(File, Out),
+	user:use_module(File),		% we want the operators in user
+	doc_latex(File, Out,
+		  [ stand_alone(false)
+		  | Options
+		  ]).
+
+tex_file(File, TeXFile) :-
+	file_base_name(File, Local),
+	file_name_extension(Base0, _, Local),
+	strip(Base0, 0'_, Base),
+	file_name_extension(Base, tex, TeXFile).
+
+strip(In, Code, Out) :-
+	atom_codes(In, Codes0),
+	delete(Codes0, Code, Codes),
+	atom_codes(Out, Codes).
+
+
+%%	pltotex
+%
+%	Usage: pl -q -s pltotex.pl -g pltotex -- file ...
+
+pltotex :-
+	main.
+
+main(Argv) :-
+	partition(is_option, Argv, OptArgs, Files),
+	maplist(to_option, OptArgs, Options),
+	maplist(process_file(Options), Files).
+
+is_option(Arg) :-
+	sub_atom(Arg, 0, _, _, --).
+
+to_option('--section', section_level(section)).
+to_option('--subsection', section_level(subsection)).
+to_option('--subsubsection', section_level(subsubsection)).
+
+process_file(Options, File) :-
+	pltotex(File, Options).
+

packages/http/post.txt

@@ -0,0 +1,30 @@
+---+++ Repositioning HTML for CSS and javascript links
+
+Modern HTML commonly uses  CSS  and   Javascript.  This  requires <link>
+elements in the HTML <head> element or  <script> elements in the <body>.
+Unfortunately this seriously harms re-using HTML DCG rules as components
+as each of these components  may  rely   on  their  own  style sheets or
+JavaScript code. We added a `mailing'   system to reposition and collect
+fragments of HTML. This is  implemented by html_post//2, html_receive//1
+and html_receive//2.
+
+	* [[html_post//2]]
+	* [[html_receive//1]]
+	* [[html_receive//2]]
+
+The library predefines the receiver channel  =head=   at  the end of the
+=head= element for all pages that  write   the  html =head= through this
+library. The following  code  can  be   used  anywhere  inside  an  HTML
+generating rule to demand a javascript in the header:
+
+==
+js_script(URL) -->
+	html_post(head, script([ src(URL),
+				 type('text/javascript')
+			       ], [])).
+==
+
+This  mechanism  is  also  exploited  to  add  XML  namespace  (=xmlns=)
+declarations to the (outer) =html= element using xhml_ns//2:
+
+	* [[xhtml_ns//2]]

packages/http/stream_range.c

@@ -0,0 +1,221 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2007, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*/
+
+#include <SWI-Stream.h>
+#include <SWI-Prolog.h>
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <time.h>
+#include <errno.h>
+
+static atom_t ATOM_size;		/* size(Int) */
+
+		 /*******************************
+		 *	       TYPES		*
+		 *******************************/
+
+#define BUFSIZE SIO_BUFSIZE		/* raw I/O buffer */
+
+typedef struct range_context
+{ IOSTREAM	   *stream;		/* Original stream */
+  IOSTREAM	   *range_stream;	/* Stream I'm handle of */
+  IOENC		    parent_encoding;	/* Saved encoding of parent */
+  size_t	    read;		/* data already read */
+  size_t	    size;		/* #bytes of data available */
+} range_context;
+
+
+static range_context*
+alloc_range_context(IOSTREAM *s)
+{ range_context *ctx = PL_malloc(sizeof(*ctx));
+
+  memset(ctx, 0, sizeof(*ctx));
+  ctx->stream       = s;
+
+  return ctx;
+}
+
+
+static void
+free_range_context(range_context *ctx)
+{ if ( ctx->stream->upstream )
+    Sset_filter(ctx->stream, NULL);
+  else
+    PL_release_stream(ctx->stream);
+
+  PL_free(ctx);
+}
+
+
+		 /*******************************
+		 *	RANGE LIMITED INPUT	*
+		 *******************************/
+
+static ssize_t				/* range-limited read */
+range_read(void *handle, char *buf, size_t size)
+{ range_context *ctx = handle;
+  size_t max_rd;
+  ssize_t rd;
+
+  if ( ctx->read == ctx->size )
+    return 0;
+
+  if ( ctx->size - ctx->read < size )
+    max_rd = ctx->size - ctx->read;
+  else
+    max_rd = size;
+
+  if ( (rd = Sfread(buf, sizeof(char), max_rd, ctx->stream)) >= 0 )
+  { ctx->read += rd;
+
+    return rd;
+  }
+
+  return rd;
+}
+
+
+static ssize_t				/* no writing! */
+range_write(void *handle, char *buf, size_t size)
+{ return -1;
+}
+
+
+static int
+range_control(void *handle, int op, void *data)
+{ range_context *ctx = handle;
+
+  switch(op)
+  { case SIO_FLUSHOUTPUT:
+    case SIO_SETENCODING:
+      return 0;				/* allow switching encoding */
+    case SIO_GETSIZE:
+    { size_t *rval = data;
+      *rval = ctx->size;
+      return 0;
+    }
+    default:
+      if ( ctx->stream->functions->control )
+	return (*ctx->stream->functions->control)(ctx->stream->handle, op, data);
+      return -1;
+  }
+}
+
+
+static int
+range_close(void *handle)
+{ range_context *ctx = handle;
+
+  ctx->stream->encoding = ctx->parent_encoding;
+  free_range_context(ctx);
+
+  return 0;
+}
+
+
+static IOFUNCTIONS range_functions =
+{ range_read,
+  range_write,
+  NULL,					/* seek */
+  range_close,
+  range_control,			/* zcontrol */
+  NULL,					/* seek64 */
+};
+
+
+		 /*******************************
+		 *	 PROLOG CONNECTION	*
+		 *******************************/
+
+#define COPY_FLAGS (SIO_INPUT|SIO_OUTPUT| \
+		    SIO_TEXT| \
+		    SIO_REPXML|SIO_REPPL|\
+		    SIO_RECORDPOS)
+
+static foreign_t
+pl_stream_range_open(term_t org, term_t new, term_t options)
+{ term_t tail = PL_copy_term_ref(options);
+  term_t head = PL_new_term_ref();
+  range_context *ctx;
+  IOSTREAM *s, *s2;
+  int size = 0;
+
+  while(PL_get_list(tail, head, tail))
+  { atom_t name;
+    int arity;
+    term_t arg = PL_new_term_ref();
+
+    if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
+      return type_error(head, "option");
+    _PL_get_arg(1, head, arg);
+
+    if ( name == ATOM_size )
+    { if ( !get_int_ex(arg, &size) )
+	return FALSE;
+      if ( size <= 0 )
+	return domain_error(arg, "nonneg");
+    }
+  }
+  if ( !PL_get_nil(tail) )
+    return type_error(tail, "list");
+
+  if ( !PL_get_stream_handle(org, &s) )
+    return FALSE;			/* Error */
+  ctx = alloc_range_context(s);
+  ctx->size = size;
+
+  if ( !(s2 = Snew(ctx,
+		   (s->flags&COPY_FLAGS)|SIO_FBUF,
+		   &range_functions))	)
+  { free_range_context(ctx);			/* no memory */
+
+    return FALSE;
+  }
+
+  s2->encoding = s->encoding;
+  ctx->parent_encoding = s->encoding;
+  s->encoding = ENC_OCTET;
+  ctx->range_stream = s2;
+  if ( PL_unify_stream(new, s2) )
+  { Sset_filter(s, s2);
+    PL_release_stream(s);
+
+    return TRUE;
+  } else
+  { return instantiation_error();
+  }
+}
+
+
+		 /*******************************
+		 *	       INSTALL		*
+		 *******************************/
+
+static void
+install_stream_range()
+{  ATOM_size = PL_new_atom("size");
+
+  PL_register_foreign("stream_range_open",  3, pl_stream_range_open,  0);
+}

packages/http/test_cgi_stream.pl

@@ -0,0 +1,329 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2008, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(test_cgi_stream,
+	  [ test_cgi_stream/0
+	    , t/0, d/0, nd/0		% Handy things
+	  ]).
+
+:- use_module(library(plunit)).
+:- use_module(library(debug)).
+:- use_module(library(http/http_stream)).
+:- use_module(library(http/http_header)).
+:- use_module(library(http/http_client)).
+
+:- expects_dialect(swi).
+:- assert(system:swi_io).
+
+
+/** <module> Test CGI stream object
+
+This module defines a series of tests   outside  the context of the HTTP
+server to validate correct  processing  of   the  CGI  header,  handling
+different  encodings  and  transfer    encodings  (chunked/traditional).
+Instead of using real sockets, we use temporary storage on a file.
+
+@tbd	Validate error processing
+*/
+
+t :-
+	test_cgi_stream.
+
+d :-
+	http_stream:http_stream_debug(1),
+	debug(http(hook)),
+	debug(http(header)).
+nd :-
+	http_stream:http_stream_debug(0),
+	nodebug(http(hook)),
+	nodebug(http(header)).
+
+test_cgi_stream :-
+	run_tests([ cgi_stream,
+		    cgi_chunked,
+		    cgi_errors
+		  ]).
+
+		 /*******************************
+		 *	    DESTINATION		*
+		 *******************************/
+
+open_dest(TmpF, Out) :-
+	tmp_file(http, TmpF),
+	open(TmpF, write, Out, [type(binary)]).
+
+free_dest(TmpF) :-
+	delete_file(TmpF).
+
+free_dest(TmpF, Out) :-
+	close(Out),
+	delete_file(TmpF).
+
+http_read_mf(TmpF, Header, Data) :-
+	open(TmpF, read, In, [type(binary)]),
+	http_read_reply_header(In, Header),
+	http_read_data(Header, Data, to(atom)),
+	close(In).
+
+
+cat(TmpF) :-
+	open(TmpF, read, In),
+	call_cleanup(copy_stream_data(In, current_output),
+		     close(In)).
+
+
+		 /*******************************
+		 *	      MAKE DATA		*
+		 *******************************/
+
+%%	data_atom(+Length, +Min, +Max, -Atom) is det.
+%
+%	Create an atom of Length codes.  It contains repeating sequences
+%	Min..Max.
+
+data_atom(Length, Min, Max, Atom) :-
+	data_list(Length, Min, Max, List),
+	atom_codes(Atom, List).
+
+data_list(Length, Min, Max, List) :-
+	Span is Max - Min,
+	data_list(Length, Min, 0, Span, List).
+
+data_list(Len, Min, I, Span, [H|T]) :-
+	Len > 0, !,
+	H is Min + I mod Span,
+	Len2 is Len - 1,
+	I2 is I+1,
+	data_list(Len2, Min, I2, Span, T).
+data_list(_, _, _, _, []).
+
+%%	data(+Name, -Data, -ContentType) is det.
+%
+%	Create data-sets to be used with the PlUnit forall option.
+
+data(short_ascii, Data, 'text/plain') :-
+	data_atom(10, 97, 128, Data).
+data(ascii, Data, 'text/plain') :-
+	data_atom(126, 1, 128, Data).
+data(unicode, Data, 'text/plain') :-
+	data_atom(10, 1000, 1010, Data).
+data(long_unicode, Data, 'text/plain') :-
+	data_atom(10000, 1, 1000, Data).
+data(long_binary, Data, 'text/plain') :-
+	data_atom(10000, 0, 255, Data).
+
+%%	current_data(-Name) is nondet.
+%
+%	Enumerate available datasets.
+
+current_data(Name) :-
+	clause(data(Name, _, _), _).
+
+
+		 /*******************************
+		 *	       TEST		*
+		 *******************************/
+
+assert_header(Header, Field) :-
+	memberchk(Field, Header), !.
+assert_header(_Header, Field) :-
+	format(user_error, 'ERROR: ~p expected in header~n', [Field]),
+	fail.
+
+
+		 /*******************************
+		 *	      HOOK		*
+		 *******************************/
+
+cgi_hook(What, _CGI) :-
+	debug(http(hook), 'Running hook: ~q', [What]),
+	fail.
+cgi_hook(header, CGI) :-
+	cgi_property(CGI, header_codes(HeadText)),
+	http_parse_header(HeadText, CgiHeader),
+	cgi_property(CGI, request(Request)),
+	http_update_connection(CgiHeader, Request, Connection, Header1),
+	http_update_transfer(Request, Header1, Transfer, Header2),
+	http_update_encoding(Header2, Encoding, Header),
+	set_stream(CGI, encoding(Encoding)),
+	cgi_set(CGI, connection(Connection)),
+	cgi_set(CGI, header(Header)),
+	cgi_set(CGI, transfer_encoding(Transfer)). % must be LAST
+cgi_hook(send_header, CGI) :-
+	cgi_property(CGI, header(Header)),
+	cgi_property(CGI, client(Out)),
+	(   cgi_property(CGI, transfer_encoding(chunked))
+	->  phrase(http_header:reply_header(chunked_data, Header, _), String)
+	;   cgi_property(CGI, content_length(Len))
+	->  phrase(http_header:reply_header(cgi_data(Len), Header, _), String)
+	),
+	format(Out, '~s', [String]).
+cgi_hook(close, _).
+
+
+:- begin_tests(cgi_stream, [sto(rational_trees)]).
+
+test(traditional,
+     [ forall(current_data(Name)),
+       Reply == Data,
+       setup(open_dest(TmpF, Out)),
+       cleanup(free_dest(TmpF))
+     ]) :-
+	data(Name, Data, ContentType),
+	cgi_open(Out, CGI, cgi_hook, []),
+	start_low_level_trace,
+	format(CGI, 'Content-type: ~w\n\n', [ContentType]),
+	format(CGI, '~w', [Data]),
+	close(CGI),
+	close(Out),
+	http_read_mf(TmpF, Header, Reply),
+	assert_header(Header, status(ok, _)).
+
+test(unicode,
+     [ forall(Name=unicode),
+       Reply == Data,
+       setup(open_dest(TmpF, Out)),
+       cleanup(free_dest(TmpF))
+     ]) :-
+	data(Name, Data, ContentType),
+	cgi_open(Out, CGI, cgi_hook, []),
+	format(CGI, 'Content-type: ~w\n\n', [ContentType]),
+	format(CGI, '~w', [Data]),
+	close(CGI),
+	close(Out),
+	http_read_mf(TmpF, Header, Reply),
+	assert_header(Header, status(ok, _)).
+
+:- end_tests(cgi_stream).
+
+:- begin_tests(cgi_chunked, [sto(rational_trees)]).
+
+test(chunked,
+     [ forall(current_data(Name)),
+       Reply == Data,
+       setup(open_dest(TmpF, Out)),
+       cleanup(free_dest(TmpF))
+     ]) :-
+	data(Name, Data, ContentType),
+	cgi_open(Out, CGI, cgi_hook,
+ 		 [ request([http_version(1-1)])
+		 ]),
+	format(CGI, 'Transfer-encoding: chunked\n', []),
+	format(CGI, 'Content-type: ~w\n\n', [ContentType]),
+	format(CGI, '~w', [Data]),
+	close(CGI),
+	close(Out),
+	http_read_mf(TmpF, Header, Reply),
+	assert_header(Header, status(ok, _)),
+	assert_header(Header, transfer_encoding(chunked)).
+
+:- end_tests(cgi_chunked).
+
+
+		 /*******************************
+		 *	   ERROR HANDLING	*
+		 *******************************/
+
+%%	collect_messages(:Goal, -Messages) is semidet.
+%
+%	Run Goal as once/1, collecting possible messages in Messages.
+
+:- meta_predicate
+	collect_messages(0, -, -).
+
+collect_messages(Goal, True, Messages) :-
+	strip_module(Goal, M, G),
+	collect_messages2(M:G, True, Messages).
+
+:- multifile
+	user:message_hook/3.
+:- dynamic
+	msg_collecting/0,
+	msg/2.
+
+user:message_hook(Term, Kind, _Lines) :-
+	msg_collecting, !,
+	assert(msg(Term, Kind)).
+
+collect_messages2(Goal, True, Messages) :-
+	assert(msg_collecting, Ref),
+	call_cleanup(call_result(Goal, True),
+		     (	 erase(Ref),
+			 findall(message(Term, Kind), retract(msg(Term, Kind)),
+				 Messages))).
+
+call_result(Goal, true) :-
+	Goal, !.
+call_result(_, false).
+
+
+:- begin_tests(cgi_errors, [sto(rational_trees)]).
+
+cgi_fail_hook(Event, _) :-
+	debug(http(hook), 'Failing hook for ~w', [Event]),
+	fail.
+
+cgi_error_hook(Event, _) :-
+	debug(http(hook), 'Error hook for ~w', [Event]),
+	throw(error(demo_error, _)).
+
+test(hook_failed,
+      [ setup(open_dest(TmpF, Out)),
+        cleanup(free_dest(TmpF, Out)),
+	error(io_error(_,_))
+      ]) :-
+ 	cgi_open(Out, CGI, cgi_fail_hook, []),
+ 	close(CGI).
+
+test(hook_error,
+     [ setup(open_dest(TmpF, Out)),
+       cleanup(free_dest(TmpF, Out)),
+       error(demo_error)
+     ]) :-
+	cgi_open(Out, CGI, cgi_error_hook, []),
+	close(CGI).
+
+:- end_tests(cgi_errors).
+
+
+		 /*******************************
+		 *	       PORTRAY		*
+		 *******************************/
+
+user:portray(Atom) :-
+	atom(Atom),
+	atom_length(Atom, Len),
+	Len > 100, !,
+	sub_atom(Atom, 0, 35, _, Start),
+	sub_atom(Atom, _, 35, 0, End),
+	format('~q...[~D codes]...~q', [Start, Len, End]).
+
+:- retract(system:swi_io).

packages/http/test_http.pl

@@ -0,0 +1,82 @@
+:- module(test_http,
+	  [ test_http/0
+	  ]).
+:- asserta(user:file_search_path(foreign, '.')).
+:- asserta(user:file_search_path(foreign, '../clib')).
+:- asserta(user:file_search_path(foreign, '../sgml')).
+:- asserta(user:file_search_path(library, '..')).
+:- asserta(user:file_search_path(library, '../sgml')).
+:- asserta(user:file_search_path(library, '../plunit')).
+:- asserta(user:file_search_path(library, '../clib')).
+
+:- use_module(library(http/http_open)).
+:- use_module(library(http/http_client)).
+:- use_module(library(http/http_stream)).
+:- use_module(library(plunit)).
+:- use_module(library(readutil)).
+:- use_module(library(socket)).
+:- use_module(library(debug)).
+:- use_module(library(lists)).
+
+test_http :-
+	run_tests([ http_open,
+		    http_get
+		  ]).
+
+
+:- begin_tests(http_open).
+
+test(gollem, true) :-
+     http_open('http://gollem.science.uva.nl/', In, []),
+     read_stream_to_codes(In, Codes),
+     close(In),
+     appendchk(_, "http://www.swi-prolog.org/", _, Codes).
+test(gollem_redirect, true) :-
+     http_open('http://gollem.science.uva.nl', In, []),
+     read_stream_to_codes(In, Codes),
+     close(In),
+     appendchk(_, "http://www.swi-prolog.org/", _, Codes).
+test(gollem_chunked, true(Codes == Ref)) :-
+     http_open('http://gollem.science.uva.nl/cgi-bin/chunked', In, []),
+     read_stream_to_codes(In, Codes),
+     close(In),
+     chunked_data(Ref).
+
+:- end_tests(http_open).
+
+:- begin_tests(http_get).
+
+test(gollem, true) :-
+     http_get('http://gollem.science.uva.nl/', Data, [to(codes)]),
+     appendchk(_, "http://www.swi-prolog.org/", _, Data).
+
+test(gollem_chunked, true(Data == Ref)) :-
+     http_get('http://gollem.science.uva.nl/cgi-bin/chunked',
+	      Data, [to(codes)]),
+     chunked_data(Ref).
+
+:- end_tests(http_get).
+
+		 /*******************************
+		 *	       UTIL		*
+		 *******************************/
+
+read_file_to_codes(File, Codes) :-
+	open(File, read, In),
+	call_cleanup(read_stream_to_codes(In, Codes), close(In)).
+
+appendchk(Pre, Middle, Post, List) :-
+	append(Pre, Rest, List),
+	append(Middle, Post, Rest), !.
+
+%%	chunked_data(-String) is det.
+%
+%	Content of the chunked data that is sent by cgi-bin/chunked.
+
+chunked_data(S) :-
+	findall(C,
+		(   between(1, 1000, X),
+		    C is "a" + X mod 26
+		), S).
+
+

packages/http/test_json.pl

@@ -0,0 +1,186 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    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
+    of the License, 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 library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(test_json,
+	  [ test_json/0
+	  ]).
+:- asserta(user:file_search_path(foreign, '.')).
+:- asserta(user:file_search_path(foreign, '../clib')).
+:- asserta(user:file_search_path(foreign, '../sgml')).
+:- asserta(user:file_search_path(library, '../plunit')).
+:- asserta(user:file_search_path(library, '../clib')).
+:- asserta(user:file_search_path(library, '../sgml')).
+
+:- use_module(library(plunit)).
+:- use_module(json).
+
+test_json :-
+	run_tests([ json_read,
+		    json_convert,
+		    json_http
+		  ]).
+
+:- begin_tests(json_read).
+
+test(true, X == @(true)) :-
+	atom_json_term(true, X, []).
+test(true, X == true) :-
+	atom_json_term(true, X, [true(true)]).
+
+test(string, X == hello) :-
+	atom_json_term('"hello"', X, []).
+test(string, X == '\\\b\f\n\r\t') :-
+	atom_json_term('"\\\\\\b\\f\\n\\r\\t"', X, []).
+test(string, X == '\u1234') :-
+	atom_json_term('"\\u1234"', X, []).
+
+test(int, X == 42) :-
+	atom_json_term('42', X, []).
+test(int, X == -42) :-
+	atom_json_term('-42', X, []).
+
+test(float, X == 3.14) :-
+	atom_json_term('3.14', X, []).
+test(float, X == -3.14) :-
+	atom_json_term('-3.14', X, []).
+test(float, X == 1000.0) :-
+	atom_json_term('1e3', X, []).
+test(float, X == 0.001) :-
+	atom_json_term('1e-3', X, []).
+
+test(empty, X == json([])) :-
+	atom_json_term({}, X, []).
+test(empty, X == json([])) :-
+	atom_json_term('  {  } ', X, []).
+test(empty, X == json([])) :-
+	atom_json_term('  {\n//comment\n} ', X, []).
+
+
+:- end_tests(json_read).
+
+
+		 /*******************************
+		 *	      CONVERT		*
+		 *******************************/
+
+:- begin_tests(json_convert).
+
+:- use_module(json_convert).
+
+:- json_object
+	point(x:integer, y:integer),
+	tpoint(x:integer, y:integer)+[type=point],
+	fpoint(x:float, y:float).
+
+test(pt2json, JSON == json([x=25,y=50])) :-
+	prolog_to_json(point(25,50), JSON).
+test(pt2json, JSON == json([x=25,y=50,type=point])) :-
+	prolog_to_json(tpoint(25,50), JSON).
+
+test(json2pt, X == point(25,50)) :-
+	json_to_prolog(json([x=25,y=50]), X).
+test(json2pt, X == point(25,50)) :-
+	json_to_prolog(json([y=50,x=25]), X).
+test(json2pt, X == fpoint(25.1,50.0)) :-
+	json_to_prolog(json([y=50.0,x=25.1]), X).
+test(json2pt, T == T2) :-
+	T = json([y=50,x=25.1]),
+	json_to_prolog(json([y=50,x=25.1]), T2).
+test(json2pt, X == tpoint(25,50)) :-
+	json_to_prolog(json([x=25,y=50,type=point]), X).
+
+:- end_tests(json_convert).
+
+
+		 /*******************************
+		 *	       HTTP		*
+		 *******************************/
+
+:- use_module(http_json).
+:- use_module(http_client).
+:- use_module(thread_httpd).
+
+:- dynamic
+	port/1.
+
+make_server :-
+	retractall(port(_)),
+	http_server(reply,
+		    [ port(Port),
+		      workers(1)
+		    ]),
+	assert(port(Port)).
+
+kill_server :-
+	retract(port(Port)),
+	http_stop_server(Port, []).
+
+reply(Request) :-
+	memberchk(path('/json/echo'), Request), !,
+	http_read_json(Request, JSON),
+	reply_json(JSON).
+
+echo(Term, Reply) :-
+	port(Port),
+	format(string(URL), 'http://localhost:~w/json/echo', [Port]),
+	http_post(URL, json(Term), Reply, []).
+
+:- begin_tests(json_http, [ setup(make_server),
+			    cleanup(kill_server)
+			  ]).
+
+test(echo, X == 42) :-
+	echo(42, X).
+test(echo, X == -3.14) :-
+	echo(-3.14, X).
+test(echo, X == name) :-
+	echo(name, X).
+test(echo, X == [1,2,3]) :-
+	echo([1,2,3], X).
+test(echo, X == json([name=json, arity=2])) :-
+	echo(json([name=json, arity=2]), X).
+
+test(unicode, X == Atom) :-
+	Atom = '\u0411\u0435\u0437\u0443\u043f\u0440\u0435\u0447\u043d\u043e\u0435',
+	echo(Atom, X).
+test(quote, X == Atom) :-
+	Atom = 'hello, "world"',
+	echo(Atom, X).
+test(control, X == Atom) :-
+	Atom = 'hello\n\t\r\b\003\',
+	echo(Atom, X).
+
+:- end_tests(json_http).
+
+:- multifile
+	user:message_hook/3.
+
+user:message_hook(httpd_stopped_worker(_, true), _Kind, _Lines).

packages/http/thread_httpd.pl

@@ -0,0 +1,593 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(thread_httpd,
+	  [ http_current_server/2,	% ?:Goal, ?Port
+	    http_server_property/2,	% ?Port, ?Property
+	    http_server/2,		% :Goal, +Options
+	    http_workers/2,		% +Port, ?WorkerCount
+	    http_current_worker/2,	% ?Port, ?ThreadID
+	    http_stop_server/2,		% +Port, +Options
+	    http_spawn/2,		% :Goal, +Options
+
+	    http_requeue/1,		% +Request
+	    http_close_connection/1	% +Request
+	  ]).
+:- use_module(library(debug)).
+:- use_module(library(error)).
+:- use_module(library(option)).
+:- use_module(library(lists)).
+:- use_module(library(socket)).
+:- use_module(library(thread_pool)).
+:- use_module(http_wrapper).
+:- use_module(http_stream).
+
+
+/** <module> Threaded HTTP server
+
+This library provides a multi-threaded Prolog-based HTTP server based on
+the same wrapper as xpce_httpd and   inetd_httpd. This server can handle
+multiple clients in Prolog threads and doesn't need XPCE.
+
+In addition to the other two frontends   (XPCE and inetd), this frontend
+provides hooks for http_ssl_plugin.pl for creating   an HTTPS server. It
+is activated using the  option   ssl(+SSLOptions),  where SSLOptions are
+options required by ssl_init/3. See   http_ssl_plugin.pl and package ssl
+for details.
+*/
+
+:- meta_predicate
+	http_server(1, +),
+	http_current_server(1, ?),
+	http_spawn(0, +).
+
+:- dynamic
+	port_option/2,			% Port, Option
+	current_server/5,		% Port, Goal, Thread, Queue, StartTime
+	queue_worker/2,			% Queue, ThreadID
+	queue_options/2.		% Queue, Options
+
+:- multifile
+	make_socket_hook/3,
+	accept_hook/2,
+	close_hook/1,
+	open_client_hook/5.
+
+%%	http_server(:Goal, +Options) is det.
+%
+%	Create a server at Port that calls Goal for each parsed request.
+%	Options provide a list of options. Defined options are
+%
+%	| port(?Port)	     | - 	| Port to listen to		      |
+%	| workers(N)	     | 2 	| Define the number of worker threads |
+%	| timeout(S)	     | 60	| Max inactivity for reading request  |
+%	| keep_alive_timeout | 10	| Drop Keep-Alive connection timeout  |
+%	| local(KBytes)	     | <CommandLine> |				      |
+%	| global(KBytes)     | <CommandLine> |				      |
+%	| trail(KBytes)      | <CommandLine> | Stack-sizes of worker threads  |
+
+http_server(Goal, Options) :-
+	strip_module(Goal, Module, G),
+	select_option(port(Port), Options, Options1), !,
+	make_socket(Port, Options1, Options2),
+	set_port_options(Port, Options2),
+	create_workers(Options2),
+	create_server(Module:G, Port, Options2).
+http_server(_Goal, _Options) :-
+	throw(error(existence_error(option, port), _)).
+
+
+%%	make_socket(?Port, +OptionsIn, -OptionsOut) is det.
+%
+%	Create the HTTP server socket and  worker pool queue. OptionsOut
+%	is quaranteed to hold the option queue(QueueId).
+
+make_socket(Port, Options0, Options) :-
+	make_socket_hook(Port, Options0, Options), !.
+make_socket(Port, Options0, Options) :-
+	tcp_socket(Socket),
+	tcp_setopt(Socket, reuseaddr),
+	tcp_bind(Socket, Port),
+	tcp_listen(Socket, 5),
+	atom_concat('httpd@', Port, Queue),
+	Options = [ queue(Queue),
+		    tcp_socket(Socket)
+		  | Options0
+		  ].
+
+create_server(Goal, Port, Options) :-
+	get_time(StartTime),
+	memberchk(queue(Queue), Options),
+	atom_concat('http@', Port, Alias),
+	thread_create(accept_server(Goal, Options), _,
+		      [ alias(Alias)
+		      ]),
+	assert(current_server(Port, Goal, Alias, Queue, StartTime)).
+
+
+%%	set_port_options(+Port, +Options) is det.
+%
+%	Register Options for the HTTP server at Port.
+
+set_port_options(Port, Options) :-
+	retractall(port_option(Port, _)),
+	assert_port_options(Options, Port).
+
+assert_port_options([], _).
+assert_port_options([Name=Value|T], Port) :- !,
+	Opt =.. [Name,Value],
+	assert(port_option(Port, Opt)),
+	assert_port_options(T, Port).
+assert_port_options([Opt|T], Port) :- !,
+	assert(port_option(Port, Opt)),
+	assert_port_options(T, Port).
+
+
+%%	http_current_server(:Goal, ?Port) is nondet.
+%
+%	True if Goal is the goal of a server at Port.
+%
+%	@deprecated Use http_server_property(Port, goal(Goal))
+
+http_current_server(Goal, Port) :-
+	current_server(Port, Goal, _, _, _).
+
+
+%%	http_server_property(?Port, ?Property) is nondet.
+%
+%	True if Property is a property of the HTTP server running at
+%	Port.  Defined properties are:
+%
+%	    * goal(:Goal)
+%	    Goal used to start the server. This is often
+%	    http_dispatch/1.
+%	    * start_time(?Time)
+%	    Time-stamp when the server was created.
+
+http_server_property(Port, Property) :-
+	server_property(Property, Port).
+
+server_property(goal(Goal), Port) :-
+	current_server(Port, Goal, _, _, _).
+server_property(start_time(Time), Port) :-
+	current_server(Port, _, _, _, Time).
+
+
+%%	http_workers(+Port, -Workers) is det.
+%%	http_workers(+Port, +Workers:int) is det.
+%
+%	Query or set the number of workers  for the server at this port.
+%	The number of workers is dynamically   modified. Setting it to 1
+%	(one) can be used to profile the worker using tprofile/1.
+
+http_workers(Port, Workers) :-
+	must_be(integer, Port),
+	current_server(Port, _, _, Queue, _), !,
+	(   integer(Workers)
+	->  resize_pool(Queue, Workers)
+	;   findall(W, queue_worker(Queue, W), WorkerIDs),
+	    length(WorkerIDs, Workers)
+	).
+http_workers(Port, _) :-
+	existence_error(http_server, Port).
+
+
+%%	http_current_worker(?Port, ?ThreadID) is nondet.
+%
+%	True if ThreadID is the identifier   of  a Prolog thread serving
+%	Port. This predicate is  motivated  to   allow  for  the  use of
+%	arbitrary interaction with the worker thread for development and
+%	statistics.
+
+http_current_worker(Port, ThreadID) :-
+	current_server(Port, _, _, Queue, _),
+	queue_worker(Queue, ThreadID).
+
+
+%%	accept_server(:Goal, +Options)
+%
+%	The goal of a small server-thread accepting new requests and
+%	posting them to the queue of workers.
+
+accept_server(Goal, Options) :-
+	catch(accept_server2(Goal, Options), http_stop, true),
+	thread_self(Thread),
+	retract(current_server(_Port, _, Thread, _Queue, _StartTime)),
+	close_server_socket(Options).
+
+accept_server2(Goal, Options) :-
+	accept_hook(Goal, Options), !.
+accept_server2(Goal, Options) :-
+	memberchk(tcp_socket(Socket), Options), !,
+	memberchk(queue(Queue), Options),
+	repeat,
+	  (   catch(tcp_accept(Socket, Client, Peer), E, true)
+	  ->  (   var(E)
+	      ->  debug(http(connection), 'New HTTP connection from ~p', [Peer]),
+		  thread_send_message(Queue, tcp_client(Client, Goal, Peer)),
+		  fail
+	      ;   accept_rethrow_error(E)
+	      ->  throw(E)
+	      ;   print_message(error, E),
+		  fail
+	      )
+	  ;   print_message(error, goal_failed(tcp_accept(Socket, Client, Peer)))
+	  ).
+
+accept_rethrow_error(http_stop).
+accept_rethrow_error('$aborted').
+
+
+%%	close_server_socket(+Options)
+%
+%	Close the server socket.
+
+close_server_socket(Options) :-
+	close_hook(Options), !.
+close_server_socket(Options) :-
+	memberchk(tcp_socket(Socket), Options), !,
+	tcp_close_socket(Socket).
+
+
+%%	http_stop_server(+Port, +Options)
+%
+%	Stop the indicated  HTTP  server   gracefully.  First  stops all
+%	workers, then stops the server.
+%
+%	@tbd	Realise non-graceful stop
+
+http_stop_server(Port, _Options) :-
+	http_workers(Port, 0),
+	current_server(Port, _, Thread, Queue, _Start),
+	retractall(queue_options(Queue, _)),
+	thread_signal(Thread, throw(http_stop)),
+	catch(connect(localhost:Port), _, true),
+	thread_join(Thread, _),
+	message_queue_destroy(Queue).
+
+connect(Address) :-
+        tcp_socket(Socket),
+        tcp_connect(Socket, Address),
+	tcp_close_socket(Socket).
+
+
+		 /*******************************
+		 *    WORKER QUEUE OPERATIONS	*
+		 *******************************/
+
+%%	create_workers(+Options)
+%
+%	Create the pool of HTTP worker-threads. Each worker has the
+%	alias http_worker_N.
+
+create_workers(Options) :-
+	option(workers(N), Options, 2),
+	option(queue(Queue), Options),
+	catch(message_queue_create(Queue), _, true),
+	atom_concat(Queue, '_', AliasBase),
+	create_workers(1, N, Queue, AliasBase, Options),
+	assert(queue_options(Queue, Options)).
+
+create_workers(I, N, _, _, _) :-
+	I > N, !.
+create_workers(I, N, Queue, AliasBase, Options) :-
+	gensym(AliasBase, Alias),
+	thread_create(http_worker(Options), Id,
+		      [ alias(Alias)
+		      | Options
+		      ]),
+	assert(queue_worker(Queue, Id)),
+	I2 is I + 1,
+	create_workers(I2, N, Queue, AliasBase, Options).
+
+
+%%	resize_pool(+Queue, +Workers) is det.
+%
+%	Create or destroy workers. If workers   are  destroyed, the call
+%	waits until the desired number of waiters is reached.
+
+resize_pool(Queue, Size) :-
+	findall(W, queue_worker(Queue, W), Workers),
+	length(Workers, Now),
+	(   Now < Size
+	->  queue_options(Queue, Options),
+	    atom_concat(Queue, '_', AliasBase),
+	    I0 is Now+1,
+	    create_workers(I0, Size, Queue, AliasBase, Options)
+	;   Now == Size
+	->  true
+	;   Now > Size
+	->  Excess is Now - Size,
+	    thread_self(Me),
+	    forall(between(1, Excess, _), thread_send_message(Queue, quit(Me))),
+	    forall(between(1, Excess, _), thread_get_message(quitted(_)))
+	).
+
+
+%%	http_worker(+Options)
+%
+%	Run HTTP worker main loop. Workers   simply  wait until they are
+%	passed an accepted socket to process  a client.
+%
+%	If the message quit(Sender) is read   from the queue, the worker
+%	stops.
+
+http_worker(Options) :-
+	thread_at_exit(done_worker),
+	option(queue(Queue), Options),
+	repeat,
+	  garbage_collect,
+	  debug(http(worker), 'Waiting for a job ...', []),
+	  thread_get_message(Queue, Message),
+	  debug(http(worker), 'Got job ~p', [Message]),
+	  (   Message = quit(Sender)
+	  ->  !,
+	      thread_self(Self),
+	      thread_detach(Self),
+	      thread_send_message(Sender, quitted(Self))
+	  ;   open_client(Message, Queue, Goal, In, Out,
+			  Options, ClientOptions),
+	      (	  catch(http_process(Goal, In, Out, ClientOptions),
+			Error, true)
+	      ->  true
+	      ;	  Error = goal_failed(http_process/4)
+	      ),
+	      (	  var(Error)
+	      ->  fail
+	      ;	  current_message_level(Error, Level),
+		  print_message(Level, Error),
+		  memberchk(peer(Peer), ClientOptions),
+		  close_connection(Peer, In, Out),
+		  fail
+	      )
+	  ).
+
+
+%%	open_client(+Message, +Queue, -Goal, -In, -Out,
+%%		    +Options, -ClientOptions) is semidet.
+%
+%	Opens the connection to the client in a worker from the message
+%	sent to the queue by accept_server/2.
+
+open_client(requeue(In, Out, Goal, ClOpts),
+	    _, Goal, In, Out, Opts, ClOpts) :- !,
+	memberchk(peer(Peer), ClOpts),
+	option(keep_alive_timeout(KeepAliveTMO), Opts, 5),
+	check_keep_alife_connection(In, KeepAliveTMO, Peer, In, Out).
+open_client(Message, Queue, Goal, In, Out, _Opts,
+	    [ pool(client(Queue, Goal, In, Out))
+	    | Options
+	    ]) :-
+	catch(open_client(Message, Goal, In, Out, Options),
+	      E, report_error(E)),
+	memberchk(peer(Peer), Options),
+	debug(http(connection), 'Opened connection from ~p', [Peer]).
+
+
+open_client(Message, Goal, In, Out, Options) :-
+	open_client_hook(Message, Goal, In, Out, Options), !.
+open_client(tcp_client(Socket, Goal, Peer), Goal, In, Out,
+	    [ peer(Peer),
+	      protocol(http)
+	    ]) :-
+	tcp_open_socket(Socket, In, Out).
+
+report_error(E) :-
+	print_message(error, E),
+	fail.
+
+
+%%	check_keep_alife_connection(+In, +TimeOut, +Peer, +In, +Out) is semidet.
+%
+%	Wait for the client for at most  TimeOut seconds. Succeed if the
+%	client starts a new request within   this  time. Otherwise close
+%	the connection and fail.
+
+check_keep_alife_connection(In, TMO, Peer, In, Out) :-
+	stream_property(In, timeout(Old)),
+	set_stream(In, timeout(TMO)),
+	debug(http(keep_alife), 'Waiting for keep-alife ...', []),
+	catch(peek_code(In, Code), E, true),
+	(   var(E),			% no exception
+	    Code \== -1			% no end-of-file
+	->  set_stream(In, timeout(Old)),
+	    debug(http(keep_alife), '\tre-using keep-alife connection', [])
+	;   (   Code == -1
+	    ->	debug(http(keep_alife), '\tRemote closed keep-alife connection', [])
+	    ;	debug(http(keep_alife), '\tTimeout on keep-alife connection', [])
+	    ),
+	    close_connection(Peer, In, Out),
+	    fail
+	).
+
+
+%%	done_worker
+%
+%	Called when worker is terminated due to http_workers/2.
+
+done_worker :-
+	thread_self(Self),
+	thread_property(Self, status(Status)),
+	retract(queue_worker(_Queue, Self)),
+	print_message(informational,
+		      httpd_stopped_worker(Self, Status)).
+
+
+%	thread_httpd:message_level(+Exception, -Level)
+%
+%	Determine the message stream used for  exceptions that may occur
+%	during server_loop/5. Being multifile, clauses   can be added by
+%	the   application   to   refine   error   handling.   See   also
+%	message_hook/3 for further programming error handling.
+
+:- multifile
+	message_level/2.
+
+message_level(error(io_error(read, _), _),	silent).
+message_level(error(timeout_error(read, _), _),	informational).
+message_level(keep_alive_timeout,		silent).
+
+current_message_level(Term, Level) :-
+	(   message_level(Term, Level)
+	->  true
+	;   Level = error
+	).
+
+
+%%	http_requeue(+Header)
+%
+%	Re-queue a connection to  the  worker   pool.  This  deals  with
+%	processing additional requests on keep-alife connections.
+
+http_requeue(Header) :-
+	requeue_header(Header, ClientOptions),
+	memberchk(pool(client(Queue, Goal, In, Out)), ClientOptions),
+	thread_send_message(Queue, requeue(In, Out, Goal, ClientOptions)), !.
+http_requeue(Header) :-
+	debug(http(error), 'Re-queue failed: ~p', [Header]),
+	fail.
+
+requeue_header([], []).
+requeue_header([H|T0], [H|T]) :-
+	requeue_keep(H), !,
+	requeue_header(T0, T).
+requeue_header([_|T0], T) :-
+	requeue_header(T0, T).
+
+requeue_keep(pool(_)).
+requeue_keep(peer(_)).
+requeue_keep(protocol(_)).
+
+
+%%	http_process(Message, Queue, +Options)
+%
+%	Handle a single client message on the given stream.
+
+http_process(Goal, In, Out, Options) :-
+	debug(http(server), 'Running server goal ~p on ~p -> ~p',
+	      [Goal, In, Out]),
+	option(timeout(TMO), Options, 60),
+	set_stream(In, timeout(TMO)),
+	http_wrapper(Goal, In, Out, Connection,
+		     [ request(Request)
+		     | Options
+		     ]),
+	next(Connection, Request).
+
+next(spawned(ThreadId), _) :- !,
+	debug(http(spawn), 'Handler spawned to thread ~w', [ThreadId]).
+next(Connection, Request) :-
+	downcase_atom(Connection, 'keep-alive'),
+	http_requeue(Request), !.
+next(_, Request) :-
+	http_close_connection(Request).
+
+
+%%	http_close_connection(+Request)
+%
+%	Close connection associated to Request.  See also http_requeue/1.
+
+http_close_connection(Request) :-
+	memberchk(pool(client(_Queue, _Goal, In, Out)), Request),
+	memberchk(peer(Peer), Request),
+	close_connection(Peer, In, Out).
+
+%%	close_connection(+Peer, +In, +Out)
+%
+%	Closes the connection from the server to the client.  Errors are
+%	currently silently ignored.
+
+close_connection(Peer, In, Out) :-
+	debug(http(connection), 'Closing connection from ~p', [Peer]),
+	catch(close(In, [force(true)]), _, true),
+	catch(close(Out, [force(true)]), _, true).
+
+%%	http_spawn(:Goal, +Options) is det.
+%
+%	Continue this connection on a  new   thread.  A handler may call
+%	http_spawn/2 to start a new thread that continues processing the
+%	current request using Goal. The original   thread returns to the
+%	worker pool for processing new requests.   Options are passed to
+%	thread_create/3, except for:
+%
+%	    * pool(+Pool)
+%	    Interfaces to library(thread_pool), starting the thread
+%	    on the given pool.
+%	    * backlog(+MaxBacklog)
+%	    Reply using a 503 (service unavailable) if too many requests
+%	    are waiting in this pool.
+
+http_spawn(Goal, Options) :-
+	select_option(pool(Pool), Options, Options1), !,
+	select_option(backlog(BackLog), Options1, ThreadOptions, infinite),
+	check_backlog(BackLog, Pool),
+	current_output(CGI),
+	thread_create_in_pool(Pool,
+			      wrap_spawned(CGI, Goal), Id,
+			      [ detached(true)
+			      | ThreadOptions
+			      ]),
+	http_spawned(Id).
+http_spawn(Goal, Options) :-
+	current_output(CGI),
+	thread_create(wrap_spawned(CGI, Goal), Id,
+		      [ detached(true)
+		      | Options
+		      ]),
+	http_spawned(Id).
+
+wrap_spawned(CGI, Goal) :-
+	set_output(CGI),
+	http_wrap_spawned(Goal, Request, Connection),
+	next(Connection, Request).
+
+%%	check_backlog(+MaxBackLog, +Pool)
+%
+%	Check whether the backlog in the pool  has been exceeded. If so,
+%	reply as =busy=, which causes an HTTP 503 response.
+
+check_backlog(BackLog, Pool) :-
+	integer(BackLog),
+	thread_pool_property(Pool, backlog(Waiting)),
+	Waiting > BackLog, !,
+	throw(http_reply(busy)).
+check_backlog(_, _).
+
+
+		 /*******************************
+		 *	      MESSAGES		*
+		 *******************************/
+
+:- multifile
+	prolog:message/3.
+
+prolog:message(httpd_stopped_worker(Self, Status)) -->
+	[ 'Stopped worker ~p: ~p'-[Self, Status] ].

packages/http/txttotex.pl

@@ -0,0 +1,20 @@
+:- asserta(user:file_search_path(library, ..)).
+
+:- load_files([ library(doc_latex),
+		library('http/html_write'),
+		library('http/json'),
+		library('http/json_convert'),
+		library('http/http_json')
+	      ],
+	      [ silent(true)
+	      ]).
+
+txttotex :-
+	current_prolog_flag(argv, Argv),
+	append(_, [--|Files], Argv), !,
+	maplist(txttotex, Files).
+
+txttotex(File) :-
+	file_name_extension(Base, _, File),
+	file_name_extension(Base, tex, TexFile),
+	doc_latex(File, TexFile, [stand_alone(false)]).

packages/http/web/css/dirindex.css

@@ -0,0 +1,24 @@
+/* CSS for SWI-Prolog HTTPD directory indices
+*/
+
+table.dirindex th.name
+{ text-align: left;
+}
+
+table.dirindex tr.dirindex_header
+{ background-color: #b0ffb0;
+}
+
+table.dirindex tr.odd
+{ background-color: #d0d0d0;
+}
+
+table.dirindex th.modified, th.size
+{ text-align: right;
+}
+
+table.dirindex td.modified, td.size
+{ text-align: right;
+  padding-left: 10px;
+  font-family: monospace;
+}

packages/http/web/css/openid.css

@@ -0,0 +1,42 @@
+/* $Id$
+
+   CSS for OpenID module,
+   Author: Jan Wielemaker
+   Copying: Public domain
+
+   For a tutorial on CSS, see
+   <http://www.htmldog.com/guides/cssbeginner/selectors/>
+*/
+
+div.openid-title
+{ margin-bottom: 1em;
+}
+
+div.openid-title img
+{ border: 0;
+  height: 4em;
+  vertical-align: sub;
+}
+
+div.openid-title span
+{ font-size: 2em;
+  font-weight: 300;
+}
+
+div.openid-message
+{ margin-top: 1em;
+}
+
+table.openid-form
+{ margin-top: 1em;
+}
+
+table.openid-form td
+{
+}
+
+input.openid-input
+{ background: #fff url('../icons/openid-logo-tiny.png') no-repeat center left;
+  padding-left: 20px;
+  margin-left: 2cm;
+}

packages/http/xpce_httpd.pl

@@ -0,0 +1,286 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2005, University of Amsterdam
+
+    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
+    of the License, 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 Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+    As a special exception, if you link this library with other files,
+    compiled with a Free Software compiler, to produce an executable, this
+    library does not by itself cause the resulting executable to be covered
+    by the GNU General Public License. This exception does not however
+    invalidate any other reasons why the executable file might be covered by
+    the GNU General Public License.
+*/
+
+:- module(xpce_httpd,
+	  [ http_current_server/2,	% ?:Goal, ?Port
+	    http_server/2		% :Goal, :Options
+	  ]).
+:- use_module(library(pce)).
+:- use_module(http_header).
+:- use_module(library(debug)).
+:- use_module(http_wrapper).
+:- use_module(library(lists)).
+
+:- meta_predicate
+	http_server(:, ?),
+	http_server(:, ?, +).
+
+%	@http_servers: keep track of them and avoid the servers being
+%	garbage collected.
+
+:- pce_global(@http_servers, new(chain)).
+
+%:- debug(connection).
+
+http_current_server(Goal, Port) :-
+	object(@open_sockets),
+	chain_list(@open_sockets, Sockets),
+	member(Socket, Sockets),
+	send(Socket, instance_of, interactive_httpd),
+	get(Socket, goal, Goal),
+	get(Socket, address, Port).
+
+%%	http_server(:Goal, +Options) is det.
+%
+%	Start server at given or arbitrary port.
+
+http_server(Goal, Options) :-
+	select(port(Port), Options, Options1), !,
+	http_server(Goal, Port, Options1).
+http_server(_Goal, _Options) :-
+	throw(error(existence_error(option, port), _)).
+
+http_server(Goal, Port, _Options) :-
+	strip_module(Goal, M, PlainGoal),
+	(   var(Port)
+	->  new(X, interactive_httpd(M:PlainGoal)),
+	    get(X, address, Port)
+	;   new(X, interactive_httpd(M:PlainGoal, Port))
+	).
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+XPCE based socket handling for   generic HTTP interface infra-structure.
+This module acts as a replacement for inetd_httpd, which allows a Prolog
+process to acts as an inet-driven HTTP server.
+
+Using this module the user can easily  debug HTTP connections or provide
+services while running the XPCE GUI.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+:- pce_begin_class(interactive_httpd, socket,
+		   "Prolog HTTP debugger").
+
+variable(allowed_hosts,	chain*,	 both, "Chain of regex with acceptable peers").
+variable(goal,		prolog,	 get,  "Goal to use for processing").
+variable(out_stream,	prolog,	 get,  "Stream for output").
+variable(peer,		name,	 get,  "Peer connection (host only)").
+variable(request,	string*, get,  "Data for first line").
+variable(data,		string*, get,  "Data for POST request").
+variable(chunk_data,	string*, get,  "Collect chunked input").
+variable(mode,
+	 {request,header,post_content_length,chunked} := request,
+				 get,  "Mode of operation").
+
+:- pce_global(@http_end_header_regex,
+	      new(regex('\n\r?\n\r?'))).
+:- pce_global(@http_end_line_regex,
+	      new(regex('\n\r?'))).
+:- pce_global(@http_has_header_regex,
+	      new(regex('[^\n]*HTTP/'))).
+
+initialise(S, Goal:prolog, Port:[int]) :->
+	default(Port, 0, ThePort),	% anonymous
+	send_super(S, initialise, ThePort),
+	send(S, slot, goal, Goal),
+	send(S, record_separator, @http_end_line_regex),
+	send(S, input_message, message(@receiver, input, @arg1)),
+	send(S, accept_message, message(@arg1, accepted)),
+	send(S, listen, reuse := @on),
+	send(@http_servers, append, S).
+
+unlink(S) :->
+	send(@http_servers, delete_all, S),
+	send_super(S, unlink).
+
+:- pce_group(connection).
+
+accepted(S) :->
+	"A new connection is established on this socket"::
+	(   pce_catch_error(_, get(S, peer_name, tuple(Peer, _Port)))
+	->  send(S, slot, peer, Peer),
+	    send(S, authorise),
+	    debug(connection, 'New connection from ~w', [Peer]),
+	    pce_open(S, append, Fd),
+	    send(S, slot, out_stream, Fd)
+	;   debug(connection, 'Cannot get peer: closing.', []),
+	    free(S)
+	).
+
+authorise(S) :->
+	"See whether we will proceeed with this connection"::
+	get(S, allowed_hosts, Allowed),
+	(   Allowed == @nil
+	->  true
+	;   get(S, peer, Peer),
+	    get(Allowed, find,
+		message(@arg1, match, Peer),
+		_)
+	->  true
+	;   debug(connection, 'Refused connection from ~w', [Peer]),
+	    free(S),
+	    fail
+	).
+
+unlink(S) :->
+	(   debugging(connection)
+	->  get(S, peer, Peer),
+	    debug(connection, 'Closed connection from ~w', [Peer])
+	;   true
+	),
+	(   get(S, slot, out_stream, Fd),
+	    Fd \== @nil
+	->  catch(close(Fd), _, true)
+	;   true
+	),
+	send_super(S, unlink).
+
+:- pce_group(request).
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+->input collects input from  the  stream   until  an  entire  request is
+complete. A request consists of one of the following:
+
+	<Request>	::= <Action> <Path>\n
+			  | <Action> <Path> HTTP/<Version>\n
+			    <Header>
+			    <Post Data>?
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+input(S, Input:string) :->
+	"Process input.  The argument is the header"::
+	get(S, mode, Mode),
+	(   debugging(input)
+	->  send(@pce, format, 'GOT (mode %s): "%s"\n', Mode, Input)
+	;   true
+	),
+	(   Mode == request		% got first line
+	->  (   send(@http_has_header_regex, match, Input)
+	    ->	send(S, slot, request, Input),
+		send(S, slot, mode, header),
+		send(S, record_separator, @http_end_header_regex)
+	    ;	send(S, dispatch, Input)
+	    )
+	;   Mode == header
+	->  send(Input, prepend, S?request),
+	    send(S, slot, request, @nil),
+	    (	send(S, collect_post_data, Input)
+	    ->	true
+	    ;	send(S, dispatch, Input)
+	    )
+	;   Mode == post_content_length
+	->  send(S, slot, mode, request),
+	    send(S, record_separator, @http_end_line_regex),
+	    get(S, data, Header),
+	    send(Header, append, Input),
+	    send(Header, lock_object, @on),
+	    send(S, slot, data, @nil),
+	    send(S, dispatch, Header),
+	    send(Header, lock_object, @off)
+	;   Mode == chunked
+	->  get(S, chunk_data, ChunkData),
+	    (   get(S, record_separator, Bytes),
+	        integer(Bytes)
+	    ->  send(ChunkData, append, Input),
+		send(S, record_separator, '\n')
+	    ;	send(Input, prepend, '0x'),
+		get(Input, value, HexAtom),
+		term_to_atom(Bytes, HexAtom),
+		(   Bytes == 0
+		->  get(S, data, Header),
+		    get(ChunkData, size, ContentLength),
+		    send(@http_chunked_regex, search, Header),
+		    send(@http_chunked_regex, register_value, 0, Header,
+			 string('Content-Length: %d', ContentLength)),
+		    send(Header, append, ChunkData),
+		    send(S, slot, chunk_data, @nil),
+		    send(S, slot, mode, request),
+		    send(S, record_separator, @http_end_line_regex),
+		    send(S, dispatch, Header)
+		;   send(S, record_separator, Bytes)
+		)
+	    )
+	).
+
+
+dispatch(S, Input:string) :->
+	"Hand complete input for dispatching"::
+	(   debugging(dispatch)
+	->  send(@pce, write_ln, Input)
+	;   true
+	),
+	pce_open(Input, read, In),
+	get(S, goal, Goal),
+	get(S, out_stream, Out),
+	(   catch(http_wrapper(Goal, In, Out, Close, []),
+		  E, wrapper_error(E))
+	->  close(In),
+	    (   downcase_atom(Close, 'keep-alive')
+	    ->  send(S, slot, mode, request), % prepare for next
+		send(S, record_separator, @http_end_line_regex),
+		send(S, slot, data, @nil)
+	    ;   free(S)
+	    )
+	;   close(In),			% exception or failure
+	    free(S)
+	).
+
+wrapper_error(Error) :-
+	(   debugging(connection)
+	->  print_message(error, Error)
+	;   true
+	),
+	fail.
+
+:- pce_group(post).
+
+
+:- pce_global(@http_content_length_regex,
+	      new(regex('^Content-Length:[[:blank:]]*([0-9]+)', @off))).
+:- pce_global(@http_chunked_regex,
+	      new(regex('^Transfer-encoding:[[:blank:]]*chunked', @off))).
+
+
+collect_post_data(S, Header:string) :->
+	(   send(@http_content_length_regex, search, Header)
+	->  get(@http_content_length_regex, register_value, Header,
+		1, int, Len),
+	    debug(dispatch, '[POST] Content-length: ~w~n', [Len]),
+	    send(S, slot, mode, post_content_length),
+	    send(S, slot, data, Header),
+	    send(S, record_separator, Len)
+	;   send(@http_chunked_regex, search, Header)
+	->  send(S, slot, mode, chunked),
+	    send(S, slot, chunk_data, new(string)),
+	    send(S, record_separator, '\n')
+	).
+
+:- pce_end_class(interactive_httpd).
+