diogo
/
yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

make http an external module.

This commit is contained in:
Vítor Santos Costa 2011-03-09 23:38:58 +00:00
parent c52ad77861
commit 4b8a9a4f4e
96 changed files with 4 additions and 20849 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitmodules vendored
View File

@ -10,3 +10,6 @@
[submodule "packages/zlib"]
path = packages/zlib
url = git://yap.git.sourceforge.net/gitroot/yap/zlib
[submodule "packages/http"]
path = packages/http
url = ssh://vsc@yap.git.sourceforge.net/gitroot/yap/http

1
packages/http Submodule

@ -0,0 +1 @@
Subproject commit 77744ad3a901eb97cafd95c1e0ac1b89d3859b18

792
packages/http/ChangeLog
View File

@ -1,792 +0,0 @@
[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.

224
packages/http/Makefile.in
View File

@ -1,224 +0,0 @@
################################################################
# 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@
#
#
DEFS=@DEFS@ -D_YAP_NOT_INSTALLED_=1
CC=@CC@
CFLAGS= @SHLIB_CFLAGS@ $(YAP_EXTRAS) $(DEFS) -I$(srcdir) -I../.. -I$(srcdir)/../../include @CPPFLAGS@
MKINDEX=true
SO=@SO@
#4.1VPATH=@srcdir@:@srcdir@/OPTYap
CWD=$(PWD)
#
LD=@DO_SECOND_LD@ @SHLIB_LD@
LDFLAGS=@EXTRA_LIBS_FOR_SWIDLLS@ @LDFLAGS@
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) $(SOLIBS)
mkdir -p $(BINTARGET)
rm -f $(BINTARGET)/http_chunked.@SO@
$(INSTALL_PROGRAM) $(SOLIBS) $(BINTARGET)
mkdir -p $(PLTARGET)
mkdir -p $(PLTARGET)/web/icons
mkdir -p $(DESTDIR)$(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

82
packages/http/Makefile.mak
View File

@ -1,82 +0,0 @@
################################################################
# 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

18
packages/http/README
View File

@ -1,18 +0,0 @@
---+ 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

25
packages/http/TODO
View File

@ -1,25 +0,0 @@
---+ 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.

745
packages/http/cgi_stream.c
View File

@ -1,745 +0,0 @@
/* 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);
}

28
packages/http/common.mk
View File

@ -1,28 +0,0 @@
# 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

90
packages/http/config.h.in
View File

@ -1,90 +0,0 @@
/* 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

483
packages/http/config.log
View File

@ -1,483 +0,0 @@
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

9
packages/http/configure.in
View File

@ -1,9 +0,0 @@
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)

364
packages/http/dcg_basics.pl
View File

@ -1,364 +0,0 @@
/* $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]).

68
packages/http/examples/README
View File

@ -1,68 +0,0 @@
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.

92
packages/http/examples/calc.pl
View File

@ -1,92 +0,0 @@
/* $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).

212
packages/http/examples/demo_body.pl
View File

@ -1,212 +0,0 @@
/* $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, []).

161
packages/http/examples/demo_client.pl
View File

@ -1,161 +0,0 @@
/* $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'
])
]).

50
packages/http/examples/demo_files.pl
View File

@ -1,50 +0,0 @@
:- 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)
).

18
packages/http/examples/demo_inetd
View File

@ -1,18 +0,0 @@
#!/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, []).

173
packages/http/examples/demo_openid.pl
View File

@ -1,173 +0,0 @@
/* 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).

20
packages/http/examples/demo_pwp.pl
View File

@ -1,20 +0,0 @@
:- 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)]).

30
packages/http/examples/demo_threads.pl
View File

@ -1,30 +0,0 @@
/* $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).

40
packages/http/examples/demo_xpce.pl
View File

@ -1,40 +0,0 @@
/* $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)
]).

23
packages/http/examples/pwp/context.pwp
View File

@ -1,23 +0,0 @@
<?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>

25
packages/http/examples/pwp/index.pwp
View File

@ -1,25 +0,0 @@
<?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>

12
packages/http/examples/pwp/pwp1.pwp
View File

@ -1,12 +0,0 @@
<?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>

10
packages/http/examples/pwp/pwp2.pwp
View File

@ -1,10 +0,0 @@
<?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>

25
packages/http/examples/pwp/pwp3.pwp
View File

@ -1,25 +0,0 @@
<?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>

23
packages/http/examples/pwp/pwp4.pwp
View File

@ -1,23 +0,0 @@
<?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>

11
packages/http/examples/pwp/pwp5.pwp
View File

@ -1,11 +0,0 @@
<?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>

3
packages/http/examples/pwp/pwp6.pwp
View File

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

3
packages/http/examples/pwp/pwp7.pwp
View File

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

3
packages/http/examples/pwp/pwp8.pwp
View File

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

12
packages/http/examples/pwp/pwpdb.pl
View File

@ -1,12 +0,0 @@
% 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').

52
packages/http/examples/stress_client.pl
View File

@ -1,52 +0,0 @@
/* $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')
], _, []).

129
packages/http/examples/stress_server.pl
View File

@ -1,129 +0,0 @@
/* $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]).

1
packages/http/figs/.cvsignore
View File

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

384
packages/http/figs/httpserver.eps
View File

@ -1,384 +0,0 @@
%!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

BIN
packages/http/figs/httpserver.pd
View File

Binary file not shown.

503
packages/http/html_head.pl
View File

@ -1,503 +0,0 @@
/* 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).

1278
packages/http/html_write.pl
View File

File diff suppressed because it is too large Load Diff

1837
packages/http/http.doc
View File

File diff suppressed because it is too large Load Diff

221
packages/http/http_authenticate.pl
View File

@ -1,221 +0,0 @@
/* $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)))
).

293
packages/http/http_chunked.c
View File

@ -1,293 +0,0 @@
/* $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);
}

483
packages/http/http_client.pl
View File

@ -1,483 +0,0 @@
/* $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(http_stream).
:- 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).

202
packages/http/http_dirindex.pl
View File

@ -1,202 +0,0 @@
/* 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')
])
]).

855
packages/http/http_dispatch.pl
View File

@ -1,855 +0,0 @@
/* 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.

171
packages/http/http_error.c
View File

@ -1,171 +0,0 @@
/* $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
}

100
packages/http/http_error.pl
View File

@ -1,100 +0,0 @@
/* $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).

112
packages/http/http_exception.pl
View File

@ -1,112 +0,0 @@
/* 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(_,_)).

1519
packages/http/http_header.pl
View File

File diff suppressed because it is too large Load Diff

84
packages/http/http_hook.pl
View File

@ -1,84 +0,0 @@
/* 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.

123
packages/http/http_host.pl
View File

@ -1,123 +0,0 @@
/* 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).

206
packages/http/http_json.pl
View File

@ -1,206 +0,0 @@
/* $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).

263
packages/http/http_log.pl
View File

@ -1,263 +0,0 @@
/* 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)).

79
packages/http/http_mime_plugin.pl
View File

@ -1,79 +0,0 @@
/* $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').

644
packages/http/http_open.pl
View File

@ -1,644 +0,0 @@
/* $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).

1125
packages/http/http_openid.pl
View File

File diff suppressed because it is too large Load Diff

283
packages/http/http_parameters.pl
View File

@ -1,283 +0,0 @@
/* $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).

287
packages/http/http_path.pl
View File

@ -1,287 +0,0 @@
/* 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.

271
packages/http/http_pwp.pl
View File

@ -1,271 +0,0 @@
/* 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).

90
packages/http/http_server_files.pl
View File

@ -1,90 +0,0 @@
/* 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).

512
packages/http/http_session.pl
View File

@ -1,512 +0,0 @@
/* $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.

128
packages/http/http_sgml_plugin.pl
View File

@ -1,128 +0,0 @@
/* $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).

36
packages/http/http_stream.c
View File

@ -1,36 +0,0 @@
/* $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();
}

253
packages/http/http_stream.pl
View File

@ -1,253 +0,0 @@
/* $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.
:- meta_predicate cgi_open(+, -, :, +).
%% 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).

405
packages/http/http_wrapper.pl
View File

@ -1,405 +0,0 @@
/* $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)).

0
packages/http/httpserver.gif
View File

65
packages/http/inetd_httpd.pl
View File

@ -1,65 +0,0 @@
/* $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.

238
packages/http/install-sh
View File

@ -1,238 +0,0 @@
#!/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

231
packages/http/js_write.pl
View File

@ -1,231 +0,0 @@
/* 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)])).

152
packages/http/json.c
View File

@ -1,152 +0,0 @@
/* $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);
}

654
packages/http/json.pl
View File

@ -1,654 +0,0 @@
/* $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' ].

30
packages/http/json.txt
View File

@ -1,30 +0,0 @@
---+ [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]]

548
packages/http/json_convert.pl
View File

@ -1,548 +0,0 @@
/* $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).

146
packages/http/mimepack.pl
View File

@ -1,146 +0,0 @@
/* $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]).

111
packages/http/mimetype.pl
View File

@ -1,111 +0,0 @@
/* $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').

60
packages/http/pltotex.pl
View File

@ -1,60 +0,0 @@
:- 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).

30
packages/http/post.txt
View File

@ -1,30 +0,0 @@
---+++ 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]]

221
packages/http/stream_range.c
View File

@ -1,221 +0,0 @@
/* $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);
}

327
packages/http/test_cgi_stream.pl
View File

@ -1,327 +0,0 @@
/* $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, []),
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).

82
packages/http/test_http.pl
View File

@ -1,82 +0,0 @@
:- 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).

186
packages/http/test_json.pl
View File

@ -1,186 +0,0 @@
/* $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).

593
packages/http/thread_httpd.pl
View File

@ -1,593 +0,0 @@
/* $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] ].

20
packages/http/txttotex.pl
View File

@ -1,20 +0,0 @@
:- 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)]).

24
packages/http/web/css/dirindex.css
View File

@ -1,24 +0,0 @@
/* 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;
}

42
packages/http/web/css/openid.css
View File

@ -1,42 +0,0 @@
/* $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;
}

BIN
packages/http/web/icons/back.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 284 B

BIN
packages/http/web/icons/c.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 285 B

BIN
packages/http/web/icons/compressed.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 315 B

BIN
packages/http/web/icons/folder.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 272 B

BIN
packages/http/web/icons/generic.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 260 B

BIN
packages/http/web/icons/layout.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 306 B

BIN
packages/http/web/icons/openid-logo-square.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.2 KiB

BIN
packages/http/web/icons/openid-logo-tiny.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 493 B

286
packages/http/xpce_httpd.pl
View File

@ -1,286 +0,0 @@
/* $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).