http package (only partially working)
This commit is contained in:
Vítor Santos Costa
parent
6e956b879a
commit
4694a50fa5
@ -505,6 +505,7 @@ all: startup.yss
|
||||
@INSTALL_DLLS@ (cd library/rltree; $(MAKE))
|
||||
@INSTALL_DLLS@ (cd library/lammpi; $(MAKE))
|
||||
@INSTALL_DLLS@ (cd library/matrix; $(MAKE))
|
||||
@INSTALL_DLLS@ (cd packages/http; $(MAKE))
|
||||
@INSTALL_DLLS@ (cd packages/sgml; $(MAKE))
|
||||
@INSTALL_DLLS@ (cd packages/plunit; $(MAKE))
|
||||
@USE_MINISAT@ (cd packages/swi-minisat2/C; $(MAKE))
|
||||
@ -547,6 +548,7 @@ install_unix: startup.yss libYap.a
|
||||
for f in $(PL_SOURCES); do $(INSTALL) $$f $(DESTDIR)$(SHAREDIR)/Yap/pl; done
|
||||
@INSTALL_DLLS@ (cd packages/PLStream; $(MAKE) install)
|
||||
@INSTALL_DLLS@ (cd packages/plunit; $(MAKE) install)
|
||||
@INSTALL_DLLS@ (cd packages/http; $(MAKE) install)
|
||||
@INSTALL_DLLS@ (cd packages/sgml; $(MAKE) install)
|
||||
@USE_MINISAT@ (cd packages/swi-minisat2/C; $(MAKE) install)
|
||||
@INSTALL_DLLS@ (cd library/random; $(MAKE) install)
|
||||
@ -593,6 +595,7 @@ install_win32: startup.yss
|
||||
$(INSTALL) parms.h $(DESTDIR)$(INCLUDEDIR)/parms.h
|
||||
(cd packages/PLStream; $(MAKE) install)
|
||||
(cd packages/plunit; $(MAKE) install)
|
||||
(cd packages/http; $(MAKE) install)
|
||||
(cd packages/sgml; $(MAKE) install)
|
||||
@USE_MINISAT@ (cd packages/swi-minisat2/C; $(MAKE) install)
|
||||
(cd library/random; $(MAKE) install)
|
||||
|
||||
9
configure
vendored
9
configure
vendored
@ -7123,7 +7123,7 @@ then
|
||||
YAPLIB_CFLAGS="$SHLIB_CFLAGS"
|
||||
YAPLIB="$DYNYAPLIB"
|
||||
else
|
||||
YAPLIB_CFLAGS"$CFLAGS"
|
||||
YAPLIB_CFLAGS="$CFLAGS"
|
||||
fi
|
||||
|
||||
if test "$coroutining" = "yes"
|
||||
@ -9212,6 +9212,7 @@ CHR_TARGETS=chr_support."$SO"
|
||||
|
||||
|
||||
CLIB_TARGETS="random.$SO unix.$SO socket.$SO cgi.$SO memfile.$SO files.$SO mime.$SO crypt.$SO"
|
||||
CLIB_PLTARGETS="\$(srcdir)/random.pl \$(srcdir)/unix.pl \$(srcdir)/socket.pl \$(srcdir)/cgi.pl \$(srcdir)/memfile.pl \$(srcdir)/filesex.pl \$(srcdir)/mime.pl \$(srcdir)/crypt.pl"
|
||||
|
||||
ac_fn_c_check_func "$LINENO" "socket" "ac_cv_func_socket"
|
||||
if test "x$ac_cv_func_socket" = x""yes; then :
|
||||
@ -9448,6 +9449,7 @@ fi
|
||||
|
||||
|
||||
|
||||
mkdir -p library/lammpi
|
||||
mkdir -p library/matrix
|
||||
mkdir -p library/matlab
|
||||
mkdir -p library/mpi
|
||||
@ -9456,7 +9458,6 @@ mkdir -p library/regex
|
||||
mkdir -p library/system
|
||||
mkdir -p library/tries
|
||||
mkdir -p library/rltree
|
||||
mkdir -p library/lammpi
|
||||
mkdir -p library/yap2swi
|
||||
mkdir -p LGPL/clp
|
||||
mkdir -p LGPL/swi_console
|
||||
@ -9472,6 +9473,7 @@ mkdir -p packages/clpqr
|
||||
mkdir -p packages/cplint
|
||||
mkdir -p packages/cplint/approx
|
||||
mkdir -p packages/cplint/approx/simplecuddLPADs
|
||||
mkdir -p packages/http
|
||||
mkdir -p packages/jpl
|
||||
mkdir -p packages/jpl/src/java
|
||||
mkdir -p packages/jpl/src/java/jpl
|
||||
@ -9529,6 +9531,8 @@ ac_config_files="$ac_config_files packages/cplint/Makefile"
|
||||
|
||||
ac_config_files="$ac_config_files packages/cplint/approx/simplecuddLPADs/Makefile"
|
||||
|
||||
ac_config_files="$ac_config_files packages/http/Makefile"
|
||||
|
||||
ac_config_files="$ac_config_files packages/PLStream/Makefile"
|
||||
|
||||
ac_config_files="$ac_config_files packages/plunit/Makefile"
|
||||
@ -10272,6 +10276,7 @@ do
|
||||
"packages/CLPBN/Makefile") CONFIG_FILES="$CONFIG_FILES packages/CLPBN/Makefile" ;;
|
||||
"packages/cplint/Makefile") CONFIG_FILES="$CONFIG_FILES packages/cplint/Makefile" ;;
|
||||
"packages/cplint/approx/simplecuddLPADs/Makefile") CONFIG_FILES="$CONFIG_FILES packages/cplint/approx/simplecuddLPADs/Makefile" ;;
|
||||
"packages/http/Makefile") CONFIG_FILES="$CONFIG_FILES packages/http/Makefile" ;;
|
||||
"packages/PLStream/Makefile") CONFIG_FILES="$CONFIG_FILES packages/PLStream/Makefile" ;;
|
||||
"packages/plunit/Makefile") CONFIG_FILES="$CONFIG_FILES packages/plunit/Makefile" ;;
|
||||
"packages/ProbLog/Makefile") CONFIG_FILES="$CONFIG_FILES packages/ProbLog/Makefile" ;;
|
||||
|
||||
@ -1134,7 +1134,7 @@ then
|
||||
YAPLIB_CFLAGS="$SHLIB_CFLAGS"
|
||||
YAPLIB="$DYNYAPLIB"
|
||||
else
|
||||
YAPLIB_CFLAGS"$CFLAGS"
|
||||
YAPLIB_CFLAGS="$CFLAGS"
|
||||
fi
|
||||
|
||||
if test "$coroutining" = "yes"
|
||||
@ -1722,6 +1722,7 @@ AC_SUBST(CLIB_NETLIBS)
|
||||
AC_SUBST(CLIB_CRYPTLIBS)
|
||||
|
||||
CLIB_TARGETS="random.$SO unix.$SO socket.$SO cgi.$SO memfile.$SO files.$SO mime.$SO crypt.$SO"
|
||||
CLIB_PLTARGETS="\$(srcdir)/random.pl \$(srcdir)/unix.pl \$(srcdir)/socket.pl \$(srcdir)/cgi.pl \$(srcdir)/memfile.pl \$(srcdir)/filesex.pl \$(srcdir)/mime.pl \$(srcdir)/crypt.pl"
|
||||
|
||||
AC_CHECK_FUNC(socket, [], [
|
||||
AC_CHECK_LIB(socket, socket,
|
||||
@ -1779,6 +1780,7 @@ fi
|
||||
|
||||
|
||||
|
||||
mkdir -p library/lammpi
|
||||
mkdir -p library/matrix
|
||||
mkdir -p library/matlab
|
||||
mkdir -p library/mpi
|
||||
@ -1787,7 +1789,6 @@ mkdir -p library/regex
|
||||
mkdir -p library/system
|
||||
mkdir -p library/tries
|
||||
mkdir -p library/rltree
|
||||
mkdir -p library/lammpi
|
||||
mkdir -p library/yap2swi
|
||||
mkdir -p LGPL/clp
|
||||
mkdir -p LGPL/swi_console
|
||||
@ -1803,6 +1804,7 @@ mkdir -p packages/clpqr
|
||||
mkdir -p packages/cplint
|
||||
mkdir -p packages/cplint/approx
|
||||
mkdir -p packages/cplint/approx/simplecuddLPADs
|
||||
mkdir -p packages/http
|
||||
mkdir -p packages/jpl
|
||||
mkdir -p packages/jpl/src/java
|
||||
mkdir -p packages/jpl/src/java/jpl
|
||||
@ -1838,6 +1840,7 @@ AC_CONFIG_FILES([packages/clib/maildrop/rfc2045/Makefile])
|
||||
AC_CONFIG_FILES([packages/CLPBN/Makefile])
|
||||
AC_CONFIG_FILES([packages/cplint/Makefile])
|
||||
AC_CONFIG_FILES([packages/cplint/approx/simplecuddLPADs/Makefile])
|
||||
AC_CONFIG_FILES([packages/http/Makefile])
|
||||
AC_CONFIG_FILES([packages/PLStream/Makefile])
|
||||
AC_CONFIG_FILES([packages/plunit/Makefile])
|
||||
AC_CONFIG_FILES([packages/ProbLog/Makefile ])
|
||||
|
||||
792
packages/http/ChangeLog
Normal file
792
packages/http/ChangeLog
Normal file
@ -0,0 +1,792 @@
|
||||
[Sep 13 2009]
|
||||
|
||||
* ADDED: Process HTTP DELETE, OPTIONS and TRACE methods. Torbjörn Lager.
|
||||
|
||||
[Aug 27 2009]
|
||||
|
||||
* FIXED: JSON Mimetype handling. Matt Lilley.
|
||||
|
||||
[Aug 25 2009]
|
||||
|
||||
* ENHANCED: Made the detection of JSON more flexible.
|
||||
|
||||
* ENHANCED: JSON indentation handling. Matt Lilley.
|
||||
|
||||
[Aug 21 2009]
|
||||
|
||||
* ENHANCED: Bug#414: Get rid of pool/4 in HTTP request structures.
|
||||
Lourens van der Meij.
|
||||
|
||||
[Aug 18 2009]
|
||||
|
||||
* CLEANUP: Bug#413: Complete 'make distclean'. Feliks Kluzniak
|
||||
|
||||
[Aug 16 2009]
|
||||
|
||||
* DOC: Provide documentation of http_dispatch.pl through PlDoc
|
||||
|
||||
* ADDED: http_redirect/3 to simplify writing redirect handlers and enhance the reflexive capabilities of the HTTP server.
|
||||
|
||||
[Aug 14 2009]
|
||||
|
||||
* ADDED: Allow grouping of HTTP parameters
|
||||
|
||||
* ADDED: Support disjunctive types in HTTP parameter handling
|
||||
|
||||
* CLEANUP: Use meta_predicate for json_convert.pl
|
||||
|
||||
[Aug 13 2009]
|
||||
|
||||
* ADDED: type nonneg to http_parameters/3.
|
||||
|
||||
* ADDED: PlDoc wiki to handle references as module:name/arity.
|
||||
|
||||
* ADDED: Allow hooking http_parameters type checking and conversion.
|
||||
|
||||
* ADDED: &(Int) is written as &#Int; in html_write. Clarified the documentation.
|
||||
|
||||
* ADDED: Types list(Type), boolean and atom to http_parameters/3.
|
||||
|
||||
[Aug 12 2009]
|
||||
|
||||
* ENHANCED: Better handing of \[...] in cross-referencer
|
||||
|
||||
[Aug 10 2009]
|
||||
|
||||
* FIXED: Properly deal with external resources
|
||||
|
||||
* FIXED: Module-handling of body//1 and head//1 hooks in html_write.pl
|
||||
|
||||
* FIXED: Actually handle timout of the threaded HTTP deamon. The connection is now dropped after 60 seconds inactivity of the client.
|
||||
|
||||
* FIXED: HTTP server DoS if the clients sends an empty Cookie header.
|
||||
|
||||
[Jul 21 2009]
|
||||
|
||||
* MODIFIED: Make initialization/1 ISO compliant
|
||||
This patch is a modest cleanup to the implementation of '$load_file'/3
|
||||
from init.pl and provides an ISO compatible implementation of
|
||||
initialization/1. This executes the argument goal *after* loading the
|
||||
file rather than when encountering the directive. Often this makes no
|
||||
difference, but notably load_foreign_library/1 is an exception.
|
||||
Therefore we added use_foreign_library/1,2 that act as a directive and
|
||||
provides proper integration with saved-states automatically. Loading
|
||||
code using initialization(load_foreign_library(...)) will load the
|
||||
library immediately and issue a warning.
|
||||
|
||||
See initialization/1,2 for details and further hints for dealing with
|
||||
possible compatibility problems.
|
||||
[Jul 1 2009]
|
||||
|
||||
* ADDED: Allow \-escape inside html(\List).
|
||||
|
||||
* ADDED: Return the fact that a handler is a prefix handler in http_current_handler/3.
|
||||
|
||||
* ADDED: Allow for http_handler(root(find/concept), ...). I.e., allow for component/component without quotes,
|
||||
|
||||
[Jun 29 2009]
|
||||
|
||||
* FIXED: http_currect_session(-, ?) did not generate (all) sessions.
|
||||
|
||||
* ADDED: http_close_session/1
|
||||
|
||||
[Jun 23 2009]
|
||||
|
||||
* MODIFIED: Added option unsafe(Bool) to http_reply_file/3. This option is by default false, which causes this predicate to refuse serving files with an absolute path, a path outside the working directory or, if an alias(Path) is used, outside the root of the alias.
|
||||
If you want to serve such files, you must provide unsafe(true) explicitely.
|
||||
|
||||
* ADDED: Reply with 400 Bad Request on illegal HTTP requests
|
||||
|
||||
[Mar 19 2009]
|
||||
|
||||
* CLEANUP: Removed all trailing whitespace from all source-files. This avoids many GIT (merge) warnings.
|
||||
[Mar 12 2009]
|
||||
|
||||
* FIXED: Avoid race condition in session management. Jacco van Ossenbruggen.
|
||||
|
||||
* MODIFIED: Renamed concat_atom/2,3 into atomic_list_concat/2,3 for compatibility. Moved the old predicates into library(backcomp). It is adviced to update your code, but 99% of the code will remain working because the old definitions are autoloaded.
|
||||
|
||||
[Feb 27 2009]
|
||||
|
||||
* FIXED: http_current_server/2 was broken with meta_predicate introduction.
|
||||
|
||||
[Feb 25 2009]
|
||||
|
||||
* ENHANCED: Use a cache for http_in_session/1 to avoid repetitive access to the CGI stream object.
|
||||
|
||||
* FIXED: make http_current_request/1 semidet again. Added is_cgi_stream/1 for testing whether we are in a CGI context without raising an error.
|
||||
|
||||
[Feb 23 2009]
|
||||
|
||||
* ENHANCED: Allow the start broadcast-message of the HTTP server to throw an exception. This allows for defining additional policy-handlers as broadcast plugins.
|
||||
|
||||
[Feb 20 2009]
|
||||
|
||||
* ADDED: Use nlink property of stream to close the logfile
|
||||
|
||||
[Feb 15 2009]
|
||||
|
||||
* FIXED: Proper reply on partial content (use 206 reply; fix length computation)
|
||||
|
||||
[Feb 3 2009]
|
||||
|
||||
* ADDED: HTTP server support for byte-ranges of files.
|
||||
|
||||
* ADDED: Parsing of HTTP Range field into a structured term
|
||||
|
||||
[Jan 30 2009]
|
||||
|
||||
* ENHANCED: HTTP error handler in formulating replies from a file.
|
||||
|
||||
[Jan 29 2009]
|
||||
|
||||
* CLEANUP: be careful, but to not crash on unexpected event on CGI streams.
|
||||
|
||||
[Jan 28 2009]
|
||||
|
||||
* ADDED: When matching a prefix-path in http_dispatch, makethe remainder
|
||||
of the path available through path_info(PathInfo) in the request.
|
||||
|
||||
[Jan 22 2009]
|
||||
|
||||
* ADDED: http_in_session/1 to find the current session but do not raise an
|
||||
exception if it doesn't exist.
|
||||
|
||||
* ADDED: http_current_handler/3 to get access to accumulated options on a path
|
||||
|
||||
[Jan 20 2009]
|
||||
|
||||
* FIXED: ?- edit(HTTPLocation). Module-handling issue in locate/3 in http_dispatch.pl
|
||||
|
||||
* CLEANUP: http_wrapper.pl: PlDoc and meta-predicate handler
|
||||
|
||||
* FIXED: http_open/3: avoid leaking a socket-handle if the tcp_connect
|
||||
raises an exception.
|
||||
|
||||
[Jan 9 2009]
|
||||
|
||||
* ADDED: library(http/html_head), tracking CSS and Javascript dependencies and
|
||||
merging them automatically into the HTML <HEAD> element. Imported from
|
||||
Cliopatria project.
|
||||
[Dec 20 2008]
|
||||
|
||||
* ADDED: http_log_close/1 to provide for cooperation with logrotate
|
||||
|
||||
[Dec 18 2008]
|
||||
|
||||
* MSFIX: Accept invalid cookie options sent by Microsoft (httponly). Matt Lilley.
|
||||
[Nov 26 2008]
|
||||
|
||||
* FIXED: Update HTTP header definition for a token to RFC 2616. Matt Lilley
|
||||
[Oct 9 2008]
|
||||
|
||||
* ADDED: More flexible support for HTTP 503 (service unavailable) replies.
|
||||
|
||||
[Oct 8 2008]
|
||||
|
||||
* FIXED: drop body of HTTP 304 response
|
||||
|
||||
[Oct 7 2008]
|
||||
|
||||
* MODIFIED: Generalized the HTTP dispatch module authentication interface.
|
||||
* Instead of returning an atom representing the authenticated
|
||||
user, the hook must deliver a list of options that is added to
|
||||
the request. The new API allows for multiple authentication
|
||||
hooks on the same location. It is used by PlDoc to provide host
|
||||
access control. See doc_access.pl from the PlDoc package.
|
||||
|
||||
[Oct 6 2008]
|
||||
|
||||
* FIXED: Updated http_error to deal with new HTTP server
|
||||
|
||||
[Oct 5 2008]
|
||||
|
||||
* ADDED: Support http_path.pl specifications in http_handler/3.
|
||||
|
||||
* MODIFIED: library(http/http_dispatch): Handler changes.
|
||||
:- http_handler(prefix(Path), Action, Options) is now
|
||||
translated into http_handler(Path, Action, [prefix|Options]) with a
|
||||
warning. Future versions will drop the prefix(Path) syntax as it
|
||||
becomes ambiguous after integrating http_path.pl with the handler
|
||||
declarations.
|
||||
|
||||
* ADDED: html_write.pl: Support href(loc+[name1(value1),name2(value2)])
|
||||
|
||||
[Oct 3 2008]
|
||||
|
||||
* ADDED: Support encode(Value) and describe http location handling.
|
||||
|
||||
* ADDED: http_location_by_id/2 and location_by_id(ID) to html_write values.
|
||||
Suggested by Jacco van Ossenbruggen.
|
||||
|
||||
[Oct 2 2008]
|
||||
|
||||
* ADDED: Allow redefining the HTTP server address output of non-200 pages.
|
||||
|
||||
* ADDED: Provide hostname in http error messages
|
||||
|
||||
* FIXED: File descriptor leak in http session management.
|
||||
|
||||
[Oct 1 2008]
|
||||
|
||||
* FIXED: undefined parse_url_ex/3 in http_open.pl (deals with redirections)
|
||||
|
||||
[Sep 30 2008]
|
||||
|
||||
* ADDED: Support for proxy routes in HTTP session management. Also cleanup
|
||||
and additional tests in library(http/http_session).
|
||||
|
||||
[Sep 11 2008]
|
||||
|
||||
* PORT: Add AC_PREREQ to configure.h for systems that auto-select autoconf
|
||||
versions. After tip by Ulrich Neumerkel.
|
||||
|
||||
[Aug 30 2008]
|
||||
|
||||
* FIXED: use csym instead of csymf for valid HTTP fieldname characters. Edward Blake.
|
||||
|
||||
[Aug 11 2008]
|
||||
|
||||
* INSTALL: Remove all configure files from the git repository
|
||||
[Aug 5 2008]
|
||||
|
||||
* MODIFIED: http_read_request/3 throws error on illegal request and http_wrapper/5
|
||||
maps these to internal server errors.
|
||||
|
||||
* MODIFIED: http_open/3 now raises an error if the URL is not well-formed
|
||||
(used to fail silently).
|
||||
|
||||
[Jul 31 2008]
|
||||
|
||||
* FIXED: handling setting http:chunked_transfer(never). Yves Raimond.
|
||||
[Jul 3 2008]
|
||||
|
||||
* MODIFIED: Deleted the `after' option processing. Modern code can start a
|
||||
thread to deal with formulating a reply and start procesing after the reply
|
||||
has been sent.
|
||||
|
||||
[Jul 2 2008]
|
||||
|
||||
* ADDED: Support for HTTP 503 (service unavailable)
|
||||
|
||||
* ADDED: Support for options chunked and spawn in http_handler/3.
|
||||
|
||||
[Jun 27 2008]
|
||||
|
||||
* FIXED: Read JSON reply when using chunked encoding
|
||||
|
||||
* FIXED: Post header when using data in CGI format (used by JSON posts)
|
||||
|
||||
[Jun 25 2008]
|
||||
|
||||
* MODIFIED: http_get/3 using to(atom) or to(codes) perform UTF-8 decoding if
|
||||
the content type is declared as UTF-8.
|
||||
|
||||
[Jul 2 2008]
|
||||
|
||||
* ADDED: Bug#365: timeout support for the HTTP client library. Keri Harris.
|
||||
[Jun 16 2008]
|
||||
|
||||
* ENHANCED: Reduce HTTP header parsing time
|
||||
|
||||
* ENHANCED: Reduce overhead of deleting dead HTTP sessions
|
||||
|
||||
[May 21 2008]
|
||||
|
||||
* FIXED: atom_json_term(-,+,+): typo. Torbjörn Lager
|
||||
|
||||
[Apr 28 2008]
|
||||
|
||||
* ENHANCED: Perform a GC at the end of a communication with a client. Note that
|
||||
at that moment we have little active memory (=cheap GC), while otherwise we may
|
||||
remain idle for a long time with large stacks.
|
||||
[Apr 2 2008]
|
||||
|
||||
* FIXED: Throw an exception in illegal input wo json_write/3.
|
||||
|
||||
[Apr 1 2008]
|
||||
|
||||
* FIXED: Close the server socket in http_stop_server/2. John Stewart.
|
||||
|
||||
[Mar 28 2008]
|
||||
|
||||
* MODIFIED: html//1 interpretation of Module:Term. Previously this acted as
|
||||
\(Module:Term), now it acts as Module:html(Term), interpreting an entire
|
||||
specification relative to a module.
|
||||
|
||||
[Mar 20 2008]
|
||||
|
||||
* FIXED: Make HTTP status messages work when using the xhtml dialect
|
||||
|
||||
[Mar 10 2008]
|
||||
|
||||
* FIXED: HTTP accept loop to deal properly with termination
|
||||
|
||||
[Mar 9 2008]
|
||||
|
||||
* FIXED: Various issues around JSON booleans and null. Michiel Hildebrand.
|
||||
|
||||
[Feb 26 2008]
|
||||
|
||||
* FIXED: Avoid error on destroyed message queue in http_stop_server/3.
|
||||
Ferreira Maurizio.
|
||||
[Feb 8 2008]
|
||||
|
||||
* ADDED: Hook to expand HTML head material.
|
||||
|
||||
[Feb 7 2008]
|
||||
|
||||
* ADDED: html_receive//2 to allow for post-processing of posted messages
|
||||
|
||||
* MODIFIED: http_post//2 now executes embedded commands delayed.
|
||||
|
||||
[Feb 1 2008]
|
||||
|
||||
* FIXED: html_write.pl: avoid multiple receivers for xmlns.
|
||||
|
||||
[Jan 23 2008]
|
||||
|
||||
* PORT: Bug#346: Allow overriding COFLAGS and CWFLAGS in package
|
||||
configuration. Keri Harris.
|
||||
|
||||
[Jan 22 2008]
|
||||
|
||||
* DOC: Applied various patches. Item#272, Ulrich Neumerkel.
|
||||
|
||||
[Dec 22 2007]
|
||||
|
||||
* FIXED: Write JSON newlines always as \n. Also write all control characters
|
||||
that have no defined escape (< ' ') as \uXXXX. Michiel Hildebrand.
|
||||
|
||||
* FIXED: json_read/2 for strings holding double-quotes.
|
||||
|
||||
[Dec 18 2007]
|
||||
|
||||
* WORKAROUND: Emit no DOCTYPE header of the doctype is set to ''. This avoids
|
||||
a bug in Microsoft IE AJAX processing.
|
||||
|
||||
[Dec 16 2007]
|
||||
|
||||
* FIXED: recursive handling of lists in prolog_to_json/2. Michiel Hildebrand
|
||||
|
||||
[Dec 15 2007]
|
||||
|
||||
* FIXED: is_json_term/2 for pairs. Michiel Hildebrand.
|
||||
|
||||
[Dec 13 2007]
|
||||
|
||||
* ADDED: A predefined `head' receiver for http_post//2 and a predefined `xmlns'
|
||||
receiver used by xhtml_ns//2 to define XML namespaces in xhml mode. Clarified
|
||||
documentation of the html_write library with examples on how to deal with HTML
|
||||
head material.
|
||||
|
||||
[Dec 11 2007]
|
||||
|
||||
* DOC: various enhancement to the presentation of pldoc @keywords
|
||||
|
||||
[Dec 7 2007]
|
||||
|
||||
* MODIFIED: renamed library(http/http_chunked) to library(http/http_stream).
|
||||
Added range-limited streams
|
||||
|
||||
[Dec 5 2007]
|
||||
|
||||
* ADDED: library(http/http_json.pl), integrating JSON support into the
|
||||
HTTP libraries.
|
||||
|
||||
[Dec 4 2007]
|
||||
|
||||
* ADDED: library(http/json), providing (still incomplete) JSON support
|
||||
|
||||
[Nov 16 2007]
|
||||
|
||||
* ENHANCED: Bug#323: no longer force bgcolor=white in pagebody//1. Chris Sutton.
|
||||
|
||||
[Nov 9 2007]
|
||||
|
||||
* ADDED: type between(Low, High) for numerical values
|
||||
|
||||
[Nov 6 2007]
|
||||
|
||||
* ADDED: post/receive mechanism to modularize CSS and Javascript support in
|
||||
library(html_write). Documented using PlDoc LaTeX backend
|
||||
|
||||
Oct 1, 2007
|
||||
|
||||
* ADDED: http_stop_server/2 to stop a running HTTP server.
|
||||
|
||||
Sep 26, 2007
|
||||
|
||||
* ADDED: http_set_authorization/2 in library(http/http_open) to provide
|
||||
authorization defauls.
|
||||
|
||||
* ADDED: authorization(basic(User, Passowrd)) to the options of http_open/3.
|
||||
Now generates a permission error for common applicable 4xx errors.
|
||||
|
||||
Jun 21, 2007
|
||||
|
||||
* Avoid leaking stream handle in http_get/3 on chunked encoding.
|
||||
|
||||
Jun 20, 2007
|
||||
|
||||
* ENHANCED: Support chunked encoding in http_get/3 and http_post/4 on the
|
||||
new http_chunked library, reducing memory usage and overhead.
|
||||
|
||||
Jun 19, 2007
|
||||
|
||||
* ADDED: Support chunked encoding through library(http/http_open) based on
|
||||
new http_chunked library.
|
||||
|
||||
Jun 16, 2007
|
||||
|
||||
* ADDED: library(http/http_chunked).
|
||||
|
||||
Jun 7, 2007
|
||||
|
||||
* ADDED: http_dispatch and http_authenticate libraries.
|
||||
|
||||
Jun 1, 2007
|
||||
|
||||
* FIXED: Use new predicate_indicator frame attribute for safe error
|
||||
handling.
|
||||
|
||||
May 23, 2007
|
||||
|
||||
* FIXED: Preserve extra request-headers over redirect. Yves Raimond.
|
||||
|
||||
May 20, 2007
|
||||
|
||||
* FIXED: redirection issues. Yves Raimond.
|
||||
|
||||
Apr 12, 2007
|
||||
|
||||
* ADDED: .svg to mimetypes
|
||||
|
||||
Apr 10, 2007
|
||||
|
||||
* FIXED: Forcing UTF-8 character set.
|
||||
|
||||
Mar 22, 2007
|
||||
|
||||
* FIXED: Bug#269: time-stamp was emitted in current locale.
|
||||
|
||||
Mar 19, 2007
|
||||
|
||||
* ADDED: Include name of parameter in type-errors detected by
|
||||
http_parameters/2.
|
||||
|
||||
Mar 15, 2007
|
||||
|
||||
* ADDED: Include peer in session management for better security.
|
||||
* ADDED: Broadcast session start/end to allow deletion of derived
|
||||
data.
|
||||
|
||||
Mar 11, 2007
|
||||
|
||||
* FIXED: http_open/3: send Host: <host>:<port> if port is not 80.
|
||||
|
||||
Mar 9, 2007
|
||||
|
||||
* ADDED: reply_html_page/2. To be documented
|
||||
|
||||
* ADDED: Pass protocol(http/https) into request.
|
||||
|
||||
Mar 7, 2007
|
||||
|
||||
* FIXED: handle throw(http_reply(moved_temporary(URL))) properly.
|
||||
|
||||
Mar 6, 2007
|
||||
|
||||
* ADDED: final_url option to http_open/3
|
||||
|
||||
Mar 5, 2007
|
||||
|
||||
* MODIFIED: debug(header, ...) --> debug(http(header), ...)
|
||||
|
||||
* ADDED: codes([Type], Codes) to http_post_data.
|
||||
|
||||
Feb 26, 2007
|
||||
|
||||
* ADDED: Keep connections open on not_modified and replying files.
|
||||
|
||||
Feb 9, 2007
|
||||
|
||||
* ADDED: Support for 302 (moved temporary) HTTP replies to the server.
|
||||
|
||||
Feb 8, 2007
|
||||
|
||||
* ADDED: Map existence_error(http_location, URL) and
|
||||
permission_error(http_location, access, URL) to appropriate HTTP
|
||||
headers.
|
||||
|
||||
Feb 2, 2007
|
||||
|
||||
* ADDED: Report status of stopped worker.
|
||||
|
||||
Jan 24, 2007
|
||||
|
||||
* ADDED: Support for 303 (see other) HTTP replies to the server.
|
||||
Yves Raimond.
|
||||
|
||||
Jan 18, 2007
|
||||
|
||||
* ADDED: html_set_options/1 and html_current_option/1 to html_write.pl.
|
||||
Allows for changing the document type as well as writing XHTML output
|
||||
from the same DCG rules.
|
||||
|
||||
Jan 15, 2007
|
||||
|
||||
* ADDED: Redirect support for 301 and 303. Yves Raimond.
|
||||
|
||||
Dec 13, 2006
|
||||
|
||||
* FIXED: avoid passing reply_header option to convert hooks (conflict
|
||||
with SGML plugin).
|
||||
|
||||
Dec 12, 2006
|
||||
|
||||
* FIXED: Properly close sockets on errors in http_open/3.
|
||||
|
||||
Dec 8, 2006
|
||||
|
||||
* ADDED: support for HEAD to http_open/3.
|
||||
|
||||
Oct 31, 2006
|
||||
|
||||
* ENHANCED: Documentation
|
||||
|
||||
Oct 30, 2006
|
||||
|
||||
* ADDED: Allow for A+B in attribute values.
|
||||
|
||||
Sep 18, 2006
|
||||
|
||||
* FIXED: inetd_httpd: set stream encoding to octet to be able to handle
|
||||
binary data. Nicos Angelopoulos.
|
||||
|
||||
Aug 21, 2006
|
||||
|
||||
* FIXED: Quote & inside attribute values.
|
||||
|
||||
Aug 10, 2006
|
||||
|
||||
* ENHANCED: Time printing in http_header.pl to use format_time/3. Faster
|
||||
and proper implementation of daylight saving time.
|
||||
|
||||
Aug 8, 2006
|
||||
|
||||
* FIXED: http_relative_path/2.
|
||||
|
||||
Aug 7, 2006
|
||||
|
||||
* DEBUG: Do not generate debug info for library html_write.pl, as it makes
|
||||
code using the library very hard to debug.
|
||||
|
||||
Jun 30, 2006
|
||||
|
||||
* FIXED: dangling choicepoint in http_open/3.
|
||||
|
||||
* ADDED: zero_or_more as parameter option to http_parameters/[2,3]
|
||||
|
||||
Apr 11, 2006
|
||||
|
||||
* ADDED: http_parameters library
|
||||
|
||||
* FIXED: properly handle the server closing the connection if the connection
|
||||
is specified as Keep-alive in the client (http_get/3 and http_post/4).
|
||||
|
||||
Feb 24, 2006
|
||||
|
||||
* Added http_error.pl to generate nice looking stack-traces.
|
||||
|
||||
Feb 23, 2006
|
||||
|
||||
* Added http_session.pl and http:request_expansion/2 hook.
|
||||
|
||||
Feb 16, 2006
|
||||
|
||||
* Added http_current_request/1 to get access to the currently executing
|
||||
request.
|
||||
|
||||
Feb 10, 2006
|
||||
|
||||
* Make http_post deal with Unicode data.
|
||||
|
||||
Jan 20, 2006
|
||||
|
||||
* Map Host: <host>:<port> into host(Host), port(Port) when reading
|
||||
HTTP requests.
|
||||
|
||||
Jan 16, 2006
|
||||
|
||||
* Fixed redirect handling if the option to(Stream) is given.
|
||||
Jacco van Ossenbruggen.
|
||||
|
||||
Jan 11, 2006
|
||||
|
||||
* Added: handling of 302 redirect messages in http_get/3.
|
||||
* Fix http_get/3 with sgml plugin and proxy option. Usenet, `mans'.
|
||||
|
||||
Dec 10, 2005
|
||||
|
||||
* Enhanced robustness of the server to malicious clients by using
|
||||
call_cleanup wrappers around the code doing the actual reply. Old
|
||||
code lead to memory and file-descriptor leaking.
|
||||
|
||||
Dec 7, 2005
|
||||
|
||||
* Added http_timestamp/2 to http_header.pl. Also changed the time
|
||||
representation to be compatible to the current RFC1132 standard.
|
||||
|
||||
Nov 16, 2005
|
||||
|
||||
* Avoid XPCE http servers to be garbage collected.
|
||||
|
||||
Oct 17, 2005
|
||||
|
||||
* ADDED: Pass peer from threaded HTTP server to request.
|
||||
|
||||
* ENHANCED: Use UTF-8 encoding for text by default.
|
||||
|
||||
Sep 28, 2005
|
||||
|
||||
* FIXED: Regular expressions in xpce_httpd frontend. Wouter Jansweijer.
|
||||
|
||||
Sep 23, 2005
|
||||
|
||||
* ADDED: .class to mimetypes.pl.
|
||||
|
||||
Sep 7, 2005
|
||||
|
||||
* FIXED: handle connection error in http_get/3 gracefully.
|
||||
|
||||
Sep 6, 2005
|
||||
|
||||
* FIXED: handle error in tcp_accept/3 gracefully.
|
||||
|
||||
Sep 5, 2005
|
||||
|
||||
* ADDED: method(head) --> "HEAD". Matt Lilley.
|
||||
|
||||
Apr 26, 2005
|
||||
|
||||
* ADDED: debug(sgml_plugin) and some missing use_module calls. Simplifies
|
||||
debugging automatic conversion.
|
||||
|
||||
Mar 4, 2005
|
||||
|
||||
* FIXED: Bug#24: open files binary. Fabien Todescato.
|
||||
|
||||
Feb 11, 2005
|
||||
|
||||
* FIXED: empy header field eats next line as value. Chris Ritchey.
|
||||
|
||||
Jan 4, 2005
|
||||
|
||||
* FIXED: Bug#2: Disconnect from POST replies.
|
||||
|
||||
Sep 23, 2004
|
||||
|
||||
* FIXED: Ignore minor types when deciding which plugin to use for the
|
||||
SGML plugin.
|
||||
|
||||
Aug 30, 2004
|
||||
|
||||
* FIXED: Bug#179: Avoid XPCE dependency on strip_module/3. Sandro Hawke.
|
||||
|
||||
Aug 16, 2004
|
||||
|
||||
* FIXED: Remove " from boundary=... HTTP-POST requests. Appears necessary
|
||||
for posting to Tomcat servers. Also added explicit MIME-Version: 1.0
|
||||
to the header.
|
||||
|
||||
Aug 12, 2004
|
||||
|
||||
* ADDED: form_data(+List) alternative to http_post/4.
|
||||
|
||||
* ADDED: option reply_header(-Header) to get the full replied header for
|
||||
GET and POST methods. Also added decoding of the SetCookie field.
|
||||
|
||||
Aug 5, 2004
|
||||
|
||||
* ADDED: request_header(Name=Value) to http_open/3
|
||||
|
||||
Aug 3, 2004
|
||||
|
||||
* ADDED: keep_alive_timeout(Seconds) for multi-threaded server.
|
||||
|
||||
* FIXED: remove choicepoints in http_open/3
|
||||
|
||||
Jul 31, 2004
|
||||
|
||||
* ADDED: http_current_worker/2
|
||||
|
||||
Jul 30, 2004
|
||||
|
||||
* ADDED: Allow explicit head and body in page//1 and page//2
|
||||
|
||||
Jul 21, 2004
|
||||
|
||||
* FIXED: Bug#166: Allow alternative responses (Sandro Hawke).
|
||||
|
||||
* FIXED: Bug#168: Close connection on timeout (Sandro Hawke).
|
||||
|
||||
* FIXED: Bug#165: Added reuseaddr (Sandro Hawke).
|
||||
|
||||
Jul 18, 2004
|
||||
|
||||
* ENHANCED: handle `normal' errors silent (David Reitter)
|
||||
|
||||
Jun 28, 2004
|
||||
|
||||
* ENHANCED: print server errors and continue
|
||||
|
||||
* ADDED: SSL interface to threaded HTTP server
|
||||
|
||||
Jun 21, 2004
|
||||
|
||||
* FIXED: Handling continue header required for POST to MS IIS servers.
|
||||
Also more patches sending \r\n where required. With patches from
|
||||
Mike Elston.
|
||||
|
||||
Jun 16, 2004
|
||||
|
||||
* FIXED: make HTTP client library write header line terminate with
|
||||
\r\n. Mike Elston.
|
||||
|
||||
Jun 15, 2004
|
||||
|
||||
* FIXED: Undefined predicate strip_module/2 in thread_httpd.pl when
|
||||
there is no access to XPCE. Dmitry.
|
||||
|
||||
* ADDED: request_header(Name=Value) option to the option list of
|
||||
http_get/3 and http_post/4 for adding user request fields.
|
||||
|
||||
* ADDED: Map body throw(status(not_modified)) onto a "304 Not Modified"
|
||||
page. Mike Elston.
|
||||
|
||||
May 20, 2003
|
||||
|
||||
* DOCS: Documented http_post_data/3
|
||||
|
||||
* ADDED: form([Name=Value, ...]) input type to http_post_data/3
|
||||
|
||||
May 12, 2003
|
||||
|
||||
* FIXED: problem in mime_pack/3 using Name=Value
|
||||
|
||||
Mar 4, 2003
|
||||
|
||||
* ADDED: http_open/3: header(+Name, -Value) option. Wouter
|
||||
Jansweijer.
|
||||
|
||||
Jan 23, 2003
|
||||
|
||||
* ADDED: Provide User-Agent header for the client libraries
|
||||
|
||||
Jan 8, 2003
|
||||
|
||||
* ADDED: Support for using proxy servers Option: proxy(Host, Port).
|
||||
|
||||
* ADDED: Support for 302 (document moved) reply in http_open/3.
|
||||
|
||||
223
packages/http/Makefile.in
Normal file
223
packages/http/Makefile.in
Normal file
@ -0,0 +1,223 @@
|
||||
################################################################
|
||||
# SWI-Prolog `HTTP' package
|
||||
# Author: Jan Wielemaker. J.Wielemaker@cs.vu.nl
|
||||
# Copyright: GPL (see COPYING or www.gnu.org
|
||||
################################################################
|
||||
|
||||
.SUFFIXES: .txt .tex .dvi .doc .pl
|
||||
|
||||
ifeq (@PROLOG_SYSTEM@,yap)
|
||||
|
||||
prefix = @prefix@
|
||||
exec_prefix = @exec_prefix@
|
||||
ROOTDIR = $(prefix)
|
||||
EROOTDIR = @exec_prefix@
|
||||
abs_top_builddir = @abs_top_builddir@
|
||||
|
||||
srcdir=@srcdir@
|
||||
|
||||
BINDIR = $(EROOTDIR)/bin
|
||||
LIBDIR=@libdir@
|
||||
YAPLIBDIR=@libdir@/Yap
|
||||
SHAREDIR=$(ROOTDIR)/share/Yap
|
||||
|
||||
SHELL=@SHELL@
|
||||
PL=@INSTALL_ENV@ $(DESTDIR)$(BINDIR)/yap $(DESTDIR)$(YAPLIBDIR)/startup.yss
|
||||
EXDIR=$(YAPLIBDIR)/examples/http
|
||||
LN_S=@LN_S@
|
||||
#
|
||||
#
|
||||
CC=@CC@
|
||||
CFLAGS= @SHLIB_CFLAGS@ $(YAP_EXTRAS) $(DEFS) -D_YAP_NOT_INSTALLED_=1 -I$(srcdir) -I../.. -I$(srcdir)/../../include @CPPFLAGS@
|
||||
MKINDEX=true
|
||||
|
||||
|
||||
SO=@SO@
|
||||
#4.1VPATH=@srcdir@:@srcdir@/OPTYap
|
||||
CWD=$(PWD)
|
||||
#
|
||||
|
||||
LD=@DO_SECOND_LD@ @SHLIB_CXX_LD@
|
||||
LDFLAGS=@EXTRA_LIBS_FOR_SWIDLLS@
|
||||
|
||||
BINTARGET=$(DESTDIR)$(YAPLIBDIR)
|
||||
PLTARGET=$(DESTDIR)$(SHAREDIR)/http
|
||||
|
||||
FINAL_BINTARGET=$(YAPLIBDIR)
|
||||
FINAL_PLTARGET=$(SHAREDIR)
|
||||
|
||||
%.o: $(srcdir)/%.c
|
||||
$(CC) -c $(CFLAGS) $< -o $@
|
||||
|
||||
else # SWI
|
||||
|
||||
SHELL=@SHELL@
|
||||
PLBASE=@PLBASE@
|
||||
PLARCH=@PLARCH@
|
||||
PL=@PL@
|
||||
XPCEBASE=$(PLBASE)/xpce
|
||||
PKGDOC=$(PLBASE)/doc/packages
|
||||
PCEHOME=../xpce
|
||||
LIBDIR=$(PLBASE)/library/http
|
||||
EXDIR=$(PKGDOC)/examples/http
|
||||
|
||||
CC=@CC@
|
||||
COFLAGS=@COFLAGS@
|
||||
CWFLAGS=@CWFLAGS@
|
||||
CMFLAGS=@CMFLAGS@
|
||||
CIFLAGS=
|
||||
CFLAGS=$(COFLAGS) $(CWFLAGS) $(CMFLAGS) $(CIFLAGS) @DEFS@
|
||||
LIBS=@LIBS@
|
||||
LD=@LD@
|
||||
LDFLAGS=@LDSOFLAGS@
|
||||
|
||||
PUBLICPL=swipl
|
||||
DOCTOTEX=$(PCEHOME)/bin/doc2tex
|
||||
PLTOTEX=$(PUBLICPL) -q -s pltotex.pl -g pltotex --
|
||||
RUNTEX=../../man/runtex
|
||||
LATEX=latex
|
||||
DOC=http
|
||||
TEX=$(DOC).tex
|
||||
DVI=$(DOC).dvi
|
||||
PDF=$(DOC).pdf
|
||||
HTML=$(DOC).html
|
||||
|
||||
endif
|
||||
|
||||
INSTALL=@INSTALL@
|
||||
INSTALL_PROGRAM=@INSTALL_PROGRAM@
|
||||
INSTALL_DATA=@INSTALL_DATA@
|
||||
|
||||
include $(srcdir)/common.mk
|
||||
|
||||
STREAMOBJ= http_stream.o
|
||||
JSONOBJ= json.o
|
||||
SOLIBS= http_stream.@SO@ json.@SO@
|
||||
|
||||
all: $(SOLIBS)
|
||||
|
||||
|
||||
http_stream.@SO@: $(STREAMOBJ)
|
||||
$(LD) $(LDFLAGS) -o $@ $(STREAMOBJ) $(LIBS)
|
||||
json.@SO@: $(JSONOBJ)
|
||||
$(LD) $(LDFLAGS) -o $@ $(JSONOBJ) $(LIBS)
|
||||
|
||||
http_stream.o: $(srcdir)/http_error.c $(srcdir)/http_chunked.c $(srcdir)/cgi_stream.c $(srcdir)/stream_range.c
|
||||
|
||||
install: $(LIBPL)
|
||||
mkdir -p $(BINTARGET)
|
||||
rm -f $(BINTARGET)/http_chunked.@SO@
|
||||
$(INSTALL_PROGRAM) $(SOLIBS) $(BINTARGET)
|
||||
mkdir -p $(PLTARGET)
|
||||
mkdir -p $(PLTARGET)/web/icons
|
||||
mkdir -p $(LIBDIR)/web/css
|
||||
$(INSTALL_DATA) $(LIBPL) $(PLTARGET)
|
||||
$(INSTALL_DATA) $(srcdir)/README $(PLTARGET)
|
||||
$(INSTALL_DATA) $(srcdir)/web/icons/*.png $(PLTARGET)/web/icons
|
||||
$(INSTALL_DATA) $(srcdir)/web/css/*.css $(DESTDIR)$(LIBDIR)/web/css
|
||||
$(PL) -f none -g make -t halt
|
||||
|
||||
ln-install: $(LIBPL)
|
||||
$(MAKE) INSTALL_DATA="../ln-install" INSTALL_PROGRAM="../ln-install" install
|
||||
|
||||
rpm-install: install
|
||||
|
||||
pdf-install: install-examples
|
||||
$(INSTALL_DATA) $(DOC).pdf $(DESTDIR)$(PKGDOC)
|
||||
|
||||
html-install: install-examples
|
||||
$(INSTALL_DATA) $(DOC).html httpserver.gif $(DESTDIR)$(PKGDOC)
|
||||
|
||||
install-examples::
|
||||
mkdir -p $(DESTDIR)$(EXDIR)
|
||||
mkdir -p $(DESTDIR)$(EXDIR)/pwp
|
||||
(cd examples && $(INSTALL_DATA) $(EXAMPLES) $(DESTDIR)$(EXDIR))
|
||||
(cd examples/pwp && $(INSTALL_DATA) *.pwp *.pl $(DESTDIR)$(EXDIR)/pwp)
|
||||
(cd examples && $(INSTALL_PROGRAM) $(EXAMPLEEXE) $(DESTDIR)$(EXDIR))
|
||||
|
||||
uninstall::
|
||||
(cd $(LIBDIR) && rm -f $(LIBPL))
|
||||
$(PL) -f none -g make -t halt
|
||||
|
||||
check::
|
||||
$(PL) -q -f $(srcdir)/test_http.pl -g test_http,halt -t 'halt(1)'
|
||||
$(PL) -q -f $(srcdir)/test_json.pl -g test_json,halt -t 'halt(1)'
|
||||
$(PL) -q -f $(srcdir)/test_cgi_stream.pl -g true -t test_cgi_stream
|
||||
|
||||
################################################################
|
||||
# Documentation
|
||||
################################################################
|
||||
|
||||
doc: $(PDF) $(HTML)
|
||||
pdf: $(PDF)
|
||||
html: $(HTML)
|
||||
|
||||
SUBTEX= post.tex json.tex httplog.tex httppath.tex htmlhead.tex \
|
||||
httpsession.tex httpdispatch.tex httpdirindex.tex httppwp.tex \
|
||||
httpopen.tex httphost.tex httpopenid.tex jswrite.tex
|
||||
|
||||
$(HTML): $(TEX) $(SUBTEX)
|
||||
latex2html $(DOC)
|
||||
mv html/index.html $@
|
||||
mv html/httpserver.gif .
|
||||
rmdir html
|
||||
|
||||
$(PDF): $(TEX) $(SUBTEX)
|
||||
$(RUNTEX) --pdf $(DOC)
|
||||
|
||||
$(TEX): $(DOCTOTEX)
|
||||
|
||||
json.tex: json.pl json_convert.pl http_json.pl
|
||||
|
||||
.txt.tex:
|
||||
$(PUBLICPL) -q -s txttotex.pl -g txttotex,halt -t 'halt(1)' -- $*.txt
|
||||
|
||||
httplog.tex: http_log.pl
|
||||
$(PLTOTEX) --subsection 'library(http/http_log)'
|
||||
|
||||
httphost.tex: http_host.pl
|
||||
$(PLTOTEX) --subsection 'library(http/http_host)'
|
||||
|
||||
httppath.tex: http_path.pl
|
||||
$(PLTOTEX) --subsection 'library(http/http_path)'
|
||||
|
||||
httpopen.tex: http_open.pl
|
||||
$(PLTOTEX) --subsection 'library(http/http_open)'
|
||||
|
||||
htmlhead.tex: html_head.pl
|
||||
$(PLTOTEX) --subsection 'library(http/html_head)'
|
||||
|
||||
httpsession.tex: http_session.pl
|
||||
$(PLTOTEX) --subsection 'library(http/http_session)'
|
||||
|
||||
httpdispatch.tex: http_dispatch.pl
|
||||
$(PLTOTEX) --subsection 'library(http/http_dispatch)'
|
||||
|
||||
httpopenid.tex: http_openid.pl
|
||||
$(PLTOTEX) --subsection 'library(http/http_openid)'
|
||||
|
||||
httpdirindex.tex: http_dirindex.pl
|
||||
$(PLTOTEX) --subsection 'library(http/http_dirindex)'
|
||||
|
||||
httppwp.tex: http_pwp.pl
|
||||
$(PLTOTEX) --subsection 'library(http/http_pwp)'
|
||||
|
||||
jswrite.tex: js_write.pl
|
||||
$(PLTOTEX) --subsection 'library(http/js_write)'
|
||||
|
||||
.doc.tex:
|
||||
$(DOCTOTEX) $*.doc > $*.tex
|
||||
|
||||
################################################################
|
||||
# Clean
|
||||
################################################################
|
||||
|
||||
clean:
|
||||
rm -f $(STREAMOBJ) $(JSONOBJ)
|
||||
rm -f *~ *% config.log
|
||||
rm -f $(TEX) $(SUBTEX)
|
||||
$(RUNTEX) --clean $(DOC)
|
||||
rm -rf html
|
||||
|
||||
distclean: clean
|
||||
rm -f $(SOLIBS) config.cache config.status config.h Makefile
|
||||
82
packages/http/Makefile.mak
Normal file
82
packages/http/Makefile.mak
Normal file
@ -0,0 +1,82 @@
|
||||
################################################################
|
||||
# Install the SWI-Prolog HTTP package for MS-Windows
|
||||
#
|
||||
# Author: Jan Wielemaker
|
||||
#
|
||||
# Use:
|
||||
# nmake /f Makefile.mak
|
||||
# nmake /f Makefile.mak install
|
||||
################################################################
|
||||
|
||||
PLHOME=..\..
|
||||
!include $(PLHOME)\src\rules.mk
|
||||
!include common.mk
|
||||
|
||||
LIBDIR= $(PLBASE)\library\http
|
||||
EXDIR= $(PKGDOC)\examples\http
|
||||
|
||||
OBJ= http_stream.obj
|
||||
|
||||
all: http_stream.dll json.dll
|
||||
|
||||
http_stream.dll: $(OBJ)
|
||||
$(LD) /dll /out:$@ $(LDFLAGS) $(OBJ) $(PLLIB) $(LIBS)
|
||||
json.dll: json.obj
|
||||
$(LD) /dll /out:$@ $(LDFLAGS) json.obj $(PLLIB) $(LIBS)
|
||||
|
||||
http_stream.obj: http_error.c http_chunked.c cgi_stream.c stream_range.c
|
||||
|
||||
all:
|
||||
|
||||
!IF "$(CFG)" == "rt"
|
||||
install::
|
||||
!ELSE
|
||||
install::
|
||||
if not exist "$(LIBDIR)\$(NULL)" $(MKDIR) "$(LIBDIR)"
|
||||
if not exist "$(LIBDIR)\web\$(NULL)" $(MKDIR) "$(LIBDIR)\web"
|
||||
if not exist "$(LIBDIR)\web\icons\$(NULL)" $(MKDIR) "$(LIBDIR)\web\icons"
|
||||
if not exist "$(LIBDIR)\web\css\$(NULL)" $(MKDIR) "$(LIBDIR)\web\css"
|
||||
@echo Copying $(LIBPL)
|
||||
@for %f in ($(LIBPL)) do @copy %f "$(LIBDIR)"
|
||||
copy README "$(LIBDIR)\README.TXT"
|
||||
copy web\icons\*.* "$(LIBDIR)\web\icons"
|
||||
copy web\css\*.* "$(LIBDIR)\web\css"
|
||||
copy http_stream.dll "$(BINDIR)"
|
||||
copy json.dll "$(BINDIR)"
|
||||
!IF "$(PDB)" == "true"
|
||||
copy http_stream.pdb "$(BINDIR)"
|
||||
copy json.pdb "$(BINDIR)"
|
||||
!ENDIF
|
||||
$(MAKEINDEX)
|
||||
!ENDIF
|
||||
|
||||
html-install: install-examples
|
||||
copy http.html "$(PKGDOC)"
|
||||
copy httpserver.gif "$(PKGDOC)"
|
||||
|
||||
pdf-install: install-examples
|
||||
copy http.pdf "$(PKGDOC)"
|
||||
|
||||
install-examples::
|
||||
if not exist "$(EXDIR)\$(NULL)" $(MKDIR) "$(EXDIR)"
|
||||
if not exist "$(EXDIR)\pwp\$(NULL)" $(MKDIR) "$(EXDIR)\pwp"
|
||||
cd examples & @for %f in ($(EXAMPLES)) do @copy %f "$(EXDIR)"
|
||||
cd examples & copy $(EXAMPLEEXE) "$(EXDIR)"
|
||||
cd examples & copy pwp\*.* "$(EXDIR)\pwp"
|
||||
|
||||
xpce-install::
|
||||
|
||||
uninstall::
|
||||
cd $(LIBDIR) & del $(LIBPL) README.TXT
|
||||
del "$(BINDIR)\http_stream.dll"
|
||||
$(MAKEINDEX)
|
||||
|
||||
clean::
|
||||
if exist *~ del *~
|
||||
if exist *.obj del *.obj
|
||||
|
||||
distclean: clean
|
||||
if exist *.dll del *.dll
|
||||
if exist *.pdb del *.pdb
|
||||
|
||||
|
||||
18
packages/http/README
Normal file
18
packages/http/README
Normal file
@ -0,0 +1,18 @@
|
||||
---+ SWI-Prolog HTTP support library
|
||||
|
||||
This directory provides the SWI-Prolog libraries for accessing and
|
||||
providing HTTP services. The client libraries come in two forms:
|
||||
|
||||
* The lightweight http_open.pl opens an HTTP location as a stream
|
||||
* The more full-blown http_client.pl performs arbitrary HTTP
|
||||
requests and, depending on loaded plugins, transforms the data
|
||||
in a Prolog-friendly format.
|
||||
|
||||
The primary server-library is thread_httpd.pl, providing full-blown
|
||||
scalable embedded HTTP server.
|
||||
|
||||
---++ Further reading
|
||||
|
||||
* ../../packages/http.pdf
|
||||
* ../../packages/examples/http contains some demos.
|
||||
* http://www.swi-prolog.org/packages/http.html
|
||||
25
packages/http/TODO
Normal file
25
packages/http/TODO
Normal file
@ -0,0 +1,25 @@
|
||||
---+ HTTP Server library todo list
|
||||
|
||||
---++ Session handling
|
||||
|
||||
Especially now that we store the current request as a record in the CGI
|
||||
stream, it is now much too expensive to get the current session. How to
|
||||
deal with that? Also store in the CGI object?
|
||||
|
||||
---++ Debugging
|
||||
|
||||
We plan to provide a in-core store for requests with predicates that
|
||||
control what requests are stored. This allows for showing the requests
|
||||
as well as replaying requests from the user-thread for easy debugging.
|
||||
|
||||
Can we deal with HTTP POST requests?
|
||||
|
||||
---++ JSON integration
|
||||
|
||||
JavaScript Simple Object Notation is a simple and lightweight exchange
|
||||
protocol for structured data. Support for it is progressing, with the
|
||||
following items on our todo list.
|
||||
|
||||
* Hook json_convert.pl into json.pl
|
||||
* Deal with nested objects in conversion
|
||||
* Documentation.
|
||||
745
packages/http/cgi_stream.c
Normal file
745
packages/http/cgi_stream.c
Normal file
@ -0,0 +1,745 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2009, University of Amsterdam
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
This library is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
*/
|
||||
|
||||
#include <SWI-Stream.h>
|
||||
#include <SWI-Prolog.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
The task of cgi_stream.c is to interface between the actual wrapper code
|
||||
that implements an HTTP location and the socket sending a reply to the
|
||||
client. In particular, we want to deal with:
|
||||
|
||||
* Separating the header from the body of the reply
|
||||
* Chunked or traditional transfer encoding
|
||||
* Connection management (Keep-alife)
|
||||
* Thread management
|
||||
|
||||
The original HTTP infrastructure has an `accept thread' that accepts new
|
||||
connections. The connection is handed to a thread that reads the HTTP
|
||||
header and calls a handler with the output redirected to a memory file,
|
||||
processing the reply-header and reply-data after the handler finished.
|
||||
This is a clean and modular design, but it cannot deal with especially
|
||||
chunked encoding and thread management. This module remedies these
|
||||
issues.
|
||||
|
||||
To do this, the stream provides a three call-backs. Initially, the
|
||||
stream is in line-buffering mode (SIO_LBUF), waiting for the header to
|
||||
become complete. At that moment it calls the hook, passing event type
|
||||
'header' and the stream. This processes the head and combines the head
|
||||
with the request, deciding on:
|
||||
|
||||
* The final header
|
||||
* The transfer encoding (chunked/none)
|
||||
* The content encoding (octet/utf8)
|
||||
* The connection (Keep-Alife/close)
|
||||
|
||||
Now, the stream is placed in full buffering mode (SIO_FBUF). If the
|
||||
transfer encoding is 'chunked' it immediately calls the hook using
|
||||
'send_header' to emit the current header. Output continues. In chunked
|
||||
mode sending the chunks, otherwisse collecting the data. On close, it
|
||||
writes an empty block (chunked mode) or (normal mode) calls the hook
|
||||
'send_header' which now has access to the content-length, followed by
|
||||
the data.
|
||||
|
||||
Note that the work-flow is kept with the stream. This allows passing the
|
||||
cgi stream from thread to thread while keeping track of the work-flow.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
TODO
|
||||
|
||||
* Error handling (many places)
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
|
||||
/*******************************
|
||||
* CONSTANTS *
|
||||
*******************************/
|
||||
|
||||
static atom_t ATOM_header; /* header */
|
||||
static atom_t ATOM_header_codes; /* header_codes */
|
||||
static atom_t ATOM_send_header; /* send_header */
|
||||
static atom_t ATOM_data; /* data */
|
||||
static atom_t ATOM_discarded; /* discarded */
|
||||
static atom_t ATOM_request; /* request */
|
||||
static atom_t ATOM_client; /* client */
|
||||
static atom_t ATOM_chunked; /* chunked */
|
||||
static atom_t ATOM_none; /* none */
|
||||
static atom_t ATOM_state; /* state */
|
||||
static atom_t ATOM_transfer_encoding; /* transfer_encoding */
|
||||
static atom_t ATOM_connection; /* connection */
|
||||
static atom_t ATOM_keep_alife; /* keep_alife */
|
||||
static atom_t ATOM_close; /* close */
|
||||
static atom_t ATOM_content_length; /* content_length */
|
||||
static atom_t ATOM_id; /* id */
|
||||
static predicate_t PREDICATE_call3; /* Goal, Event, Handle */
|
||||
|
||||
|
||||
/*******************************
|
||||
* CONTEXT *
|
||||
*******************************/
|
||||
|
||||
#define BUFSIZE SIO_BUFSIZE /* raw I/O buffer */
|
||||
|
||||
typedef enum
|
||||
{ CGI_HDR = 0,
|
||||
CGI_DATA,
|
||||
CGI_DISCARDED
|
||||
} cgi_state;
|
||||
|
||||
#define CGI_MAGIC 0xa85ce042
|
||||
|
||||
typedef struct cgi_context
|
||||
{ IOSTREAM *stream; /* Original stream */
|
||||
IOSTREAM *cgi_stream; /* Stream I'm handle of */
|
||||
IOENC parent_encoding; /* Saved encoding of parent */
|
||||
/* Prolog attributes */
|
||||
module_t module; /* Calling module */
|
||||
record_t hook; /* Hook called on action */
|
||||
record_t request; /* Associated request term */
|
||||
record_t header; /* Associated reply header term */
|
||||
atom_t transfer_encoding; /* Current transfer encoding */
|
||||
atom_t connection; /* Keep alife? */
|
||||
/* state */
|
||||
cgi_state state; /* Current state */
|
||||
/* data buffering */
|
||||
size_t data_offset; /* Start of real data */
|
||||
char *data; /* Buffered data */
|
||||
size_t datasize; /* #bytes buffered */
|
||||
size_t dataallocated; /* #bytes allocated */
|
||||
int id; /* Identifier */
|
||||
unsigned int magic; /* CGI_MAGIC */
|
||||
} cgi_context;
|
||||
|
||||
|
||||
static int start_chunked_encoding(cgi_context *ctx);
|
||||
static ssize_t cgi_chunked_write(cgi_context *ctx, char *buf, size_t size);
|
||||
|
||||
|
||||
/*******************************
|
||||
* ALLOC/FREE *
|
||||
*******************************/
|
||||
|
||||
static cgi_context*
|
||||
alloc_cgi_context(IOSTREAM *s)
|
||||
{ cgi_context *ctx = PL_malloc(sizeof(*ctx));
|
||||
|
||||
memset(ctx, 0, sizeof(*ctx));
|
||||
ctx->magic = CGI_MAGIC;
|
||||
ctx->stream = s;
|
||||
|
||||
return ctx;
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
free_cgi_context(cgi_context *ctx)
|
||||
{ if ( ctx->stream->upstream )
|
||||
Sset_filter(ctx->stream, NULL);
|
||||
else
|
||||
PL_release_stream(ctx->stream);
|
||||
|
||||
if ( ctx->data ) free(ctx->data);
|
||||
if ( ctx->hook ) PL_erase(ctx->hook);
|
||||
if ( ctx->request ) PL_erase(ctx->request);
|
||||
if ( ctx->header ) PL_erase(ctx->header);
|
||||
if ( ctx->connection ) PL_unregister_atom(ctx->connection);
|
||||
|
||||
ctx->magic = 0;
|
||||
PL_free(ctx);
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
grow_data_buffer(cgi_context *ctx, size_t size)
|
||||
{ size_t newsize;
|
||||
|
||||
if ( ctx->dataallocated == 0 )
|
||||
newsize = SIO_BUFSIZE;
|
||||
else
|
||||
newsize = ctx->dataallocated;
|
||||
|
||||
while(newsize < size)
|
||||
newsize *= 2;
|
||||
if ( ctx->data )
|
||||
{ void *p;
|
||||
|
||||
if ( !(p=realloc(ctx->data, newsize)) )
|
||||
return -1;
|
||||
ctx->data = p;
|
||||
ctx->dataallocated = newsize;
|
||||
} else
|
||||
{ if ( !(ctx->data = malloc(newsize)) )
|
||||
return -1;
|
||||
|
||||
ctx->dataallocated = newsize;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/*******************************
|
||||
* PROPERTIES *
|
||||
*******************************/
|
||||
|
||||
static IOFUNCTIONS cgi_functions;
|
||||
|
||||
static int
|
||||
get_cgi_stream(term_t t, IOSTREAM **sp, cgi_context **ctx)
|
||||
{ IOSTREAM *s;
|
||||
|
||||
if ( !PL_get_stream_handle(t, &s) )
|
||||
return FALSE;
|
||||
if ( s->functions != &cgi_functions )
|
||||
{ PL_release_stream(s);
|
||||
return type_error(t, "cgi_stream");
|
||||
}
|
||||
|
||||
*sp = s;
|
||||
*ctx = s->handle;
|
||||
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
unify_record(term_t t, record_t r)
|
||||
{ if ( r )
|
||||
{ term_t t2 = PL_new_term_ref();
|
||||
PL_recorded(r, t2);
|
||||
return PL_unify(t, t2);
|
||||
}
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
static foreign_t
|
||||
is_cgi_stream(term_t cgi)
|
||||
{ IOSTREAM *s;
|
||||
int rc;
|
||||
|
||||
if ( !PL_get_stream_handle(cgi, &s) )
|
||||
return FALSE;
|
||||
rc = (s->functions == &cgi_functions);
|
||||
PL_release_stream(s);
|
||||
|
||||
return rc;
|
||||
}
|
||||
|
||||
|
||||
static foreign_t
|
||||
cgi_property(term_t cgi, term_t prop)
|
||||
{ IOSTREAM *s;
|
||||
cgi_context *ctx;
|
||||
term_t arg = PL_new_term_ref();
|
||||
atom_t name;
|
||||
int arity;
|
||||
int rc = TRUE;
|
||||
|
||||
if ( !get_cgi_stream(cgi, &s, &ctx) )
|
||||
return FALSE;
|
||||
|
||||
if ( !PL_get_name_arity(prop, &name, &arity) || arity != 1 )
|
||||
{ rc = type_error(prop, "cgi_property");
|
||||
goto out;
|
||||
}
|
||||
|
||||
_PL_get_arg(1, prop, arg);
|
||||
if ( name == ATOM_request )
|
||||
{ if ( ctx->request )
|
||||
rc = unify_record(arg, ctx->request);
|
||||
else
|
||||
rc = PL_unify_nil(arg);
|
||||
} else if ( name == ATOM_header )
|
||||
{ if ( ctx->header )
|
||||
rc = unify_record(arg, ctx->header);
|
||||
else
|
||||
rc = PL_unify_nil(arg);
|
||||
} else if ( name == ATOM_id )
|
||||
{ rc = PL_unify_integer(arg, ctx->id);
|
||||
} else if ( name == ATOM_client )
|
||||
{ rc = PL_unify_stream(arg, ctx->stream);
|
||||
} else if ( name == ATOM_transfer_encoding )
|
||||
{ rc = PL_unify_atom(arg, ctx->transfer_encoding);
|
||||
} else if ( name == ATOM_connection )
|
||||
{ rc = PL_unify_atom(arg, ctx->connection ? ctx->connection : ATOM_close);
|
||||
} else if ( name == ATOM_content_length )
|
||||
{ rc = PL_unify_int64(arg, ctx->datasize - ctx->data_offset);
|
||||
} else if ( name == ATOM_header_codes )
|
||||
{ if ( ctx->data_offset > 0 )
|
||||
rc = PL_unify_chars(arg, PL_CODE_LIST, ctx->data_offset, ctx->data);
|
||||
else
|
||||
rc = existence_error(cgi, "header");
|
||||
} else if ( name == ATOM_state )
|
||||
{ atom_t state;
|
||||
|
||||
switch(ctx->state)
|
||||
{ case CGI_HDR: state = ATOM_header; break;
|
||||
case CGI_DATA: state = ATOM_data; break;
|
||||
case CGI_DISCARDED: state = ATOM_discarded; break;
|
||||
default:
|
||||
assert(0);
|
||||
}
|
||||
|
||||
rc = PL_unify_atom(arg, state);
|
||||
} else
|
||||
{ rc = existence_error(prop, "cgi_property");
|
||||
}
|
||||
|
||||
out:
|
||||
PL_release_stream(s);
|
||||
return rc;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
set_term(record_t *r, term_t t)
|
||||
{ if ( *r )
|
||||
PL_erase(*r);
|
||||
*r = PL_record(t);
|
||||
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
set_atom(atom_t *a, term_t t)
|
||||
{ atom_t new;
|
||||
|
||||
if ( !PL_get_atom(t, &new) )
|
||||
return type_error(t, "atom");
|
||||
|
||||
if ( *a != new )
|
||||
{ if ( *a )
|
||||
PL_unregister_atom(*a);
|
||||
*a = new;
|
||||
PL_register_atom(new);
|
||||
}
|
||||
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
|
||||
static foreign_t
|
||||
cgi_set(term_t cgi, term_t prop)
|
||||
{ IOSTREAM *s;
|
||||
cgi_context *ctx;
|
||||
term_t arg = PL_new_term_ref();
|
||||
atom_t name;
|
||||
int arity;
|
||||
int rc = TRUE;
|
||||
|
||||
if ( !get_cgi_stream(cgi, &s, &ctx) )
|
||||
return FALSE;
|
||||
|
||||
if ( !PL_get_name_arity(prop, &name, &arity) || arity != 1 )
|
||||
{ rc = type_error(prop, "cgi_property");
|
||||
goto out;
|
||||
}
|
||||
|
||||
_PL_get_arg(1, prop, arg);
|
||||
if ( name == ATOM_request )
|
||||
{ rc = set_term(&ctx->request, arg);
|
||||
} else if ( name == ATOM_header )
|
||||
{ rc = set_term(&ctx->header, arg);
|
||||
} else if ( name == ATOM_connection )
|
||||
{ rc = set_atom(&ctx->connection, arg);
|
||||
} else if ( name == ATOM_transfer_encoding )
|
||||
{ atom_t enc;
|
||||
|
||||
if ( !PL_get_atom(arg, &enc) )
|
||||
return type_error(arg, "atom");
|
||||
|
||||
if ( ctx->transfer_encoding != enc )
|
||||
{ if ( enc == ATOM_chunked )
|
||||
{ ctx->transfer_encoding = enc;
|
||||
rc = start_chunked_encoding(ctx);
|
||||
} else
|
||||
{ rc = domain_error(arg, "transfer_encoding");
|
||||
}
|
||||
}
|
||||
} else
|
||||
{ rc = existence_error(prop, "cgi_property");
|
||||
}
|
||||
|
||||
out:
|
||||
PL_release_stream(s);
|
||||
return rc;
|
||||
}
|
||||
|
||||
|
||||
static foreign_t
|
||||
cgi_discard(term_t cgi)
|
||||
{ IOSTREAM *s;
|
||||
cgi_context *ctx;
|
||||
|
||||
if ( !get_cgi_stream(cgi, &s, &ctx) )
|
||||
return FALSE;
|
||||
|
||||
ctx->state = CGI_DISCARDED;
|
||||
/* empty buffer to avoid write */
|
||||
ctx->cgi_stream->bufp = ctx->cgi_stream->buffer;
|
||||
PL_release_stream(s);
|
||||
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
|
||||
/*******************************
|
||||
* HOOKS *
|
||||
*******************************/
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
Call hook on the data we collected sofar. The hook is called with the
|
||||
following additional arguments:
|
||||
|
||||
* Event-type (header, data)
|
||||
* An input stream pointing to the collected data
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
static int
|
||||
call_hook(cgi_context *ctx, atom_t event)
|
||||
{ fid_t fid = PL_open_foreign_frame();
|
||||
term_t av = PL_new_term_refs(3);
|
||||
qid_t qid;
|
||||
int rc;
|
||||
|
||||
PL_recorded(ctx->hook, av+0);
|
||||
PL_put_atom(av+1, event);
|
||||
PL_unify_stream(av+2, ctx->cgi_stream);
|
||||
qid = PL_open_query(ctx->module, PL_Q_CATCH_EXCEPTION, PREDICATE_call3, av);
|
||||
rc = PL_next_solution(qid);
|
||||
|
||||
if ( !rc )
|
||||
{ term_t ex;
|
||||
|
||||
if ( (ex = PL_exception(qid)) )
|
||||
{ Sset_exception(ctx->cgi_stream, ex);
|
||||
|
||||
} else
|
||||
{ char buf[256];
|
||||
Ssprintf(buf, "CGI Hook %s failed", PL_atom_chars(event));
|
||||
|
||||
Sseterr(ctx->cgi_stream, SIO_WARN, buf);
|
||||
}
|
||||
|
||||
PL_cut_query(qid);
|
||||
PL_close_foreign_frame(fid);
|
||||
|
||||
return FALSE;
|
||||
}
|
||||
PL_close_query(qid);
|
||||
PL_discard_foreign_frame(fid);
|
||||
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
start_chunked_encoding(cgi_context *ctx)
|
||||
{ if ( call_hook(ctx, ATOM_send_header) )
|
||||
{ if ( ctx->datasize > ctx->data_offset )
|
||||
{ int rc = cgi_chunked_write(ctx,
|
||||
&ctx->data[ctx->data_offset],
|
||||
ctx->datasize - ctx->data_offset);
|
||||
if ( rc == -1 )
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
static size_t
|
||||
find_data(cgi_context *ctx, size_t start)
|
||||
{ const char *s = &ctx->data[start];
|
||||
const char *e = &ctx->data[ctx->datasize-2];
|
||||
|
||||
for(; s<=e; s++)
|
||||
{ if ( s[0] == '\r' && s[1] == '\n' &&
|
||||
s <= e-2 &&
|
||||
s[2] == '\r' && s[3] == '\n' )
|
||||
return &s[4] - ctx->data;
|
||||
if ( s[0] == '\n' && s[1] == '\n' )
|
||||
return &s[2] - ctx->data;
|
||||
}
|
||||
|
||||
return (size_t)-1;
|
||||
}
|
||||
|
||||
|
||||
|
||||
/*******************************
|
||||
* IO FUNCTIONS *
|
||||
*******************************/
|
||||
|
||||
static ssize_t /* encode */
|
||||
cgi_chunked_write(cgi_context *ctx, char *buf, size_t size)
|
||||
{ if ( Sfprintf(ctx->stream, "%x\r\n", size) < 0 )
|
||||
return -1;
|
||||
if ( size > 0 &&
|
||||
Sfwrite(buf, sizeof(char), size, ctx->stream) != size )
|
||||
return -1;
|
||||
if ( Sfprintf(ctx->stream, "\r\n") < 0 )
|
||||
return -1;
|
||||
if ( Sflush(ctx->stream) < 0 )
|
||||
return -1;
|
||||
|
||||
return size;
|
||||
}
|
||||
|
||||
|
||||
static ssize_t
|
||||
cgi_write(void *handle, char *buf, size_t size)
|
||||
{ cgi_context *ctx = handle;
|
||||
|
||||
DEBUG(1, Sdprintf("cgi_write(%ld bytes)\n", (long)size));
|
||||
|
||||
if ( ctx->state == CGI_DISCARDED )
|
||||
{ Sseterr(ctx->cgi_stream, SIO_FERR, "CGI stream was discarded");
|
||||
return -1;
|
||||
}
|
||||
|
||||
if ( ctx->transfer_encoding == ATOM_chunked )
|
||||
{ return cgi_chunked_write(ctx, buf, size);
|
||||
} else
|
||||
{ size_t osize = ctx->datasize;
|
||||
size_t dstart;
|
||||
|
||||
if ( osize+size > ctx->dataallocated )
|
||||
{ if ( grow_data_buffer(ctx, osize+size) < 0 )
|
||||
return -1; /* no memory */
|
||||
}
|
||||
memcpy(&ctx->data[osize], buf, size);
|
||||
ctx->datasize = osize+size;
|
||||
osize = (osize > 4 ? osize-4 : 0); /* 4 is max size of the separator */
|
||||
|
||||
if ( ctx->state == CGI_HDR &&
|
||||
(dstart=find_data(ctx, osize)) != ((size_t)-1) )
|
||||
{ assert(dstart <= ctx->datasize);
|
||||
ctx->data_offset = dstart;
|
||||
ctx->state = CGI_DATA;
|
||||
if ( !call_hook(ctx, ATOM_header) )
|
||||
{ ctx->state = CGI_DISCARDED;
|
||||
return -1; /* TBD: pass error kindly */
|
||||
}
|
||||
ctx->cgi_stream->flags &= ~(SIO_FBUF|SIO_LBUF|SIO_NBUF);
|
||||
ctx->cgi_stream->flags |= SIO_FBUF;
|
||||
}
|
||||
|
||||
return size;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
cgi_control(void *handle, int op, void *data)
|
||||
{ cgi_context *ctx = handle;
|
||||
|
||||
if ( ctx->magic != CGI_MAGIC )
|
||||
{ DEBUG(0, Sdprintf("OOPS: cgi_control(%d): invalid handle\n", op));
|
||||
errno = EINVAL;
|
||||
return -1;
|
||||
}
|
||||
|
||||
switch(op)
|
||||
{ case SIO_FLUSHOUTPUT:
|
||||
case SIO_SETENCODING:
|
||||
return 0; /* allow switching encoding */
|
||||
default:
|
||||
if ( ctx->stream->functions->control )
|
||||
return (*ctx->stream->functions->control)(ctx->stream->handle, op, data);
|
||||
return -1;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
cgi_close(void *handle)
|
||||
{ cgi_context *ctx = handle;
|
||||
int rc = 0;
|
||||
|
||||
DEBUG(1, Sdprintf("cgi_close()\n"));
|
||||
|
||||
switch( ctx->state )
|
||||
{ case CGI_DATA:
|
||||
{ if ( ctx->transfer_encoding == ATOM_chunked )
|
||||
{ if ( cgi_chunked_write(ctx, NULL, 0) < 0 )
|
||||
{ rc = -1;
|
||||
goto out;
|
||||
}
|
||||
} else
|
||||
{ size_t clen = ctx->datasize - ctx->data_offset;
|
||||
const char *dstart = &ctx->data[ctx->data_offset];
|
||||
|
||||
if ( !call_hook(ctx, ATOM_send_header) )
|
||||
{ rc = -1;
|
||||
goto out;
|
||||
}
|
||||
if ( Sfwrite(dstart, sizeof(char), clen, ctx->stream) != clen ||
|
||||
Sflush(ctx->stream) < 0 )
|
||||
{ rc = -1;
|
||||
goto out;
|
||||
}
|
||||
}
|
||||
|
||||
break;
|
||||
}
|
||||
case CGI_HDR:
|
||||
break;
|
||||
case CGI_DISCARDED:
|
||||
goto out;
|
||||
}
|
||||
|
||||
if ( !call_hook(ctx, ATOM_close) ) /* what if we had no header sofar? */
|
||||
rc = -1; /* TBD: pass error kindly */
|
||||
|
||||
out:
|
||||
ctx->stream->encoding = ctx->parent_encoding;
|
||||
free_cgi_context(ctx);
|
||||
|
||||
return rc;
|
||||
}
|
||||
|
||||
|
||||
static IOFUNCTIONS cgi_functions =
|
||||
{ NULL, /* read */
|
||||
cgi_write,
|
||||
NULL, /* seek */
|
||||
cgi_close,
|
||||
cgi_control, /* control */
|
||||
NULL, /* seek64 */
|
||||
};
|
||||
|
||||
|
||||
/*******************************
|
||||
* OPEN *
|
||||
*******************************/
|
||||
|
||||
static int current_id = 0; /* TBD: MT: lock */
|
||||
|
||||
#define CGI_COPY_FLAGS (SIO_OUTPUT| \
|
||||
SIO_TEXT| \
|
||||
SIO_REPXML|SIO_REPPL|\
|
||||
SIO_RECORDPOS)
|
||||
|
||||
static foreign_t
|
||||
pl_cgi_open(term_t org, term_t new, term_t closure, term_t options)
|
||||
{ term_t tail = PL_copy_term_ref(options);
|
||||
term_t head = PL_new_term_ref();
|
||||
cgi_context *ctx;
|
||||
IOSTREAM *s, *s2;
|
||||
module_t module = NULL;
|
||||
term_t hook = PL_new_term_ref();
|
||||
record_t request = 0;
|
||||
|
||||
PL_strip_module(closure, &module, hook);
|
||||
if ( !PL_is_callable(hook) )
|
||||
return type_error(closure, "callable");
|
||||
|
||||
while(PL_get_list(tail, head, tail))
|
||||
{ atom_t name;
|
||||
int arity;
|
||||
term_t arg = PL_new_term_ref();
|
||||
|
||||
if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
|
||||
return type_error(head, "option");
|
||||
_PL_get_arg(1, head, arg);
|
||||
if ( name == ATOM_request )
|
||||
{ request = PL_record(arg);
|
||||
} else
|
||||
return existence_error(head, "cgi_open_option");
|
||||
}
|
||||
if ( !PL_get_nil(tail) )
|
||||
return type_error(tail, "list");
|
||||
|
||||
if ( !PL_get_stream_handle(org, &s) )
|
||||
return FALSE; /* Error */
|
||||
if ( !(s->flags&SIO_OUTPUT) ) /* only allow output stream */
|
||||
{ PL_release_stream(s);
|
||||
return permission_error("stream", "write", org);
|
||||
}
|
||||
|
||||
ctx = alloc_cgi_context(s);
|
||||
ctx->hook = PL_record(hook);
|
||||
ctx->module = module;
|
||||
ctx->request = request;
|
||||
ctx->transfer_encoding = ATOM_none;
|
||||
if ( !(s2 = Snew(ctx,
|
||||
(s->flags&CGI_COPY_FLAGS)|SIO_LBUF,
|
||||
&cgi_functions)) )
|
||||
{ free_cgi_context(ctx); /* no memory */
|
||||
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
s2->encoding = ENC_ASCII; /* Header is ASCII only */
|
||||
ctx->parent_encoding = s->encoding;
|
||||
s->encoding = ENC_OCTET;
|
||||
ctx->cgi_stream = s2;
|
||||
if ( PL_unify_stream(new, s2) )
|
||||
{ Sset_filter(s, s2);
|
||||
PL_release_stream(s);
|
||||
ctx->id = ++current_id;
|
||||
|
||||
return TRUE;
|
||||
} else
|
||||
{ return instantiation_error();
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
install_cgi_stream()
|
||||
{ ATOM_header = PL_new_atom("header");
|
||||
ATOM_header_codes = PL_new_atom("header_codes");
|
||||
ATOM_send_header = PL_new_atom("send_header");
|
||||
ATOM_data = PL_new_atom("data");
|
||||
ATOM_discarded = PL_new_atom("discarded");
|
||||
ATOM_request = PL_new_atom("request");
|
||||
ATOM_header = PL_new_atom("header");
|
||||
ATOM_client = PL_new_atom("client");
|
||||
ATOM_chunked = PL_new_atom("chunked");
|
||||
ATOM_state = PL_new_atom("state");
|
||||
ATOM_none = PL_new_atom("none");
|
||||
ATOM_transfer_encoding = PL_new_atom("transfer_encoding");
|
||||
ATOM_close = PL_new_atom("close");
|
||||
ATOM_keep_alife = PL_new_atom("keep_alife");
|
||||
ATOM_connection = PL_new_atom("connection");
|
||||
ATOM_content_length = PL_new_atom("content_length");
|
||||
ATOM_id = PL_new_atom("id");
|
||||
|
||||
PREDICATE_call3 = PL_predicate("call", 3, "system");
|
||||
|
||||
PL_register_foreign("cgi_open", 4, pl_cgi_open, PL_FA_TRANSPARENT);
|
||||
PL_register_foreign("is_cgi_stream", 1, is_cgi_stream, 0);
|
||||
PL_register_foreign("cgi_property", 2, cgi_property, 0);
|
||||
PL_register_foreign("cgi_set", 2, cgi_set, 0);
|
||||
PL_register_foreign("cgi_discard", 1, cgi_discard, 0);
|
||||
}
|
||||
28
packages/http/common.mk
Normal file
28
packages/http/common.mk
Normal file
@ -0,0 +1,28 @@
|
||||
# Makefile fragments to are updated frequently and can be shared
|
||||
|
||||
LIBPL= $(srcdir)/html_write.pl $(srcdir)/http_client.pl \
|
||||
$(srcdir)/http_header.pl \
|
||||
$(srcdir)/http_mime_plugin.pl $(srcdir)/http_sgml_plugin.pl \
|
||||
$(srcdir)/mimepack.pl $(srcdir)/mimetype.pl \
|
||||
$(srcdir)/dcg_basics.pl \
|
||||
$(srcdir)/thread_httpd.pl $(srcdir)/xpce_httpd.pl \
|
||||
$(srcdir)/inetd_httpd.pl \
|
||||
$(srcdir)/http_wrapper.pl $(srcdir)/http_open.pl \
|
||||
$(srcdir)/http_session.pl \
|
||||
$(srcdir)/http_error.pl $(srcdir)/http_parameters.pl \
|
||||
$(srcdir)/http_dispatch.pl \
|
||||
$(srcdir)/http_authenticate.pl $(srcdir)/http_stream.pl \
|
||||
$(srcdir)/http_log.pl \
|
||||
$(srcdir)/http_path.pl $(srcdir)/http_hook.pl \
|
||||
$(srcdir)/html_head.pl $(srcdir)/http_exception.pl \
|
||||
$(srcdir)/json.pl $(srcdir)/http_json.pl \
|
||||
$(srcdir)/json_convert.pl $(srcdir)/http_dirindex.pl \
|
||||
$(srcdir)/http_server_files.pl $(srcdir)/http_pwp.pl \
|
||||
$(srcdir)/http_host.pl \
|
||||
$(srcdir)/http_openid.pl $(srcdir)/js_write.pl
|
||||
EXAMPLES= $(srcdir)/demo_body.pl $(srcdir)/demo_client.pl \
|
||||
$(srcdir)/demo_threads.pl $(srcdir)/demo_xpce.pl \
|
||||
$(srcdir)/calc.pl $(srcdir)/demo_files.pl \
|
||||
$(srcdir)/demo_pwp.pl $(srcdir)/demo_openid.pl
|
||||
EXAMPLEEXE= demo_inetd
|
||||
XPCEPL= $(srcdir)/http_image.pl
|
||||
91
packages/http/config.h
Normal file
91
packages/http/config.h
Normal file
@ -0,0 +1,91 @@
|
||||
/* config.h. Generated from config.h.in by configure. */
|
||||
/* config.h.in. Generated from configure.in by autoheader. */
|
||||
|
||||
/* Define if building universal (internal helper macro) */
|
||||
/* #undef AC_APPLE_UNIVERSAL_BUILD */
|
||||
|
||||
/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP
|
||||
systems. This function is required for `alloca.c' support on those systems.
|
||||
*/
|
||||
/* #undef CRAY_STACKSEG_END */
|
||||
|
||||
/* Define to 1 if using `alloca.c'. */
|
||||
/* #undef C_ALLOCA */
|
||||
|
||||
/* Define to 1 if you have `alloca', as a function or macro. */
|
||||
#define HAVE_ALLOCA 1
|
||||
|
||||
/* Define to 1 if you have <alloca.h> and it should be used (not on Ultrix).
|
||||
*/
|
||||
#define HAVE_ALLOCA_H 1
|
||||
|
||||
/* Define to 1 if you have the <inttypes.h> header file. */
|
||||
#define HAVE_INTTYPES_H 1
|
||||
|
||||
/* Define to 1 if you have the <memory.h> header file. */
|
||||
#define HAVE_MEMORY_H 1
|
||||
|
||||
/* Define to 1 if you have the <stdint.h> header file. */
|
||||
#define HAVE_STDINT_H 1
|
||||
|
||||
/* Define to 1 if you have the <stdlib.h> header file. */
|
||||
#define HAVE_STDLIB_H 1
|
||||
|
||||
/* Define to 1 if you have the <strings.h> header file. */
|
||||
#define HAVE_STRINGS_H 1
|
||||
|
||||
/* Define to 1 if you have the <string.h> header file. */
|
||||
#define HAVE_STRING_H 1
|
||||
|
||||
/* Define to 1 if you have the <sys/stat.h> header file. */
|
||||
#define HAVE_SYS_STAT_H 1
|
||||
|
||||
/* Define to 1 if you have the <sys/types.h> header file. */
|
||||
#define HAVE_SYS_TYPES_H 1
|
||||
|
||||
/* Define to 1 if you have the <unistd.h> header file. */
|
||||
#define HAVE_UNISTD_H 1
|
||||
|
||||
/* Define to the address where bug reports for this package should be sent. */
|
||||
#define PACKAGE_BUGREPORT ""
|
||||
|
||||
/* Define to the full name of this package. */
|
||||
#define PACKAGE_NAME ""
|
||||
|
||||
/* Define to the full name and version of this package. */
|
||||
#define PACKAGE_STRING ""
|
||||
|
||||
/* Define to the one symbol short name of this package. */
|
||||
#define PACKAGE_TARNAME ""
|
||||
|
||||
/* Define to the home page for this package. */
|
||||
#define PACKAGE_URL ""
|
||||
|
||||
/* Define to the version of this package. */
|
||||
#define PACKAGE_VERSION ""
|
||||
|
||||
/* If using the C implementation of alloca, define if you know the
|
||||
direction of stack growth for your system; otherwise it will be
|
||||
automatically deduced at runtime.
|
||||
STACK_DIRECTION > 0 => grows toward higher addresses
|
||||
STACK_DIRECTION < 0 => grows toward lower addresses
|
||||
STACK_DIRECTION = 0 => direction of growth unknown */
|
||||
/* #undef STACK_DIRECTION */
|
||||
|
||||
/* Define to 1 if you have the ANSI C header files. */
|
||||
#define STDC_HEADERS 1
|
||||
|
||||
/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most
|
||||
significant byte first (like Motorola and SPARC, unlike Intel). */
|
||||
#if defined AC_APPLE_UNIVERSAL_BUILD
|
||||
# if defined __BIG_ENDIAN__
|
||||
# define WORDS_BIGENDIAN 1
|
||||
# endif
|
||||
#else
|
||||
# ifndef WORDS_BIGENDIAN
|
||||
/* # undef WORDS_BIGENDIAN */
|
||||
# endif
|
||||
#endif
|
||||
|
||||
/* Define for multi-thread support */
|
||||
/* #undef _REENTRANT */
|
||||
90
packages/http/config.h.in
Normal file
90
packages/http/config.h.in
Normal file
@ -0,0 +1,90 @@
|
||||
/* config.h.in. Generated from configure.in by autoheader. */
|
||||
|
||||
/* Define if building universal (internal helper macro) */
|
||||
#undef AC_APPLE_UNIVERSAL_BUILD
|
||||
|
||||
/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP
|
||||
systems. This function is required for `alloca.c' support on those systems.
|
||||
*/
|
||||
#undef CRAY_STACKSEG_END
|
||||
|
||||
/* Define to 1 if using `alloca.c'. */
|
||||
#undef C_ALLOCA
|
||||
|
||||
/* Define to 1 if you have `alloca', as a function or macro. */
|
||||
#undef HAVE_ALLOCA
|
||||
|
||||
/* Define to 1 if you have <alloca.h> and it should be used (not on Ultrix).
|
||||
*/
|
||||
#undef HAVE_ALLOCA_H
|
||||
|
||||
/* Define to 1 if you have the <inttypes.h> header file. */
|
||||
#undef HAVE_INTTYPES_H
|
||||
|
||||
/* Define to 1 if you have the <memory.h> header file. */
|
||||
#undef HAVE_MEMORY_H
|
||||
|
||||
/* Define to 1 if you have the <stdint.h> header file. */
|
||||
#undef HAVE_STDINT_H
|
||||
|
||||
/* Define to 1 if you have the <stdlib.h> header file. */
|
||||
#undef HAVE_STDLIB_H
|
||||
|
||||
/* Define to 1 if you have the <strings.h> header file. */
|
||||
#undef HAVE_STRINGS_H
|
||||
|
||||
/* Define to 1 if you have the <string.h> header file. */
|
||||
#undef HAVE_STRING_H
|
||||
|
||||
/* Define to 1 if you have the <sys/stat.h> header file. */
|
||||
#undef HAVE_SYS_STAT_H
|
||||
|
||||
/* Define to 1 if you have the <sys/types.h> header file. */
|
||||
#undef HAVE_SYS_TYPES_H
|
||||
|
||||
/* Define to 1 if you have the <unistd.h> header file. */
|
||||
#undef HAVE_UNISTD_H
|
||||
|
||||
/* Define to the address where bug reports for this package should be sent. */
|
||||
#undef PACKAGE_BUGREPORT
|
||||
|
||||
/* Define to the full name of this package. */
|
||||
#undef PACKAGE_NAME
|
||||
|
||||
/* Define to the full name and version of this package. */
|
||||
#undef PACKAGE_STRING
|
||||
|
||||
/* Define to the one symbol short name of this package. */
|
||||
#undef PACKAGE_TARNAME
|
||||
|
||||
/* Define to the home page for this package. */
|
||||
#undef PACKAGE_URL
|
||||
|
||||
/* Define to the version of this package. */
|
||||
#undef PACKAGE_VERSION
|
||||
|
||||
/* If using the C implementation of alloca, define if you know the
|
||||
direction of stack growth for your system; otherwise it will be
|
||||
automatically deduced at runtime.
|
||||
STACK_DIRECTION > 0 => grows toward higher addresses
|
||||
STACK_DIRECTION < 0 => grows toward lower addresses
|
||||
STACK_DIRECTION = 0 => direction of growth unknown */
|
||||
#undef STACK_DIRECTION
|
||||
|
||||
/* Define to 1 if you have the ANSI C header files. */
|
||||
#undef STDC_HEADERS
|
||||
|
||||
/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most
|
||||
significant byte first (like Motorola and SPARC, unlike Intel). */
|
||||
#if defined AC_APPLE_UNIVERSAL_BUILD
|
||||
# if defined __BIG_ENDIAN__
|
||||
# define WORDS_BIGENDIAN 1
|
||||
# endif
|
||||
#else
|
||||
# ifndef WORDS_BIGENDIAN
|
||||
# undef WORDS_BIGENDIAN
|
||||
# endif
|
||||
#endif
|
||||
|
||||
/* Define for multi-thread support */
|
||||
#undef _REENTRANT
|
||||
483
packages/http/config.log
Normal file
483
packages/http/config.log
Normal file
@ -0,0 +1,483 @@
|
||||
This file contains any messages produced by compilers while
|
||||
running configure, to aid debugging if configure makes a mistake.
|
||||
|
||||
It was created by configure, which was
|
||||
generated by GNU Autoconf 2.65. Invocation command line was
|
||||
|
||||
$ ./configure --prefix=/home/vsc/Yap/pl-devel --prefix=/home/vsc/Yap/pl-devel
|
||||
|
||||
## --------- ##
|
||||
## Platform. ##
|
||||
## --------- ##
|
||||
|
||||
hostname = xato
|
||||
uname -m = x86_64
|
||||
uname -r = 2.6.32-22-generic
|
||||
uname -s = Linux
|
||||
uname -v = #36-Ubuntu SMP Thu Jun 3 19:31:57 UTC 2010
|
||||
|
||||
/usr/bin/uname -p = unknown
|
||||
/bin/uname -X = unknown
|
||||
|
||||
/bin/arch = unknown
|
||||
/usr/bin/arch -k = unknown
|
||||
/usr/convex/getsysinfo = unknown
|
||||
/usr/bin/hostinfo = unknown
|
||||
/bin/machine = unknown
|
||||
/usr/bin/oslevel = unknown
|
||||
/bin/universe = unknown
|
||||
|
||||
PATH: /home/vsc/Yap/pl-devel/bin
|
||||
PATH: /home/vsc/bin
|
||||
PATH: /usr/local/sbin
|
||||
PATH: /usr/local/bin
|
||||
PATH: /usr/sbin
|
||||
PATH: /usr/bin
|
||||
PATH: /sbin
|
||||
PATH: /bin
|
||||
PATH: /usr/games
|
||||
PATH: /home/vsc/lgtsvn/xml
|
||||
PATH: /home/vsc/lgtsvn/scripts
|
||||
PATH: /home/vsc/lgtsvn/integration
|
||||
|
||||
|
||||
## ----------- ##
|
||||
## Core tests. ##
|
||||
## ----------- ##
|
||||
|
||||
configure:2132: checking for gmake
|
||||
configure:2159: result: make
|
||||
configure:2175: checking for etags
|
||||
configure:2191: found /usr/bin/etags
|
||||
configure:2202: result: etags
|
||||
configure:2251: checking for a BSD-compatible install
|
||||
configure:2319: result: /usr/bin/install -c
|
||||
configure:2378: checking for gcc
|
||||
configure:2405: result: ../swipl-ld.sh
|
||||
configure:2634: checking for C compiler version
|
||||
configure:2643: ../swipl-ld.sh --version >&5
|
||||
gcc (Ubuntu 4.4.3-4ubuntu5) 4.4.3
|
||||
Copyright (C) 2009 Free Software Foundation, Inc.
|
||||
This is free software; see the source for copying conditions. There is NO
|
||||
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
configure:2654: $? = 0
|
||||
configure:2643: ../swipl-ld.sh -v >&5
|
||||
Using built-in specs.
|
||||
Target: x86_64-linux-gnu
|
||||
Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.4.3-4ubuntu5' --with-bugurl=file:///usr/share/doc/gcc-4.4/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --enable-multiarch --enable-linker-build-id --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --with-gxx-include-dir=/usr/include/c++/4.4 --program-suffix=-4.4 --enable-nls --enable-clocale=gnu --enable-libstdcxx-debug --enable-plugin --enable-objc-gc --disable-werror --with-arch-32=i486 --with-tune=generic --enable-checking=release --build=x86_64-linux-gnu --host=x86_64-linux-gnu --target=x86_64-linux-gnu
|
||||
Thread model: posix
|
||||
gcc version 4.4.3 (Ubuntu 4.4.3-4ubuntu5)
|
||||
configure:2654: $? = 0
|
||||
configure:2643: ../swipl-ld.sh -V >&5
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 0 has invalid symbol index 11
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 1 has invalid symbol index 12
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 2 has invalid symbol index 2
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 3 has invalid symbol index 2
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 4 has invalid symbol index 11
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 5 has invalid symbol index 13
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 6 has invalid symbol index 13
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 7 has invalid symbol index 13
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 8 has invalid symbol index 2
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 9 has invalid symbol index 2
|
||||
... rest of stderr output deleted ...
|
||||
configure:2654: $? = 1
|
||||
configure:2643: ../swipl-ld.sh -qversion >&5
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 0 has invalid symbol index 11
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 1 has invalid symbol index 12
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 2 has invalid symbol index 2
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 3 has invalid symbol index 2
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 4 has invalid symbol index 11
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 5 has invalid symbol index 13
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 6 has invalid symbol index 13
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 7 has invalid symbol index 13
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 8 has invalid symbol index 2
|
||||
/usr/bin/ld: /usr/lib/debug/usr/lib/crt1.o(.debug_info): relocation 9 has invalid symbol index 2
|
||||
... rest of stderr output deleted ...
|
||||
configure:2654: $? = 1
|
||||
configure:2674: checking whether the C compiler works
|
||||
configure:2696: ../swipl-ld.sh conftest.c >&5
|
||||
% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.00 sec, 37,800 bytes
|
||||
% halt
|
||||
configure:2700: $? = 0
|
||||
configure:2749: result: yes
|
||||
configure:2752: checking for C compiler default output file name
|
||||
configure:2754: result: a.out
|
||||
configure:2760: checking for suffix of executables
|
||||
configure:2767: ../swipl-ld.sh -o conftest conftest.c >&5
|
||||
% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.01 sec, 37,800 bytes
|
||||
% halt
|
||||
configure:2771: $? = 0
|
||||
configure:2793: result:
|
||||
configure:2815: checking whether we are cross compiling
|
||||
configure:2823: ../swipl-ld.sh -o conftest conftest.c >&5
|
||||
% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.00 sec, 37,800 bytes
|
||||
% halt
|
||||
configure:2827: $? = 0
|
||||
configure:2834: ./conftest
|
||||
configure:2838: $? = 0
|
||||
configure:2853: result: no
|
||||
configure:2858: checking for suffix of object files
|
||||
configure:2880: ../swipl-ld.sh -c conftest.c >&5
|
||||
configure:2884: $? = 0
|
||||
configure:2905: result: o
|
||||
configure:2909: checking whether we are using the GNU C compiler
|
||||
configure:2928: ../swipl-ld.sh -c conftest.c >&5
|
||||
configure:2928: $? = 0
|
||||
configure:2937: result: yes
|
||||
configure:2946: checking whether ../swipl-ld.sh accepts -g
|
||||
configure:2966: ../swipl-ld.sh -c -g conftest.c >&5
|
||||
configure:2966: $? = 0
|
||||
configure:3007: result: yes
|
||||
configure:3024: checking for ../swipl-ld.sh option to accept ISO C89
|
||||
configure:3088: ../swipl-ld.sh -c -g -O2 conftest.c >&5
|
||||
configure:3088: $? = 0
|
||||
configure:3101: result: none needed
|
||||
configure:3122: checking for library containing strerror
|
||||
configure:3153: ../swipl-ld.sh -o conftest -g -O2 conftest.c >&5
|
||||
% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.00 sec, 37,800 bytes
|
||||
% halt
|
||||
configure:3153: $? = 0
|
||||
configure:3170: result: none required
|
||||
configure:3183: checking how to run the C preprocessor
|
||||
configure:3214: ../swipl-ld.sh -E conftest.c
|
||||
configure:3214: $? = 0
|
||||
configure:3228: ../swipl-ld.sh -E conftest.c
|
||||
conftest.c:9:28: error: ac_nonexistent.h: No such file or directory
|
||||
gcc -E returned code 256
|
||||
*** /home/vsc/Yap/pl-devel/src/../src/swipl-ld exit status 1
|
||||
configure:3228: $? = 1
|
||||
configure: failed program was:
|
||||
| /* confdefs.h */
|
||||
| #define PACKAGE_NAME ""
|
||||
| #define PACKAGE_TARNAME ""
|
||||
| #define PACKAGE_VERSION ""
|
||||
| #define PACKAGE_STRING ""
|
||||
| #define PACKAGE_BUGREPORT ""
|
||||
| #define PACKAGE_URL ""
|
||||
| /* end confdefs.h. */
|
||||
| #include <ac_nonexistent.h>
|
||||
configure:3253: result: ../swipl-ld.sh -E
|
||||
configure:3273: ../swipl-ld.sh -E conftest.c
|
||||
configure:3273: $? = 0
|
||||
configure:3287: ../swipl-ld.sh -E conftest.c
|
||||
conftest.c:9:28: error: ac_nonexistent.h: No such file or directory
|
||||
gcc -E returned code 256
|
||||
*** /home/vsc/Yap/pl-devel/src/../src/swipl-ld exit status 1
|
||||
configure:3287: $? = 1
|
||||
configure: failed program was:
|
||||
| /* confdefs.h */
|
||||
| #define PACKAGE_NAME ""
|
||||
| #define PACKAGE_TARNAME ""
|
||||
| #define PACKAGE_VERSION ""
|
||||
| #define PACKAGE_STRING ""
|
||||
| #define PACKAGE_BUGREPORT ""
|
||||
| #define PACKAGE_URL ""
|
||||
| /* end confdefs.h. */
|
||||
| #include <ac_nonexistent.h>
|
||||
configure:3316: checking for grep that handles long lines and -e
|
||||
configure:3374: result: /bin/grep
|
||||
configure:3379: checking for egrep
|
||||
configure:3441: result: /bin/grep -E
|
||||
configure:3446: checking for ANSI C header files
|
||||
configure:3466: ../swipl-ld.sh -c -g -O2 conftest.c >&5
|
||||
configure:3466: $? = 0
|
||||
configure:3539: ../swipl-ld.sh -o conftest -g -O2 conftest.c >&5
|
||||
% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.00 sec, 37,800 bytes
|
||||
% halt
|
||||
configure:3539: $? = 0
|
||||
configure:3539: ./conftest
|
||||
configure:3539: $? = 0
|
||||
configure:3550: result: yes
|
||||
configure:3564: checking for sys/types.h
|
||||
configure:3564: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
configure:3564: $? = 0
|
||||
configure:3564: result: yes
|
||||
configure:3564: checking for sys/stat.h
|
||||
configure:3564: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
configure:3564: $? = 0
|
||||
configure:3564: result: yes
|
||||
configure:3564: checking for stdlib.h
|
||||
configure:3564: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
configure:3564: $? = 0
|
||||
configure:3564: result: yes
|
||||
configure:3564: checking for string.h
|
||||
configure:3564: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
configure:3564: $? = 0
|
||||
configure:3564: result: yes
|
||||
configure:3564: checking for memory.h
|
||||
configure:3564: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
configure:3564: $? = 0
|
||||
configure:3564: result: yes
|
||||
configure:3564: checking for strings.h
|
||||
configure:3564: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
configure:3564: $? = 0
|
||||
configure:3564: result: yes
|
||||
configure:3564: checking for inttypes.h
|
||||
configure:3564: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
configure:3564: $? = 0
|
||||
configure:3564: result: yes
|
||||
configure:3564: checking for stdint.h
|
||||
configure:3564: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
configure:3564: $? = 0
|
||||
configure:3564: result: yes
|
||||
configure:3564: checking for unistd.h
|
||||
configure:3564: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
configure:3564: $? = 0
|
||||
configure:3564: result: yes
|
||||
configure:3579: checking for working alloca.h
|
||||
configure:3596: ../swipl-ld.sh -o conftest -fPIC conftest.c >&5
|
||||
% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.00 sec, 37,800 bytes
|
||||
% halt
|
||||
configure:3596: $? = 0
|
||||
configure:3604: result: yes
|
||||
configure:3612: checking for alloca
|
||||
configure:3649: ../swipl-ld.sh -o conftest -fPIC conftest.c >&5
|
||||
% /home/vsc/Yap/pl-devel/library/listing compiled into prolog_listing 0.01 sec, 37,800 bytes
|
||||
% halt
|
||||
configure:3649: $? = 0
|
||||
configure:3657: result: yes
|
||||
configure:3767: checking whether byte ordering is bigendian
|
||||
configure:3782: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
conftest.c:22: error: expected '=', ',', ';', 'asm' or '__attribute__' before 'a'
|
||||
gcc returned code 256
|
||||
*** /home/vsc/Yap/pl-devel/src/../src/swipl-ld exit status 1
|
||||
configure:3782: $? = 1
|
||||
configure: failed program was:
|
||||
| /* confdefs.h */
|
||||
| #define PACKAGE_NAME ""
|
||||
| #define PACKAGE_TARNAME ""
|
||||
| #define PACKAGE_VERSION ""
|
||||
| #define PACKAGE_STRING ""
|
||||
| #define PACKAGE_BUGREPORT ""
|
||||
| #define PACKAGE_URL ""
|
||||
| #define STDC_HEADERS 1
|
||||
| #define HAVE_SYS_TYPES_H 1
|
||||
| #define HAVE_SYS_STAT_H 1
|
||||
| #define HAVE_STDLIB_H 1
|
||||
| #define HAVE_STRING_H 1
|
||||
| #define HAVE_MEMORY_H 1
|
||||
| #define HAVE_STRINGS_H 1
|
||||
| #define HAVE_INTTYPES_H 1
|
||||
| #define HAVE_STDINT_H 1
|
||||
| #define HAVE_UNISTD_H 1
|
||||
| #define HAVE_ALLOCA_H 1
|
||||
| #define HAVE_ALLOCA 1
|
||||
| /* end confdefs.h. */
|
||||
| #ifndef __APPLE_CC__
|
||||
| not a universal capable compiler
|
||||
| #endif
|
||||
| typedef int dummy;
|
||||
|
|
||||
configure:3827: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
configure:3827: $? = 0
|
||||
configure:3845: ../swipl-ld.sh -c -fPIC conftest.c >&5
|
||||
conftest.c: In function 'main':
|
||||
conftest.c:28: error: 'not' undeclared (first use in this function)
|
||||
conftest.c:28: error: (Each undeclared identifier is reported only once
|
||||
conftest.c:28: error: for each function it appears in.)
|
||||
conftest.c:28: error: expected ';' before 'big'
|
||||
gcc returned code 256
|
||||
*** /home/vsc/Yap/pl-devel/src/../src/swipl-ld exit status 1
|
||||
configure:3845: $? = 1
|
||||
configure: failed program was:
|
||||
| /* confdefs.h */
|
||||
| #define PACKAGE_NAME ""
|
||||
| #define PACKAGE_TARNAME ""
|
||||
| #define PACKAGE_VERSION ""
|
||||
| #define PACKAGE_STRING ""
|
||||
| #define PACKAGE_BUGREPORT ""
|
||||
| #define PACKAGE_URL ""
|
||||
| #define STDC_HEADERS 1
|
||||
| #define HAVE_SYS_TYPES_H 1
|
||||
| #define HAVE_SYS_STAT_H 1
|
||||
| #define HAVE_STDLIB_H 1
|
||||
| #define HAVE_STRING_H 1
|
||||
| #define HAVE_MEMORY_H 1
|
||||
| #define HAVE_STRINGS_H 1
|
||||
| #define HAVE_INTTYPES_H 1
|
||||
| #define HAVE_STDINT_H 1
|
||||
| #define HAVE_UNISTD_H 1
|
||||
| #define HAVE_ALLOCA_H 1
|
||||
| #define HAVE_ALLOCA 1
|
||||
| /* end confdefs.h. */
|
||||
| #include <sys/types.h>
|
||||
| #include <sys/param.h>
|
||||
|
|
||||
| int
|
||||
| main ()
|
||||
| {
|
||||
| #if BYTE_ORDER != BIG_ENDIAN
|
||||
| not big endian
|
||||
| #endif
|
||||
|
|
||||
| ;
|
||||
| return 0;
|
||||
| }
|
||||
configure:3973: result: no
|
||||
configure:4105: creating ./config.status
|
||||
|
||||
## ---------------------- ##
|
||||
## Running config.status. ##
|
||||
## ---------------------- ##
|
||||
|
||||
This file was extended by config.status, which was
|
||||
generated by GNU Autoconf 2.65. Invocation command line was
|
||||
|
||||
CONFIG_FILES =
|
||||
CONFIG_HEADERS =
|
||||
CONFIG_LINKS =
|
||||
CONFIG_COMMANDS =
|
||||
$ ./config.status
|
||||
|
||||
on xato
|
||||
|
||||
config.status:822: creating Makefile
|
||||
config.status:822: creating config.h
|
||||
|
||||
## ---------------- ##
|
||||
## Cache variables. ##
|
||||
## ---------------- ##
|
||||
|
||||
ac_cv_c_bigendian=no
|
||||
ac_cv_c_compiler_gnu=yes
|
||||
ac_cv_env_CC_set=
|
||||
ac_cv_env_CC_value=
|
||||
ac_cv_env_CFLAGS_set=
|
||||
ac_cv_env_CFLAGS_value=
|
||||
ac_cv_env_CPPFLAGS_set=
|
||||
ac_cv_env_CPPFLAGS_value=
|
||||
ac_cv_env_CPP_set=
|
||||
ac_cv_env_CPP_value=
|
||||
ac_cv_env_LDFLAGS_set=
|
||||
ac_cv_env_LDFLAGS_value=
|
||||
ac_cv_env_LIBS_set=
|
||||
ac_cv_env_LIBS_value=
|
||||
ac_cv_env_build_alias_set=
|
||||
ac_cv_env_build_alias_value=
|
||||
ac_cv_env_host_alias_set=
|
||||
ac_cv_env_host_alias_value=
|
||||
ac_cv_env_target_alias_set=
|
||||
ac_cv_env_target_alias_value=
|
||||
ac_cv_func_alloca_works=yes
|
||||
ac_cv_header_inttypes_h=yes
|
||||
ac_cv_header_memory_h=yes
|
||||
ac_cv_header_stdc=yes
|
||||
ac_cv_header_stdint_h=yes
|
||||
ac_cv_header_stdlib_h=yes
|
||||
ac_cv_header_string_h=yes
|
||||
ac_cv_header_strings_h=yes
|
||||
ac_cv_header_sys_stat_h=yes
|
||||
ac_cv_header_sys_types_h=yes
|
||||
ac_cv_header_unistd_h=yes
|
||||
ac_cv_objext=o
|
||||
ac_cv_path_EGREP='/bin/grep -E'
|
||||
ac_cv_path_GREP=/bin/grep
|
||||
ac_cv_prog_CPP='../swipl-ld.sh -E'
|
||||
ac_cv_prog_ETAGS=etags
|
||||
ac_cv_prog_MAKE=make
|
||||
ac_cv_prog_ac_ct_CC=../swipl-ld.sh
|
||||
ac_cv_prog_cc_c89=
|
||||
ac_cv_prog_cc_g=yes
|
||||
ac_cv_search_strerror='none required'
|
||||
ac_cv_working_alloca_h=yes
|
||||
|
||||
## ----------------- ##
|
||||
## Output variables. ##
|
||||
## ----------------- ##
|
||||
|
||||
ALLOCA=''
|
||||
CC='../swipl-ld.sh'
|
||||
CFLAGS='-fPIC'
|
||||
CIFLAGS=''
|
||||
CMFLAGS='-fPIC'
|
||||
COFLAGS='-O2 -fno-strict-aliasing'
|
||||
CPP='../swipl-ld.sh -E'
|
||||
CPPFLAGS=''
|
||||
CWFLAGS='-Wall'
|
||||
DEFS='-DHAVE_CONFIG_H'
|
||||
ECHO_C=''
|
||||
ECHO_N='-n'
|
||||
ECHO_T=''
|
||||
EGREP='/bin/grep -E'
|
||||
ETAGS='etags'
|
||||
EXEEXT=''
|
||||
GREP='/bin/grep'
|
||||
INSTALL_DATA='/usr/bin/install -c -m 644'
|
||||
INSTALL_PROGRAM='${INSTALL}'
|
||||
INSTALL_SCRIPT='${INSTALL}'
|
||||
LD='../swipl-ld.sh'
|
||||
LDFLAGS=''
|
||||
LDSOFLAGS='-shared'
|
||||
LIBOBJS=''
|
||||
LIBS=''
|
||||
LTLIBOBJS=''
|
||||
MAKE='make'
|
||||
OBJEXT='o'
|
||||
PACKAGE_BUGREPORT=''
|
||||
PACKAGE_NAME=''
|
||||
PACKAGE_STRING=''
|
||||
PACKAGE_TARNAME=''
|
||||
PACKAGE_URL=''
|
||||
PACKAGE_VERSION=''
|
||||
PATH_SEPARATOR=':'
|
||||
PL='../swipl.sh'
|
||||
PLARCH='x86_64-linux'
|
||||
PLBASE='/home/vsc/Yap/pl-devel/lib/swipl-5.11.1'
|
||||
PLINCL='/home/vsc/Yap/pl-devel/include'
|
||||
PLLD='../swipl-ld.sh'
|
||||
PLLIBS='-lgmp -lrt -lreadline -lncurses -lm -lrt -ldl '
|
||||
SHELL='/bin/bash'
|
||||
SO='so'
|
||||
ac_ct_CC='../swipl-ld.sh'
|
||||
bindir='${exec_prefix}/bin'
|
||||
build_alias=''
|
||||
datadir='${datarootdir}'
|
||||
datarootdir='${prefix}/share'
|
||||
docdir='${datarootdir}/doc/${PACKAGE}'
|
||||
dvidir='${docdir}'
|
||||
exec_prefix='${prefix}'
|
||||
host_alias=''
|
||||
htmldir='${docdir}'
|
||||
includedir='${prefix}/include'
|
||||
infodir='${datarootdir}/info'
|
||||
libdir='${exec_prefix}/lib'
|
||||
libexecdir='${exec_prefix}/libexec'
|
||||
localedir='${datarootdir}/locale'
|
||||
localstatedir='${prefix}/var'
|
||||
mandir='${datarootdir}/man'
|
||||
oldincludedir='/usr/include'
|
||||
pdfdir='${docdir}'
|
||||
prefix='/home/vsc/Yap/pl-devel'
|
||||
program_transform_name='s,x,x,'
|
||||
psdir='${docdir}'
|
||||
sbindir='${exec_prefix}/sbin'
|
||||
sharedstatedir='${prefix}/com'
|
||||
sysconfdir='${prefix}/etc'
|
||||
target_alias=''
|
||||
|
||||
## ----------- ##
|
||||
## confdefs.h. ##
|
||||
## ----------- ##
|
||||
|
||||
/* confdefs.h */
|
||||
#define PACKAGE_NAME ""
|
||||
#define PACKAGE_TARNAME ""
|
||||
#define PACKAGE_VERSION ""
|
||||
#define PACKAGE_STRING ""
|
||||
#define PACKAGE_BUGREPORT ""
|
||||
#define PACKAGE_URL ""
|
||||
#define STDC_HEADERS 1
|
||||
#define HAVE_SYS_TYPES_H 1
|
||||
#define HAVE_SYS_STAT_H 1
|
||||
#define HAVE_STDLIB_H 1
|
||||
#define HAVE_STRING_H 1
|
||||
#define HAVE_MEMORY_H 1
|
||||
#define HAVE_STRINGS_H 1
|
||||
#define HAVE_INTTYPES_H 1
|
||||
#define HAVE_STDINT_H 1
|
||||
#define HAVE_UNISTD_H 1
|
||||
#define HAVE_ALLOCA_H 1
|
||||
#define HAVE_ALLOCA 1
|
||||
|
||||
configure: exit 0
|
||||
9
packages/http/configure.in
Normal file
9
packages/http/configure.in
Normal file
@ -0,0 +1,9 @@
|
||||
dnl Process this file with autoconf to produce a configure script.
|
||||
|
||||
AC_INIT(install-sh)
|
||||
AC_PREREQ([2.50])
|
||||
AC_CONFIG_HEADER(config.h)
|
||||
|
||||
m4_include([../ac_swi_c.m4])
|
||||
|
||||
AC_OUTPUT(Makefile)
|
||||
364
packages/http/dcg_basics.pl
Normal file
364
packages/http/dcg_basics.pl
Normal file
@ -0,0 +1,364 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2007, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(dcg_basics,
|
||||
[ white//0, % <white inside line>
|
||||
whites//0, % <white inside line>*
|
||||
blank//0, % <blank>
|
||||
blanks//0, % <blank>*
|
||||
nonblank//1, % <nonblank>
|
||||
nonblanks//1, % <nonblank>* --> chars (long)
|
||||
blanks_to_nl//0, % [space,tab,ret]*nl
|
||||
string//1, % <any>* -->chars (short)
|
||||
string_without//2, % Exclude, -->chars (long)
|
||||
% Characters
|
||||
alpha_to_lower//1, % Get lower|upper, return lower
|
||||
% Decimal numbers
|
||||
digits//1, % [0-9]* -->chars
|
||||
digit//1, % [0-9] --> char
|
||||
integer//1, % [+-][0-9]+ --> integer
|
||||
float//1, % [+-]?[0-9]+(.[0-9]*)?(e[+-]?[0-9]+)? --> float
|
||||
number//1, % integer | float
|
||||
% Hexadecimal numbers
|
||||
xdigits//1, % [0-9a-f]* --> 0-15*
|
||||
xdigit//1, % [0-9a-f] --> 0-15
|
||||
xinteger//1, % [0-9a-f]+ --> integer
|
||||
% Misc
|
||||
eos//0, % demand end-of-string
|
||||
% generation (TBD)
|
||||
atom//1 % generate atom
|
||||
]).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
|
||||
/** <module> Various general DCG utilities
|
||||
|
||||
This library provides various commonly used DCG primitives acting on
|
||||
list of character codes. Character classification is based on
|
||||
code_type/2.
|
||||
|
||||
@tbd Try to achieve an accepted standard and move this into the
|
||||
general SWI-Prolog library. None of this is HTTP specific.
|
||||
*/
|
||||
|
||||
%% string_without(+End, -Codes)// is det.
|
||||
%
|
||||
% Take as many tokens from the input until the next token appears
|
||||
% in End. End itself is left on the input. Typical use is to read
|
||||
% upto a defined delimiter such as a newline or other reserved
|
||||
% character.
|
||||
%
|
||||
% @see string//1.
|
||||
|
||||
string_without(Not, [C|T]) -->
|
||||
[C],
|
||||
{ \+ memberchk(C, Not)
|
||||
}, !,
|
||||
string_without(Not, T).
|
||||
string_without(_, []) -->
|
||||
[].
|
||||
|
||||
%% string(-Codes)// is nondet.
|
||||
%
|
||||
% Take as few as possible tokens from the input, taking one more
|
||||
% each time on backtracking. This code is normally followed by a
|
||||
% test for a delimiter. E.g.
|
||||
%
|
||||
% ==
|
||||
% upto_colon(Atom) -->
|
||||
% string(Codes), ":", !,
|
||||
% { atom_codes(Atom, Codes) }.
|
||||
% ==
|
||||
|
||||
string([]) -->
|
||||
[].
|
||||
string([H|T]) -->
|
||||
[H],
|
||||
string(T).
|
||||
|
||||
%% blanks// is det.
|
||||
%
|
||||
% Skip zero or more white-space characters.
|
||||
|
||||
blanks -->
|
||||
blank, !,
|
||||
blanks.
|
||||
blanks -->
|
||||
[].
|
||||
|
||||
%% blank// is semidet.
|
||||
%
|
||||
% Take next =space= character from input. Space characters include
|
||||
% newline.
|
||||
%
|
||||
% @see white//0
|
||||
|
||||
blank -->
|
||||
[C],
|
||||
{ nonvar(C),
|
||||
code_type(C, space)
|
||||
}.
|
||||
|
||||
%% nonblanks(-Codes)// is det.
|
||||
%
|
||||
% Take all =graph= characters
|
||||
|
||||
nonblanks([H|T]) -->
|
||||
[H],
|
||||
{ code_type(H, graph)
|
||||
}, !,
|
||||
nonblanks(T).
|
||||
nonblanks([]) -->
|
||||
[].
|
||||
|
||||
%% nonblank(-Code)// is semidet.
|
||||
%
|
||||
% Code is the next non-blank (=graph=) character.
|
||||
|
||||
nonblank(H) -->
|
||||
[H],
|
||||
{ code_type(H, graph)
|
||||
}.
|
||||
|
||||
%% blanks_to_nl// is semidet.
|
||||
%
|
||||
% Take a sequence of blank//0 codes if banks are followed by a
|
||||
% newline or end of the input.
|
||||
|
||||
blanks_to_nl -->
|
||||
"\n", !.
|
||||
blanks_to_nl -->
|
||||
blank, !,
|
||||
blanks_to_nl.
|
||||
blanks_to_nl -->
|
||||
eos.
|
||||
|
||||
%% whites// is det.
|
||||
%
|
||||
% Skip white space _inside_ a line.
|
||||
%
|
||||
% @see blanks//0 also skips newlines.
|
||||
|
||||
whites -->
|
||||
white, !,
|
||||
whites.
|
||||
whites -->
|
||||
[].
|
||||
|
||||
%% white// is semidet.
|
||||
%
|
||||
% Take next =white= character from input. White characters do
|
||||
% _not_ include newline.
|
||||
|
||||
white -->
|
||||
[C],
|
||||
{ nonvar(C),
|
||||
code_type(C, white)
|
||||
}.
|
||||
|
||||
|
||||
/*******************************
|
||||
* CHARACTER STUFF *
|
||||
*******************************/
|
||||
|
||||
%% alpha_to_lower(+C)// is det.
|
||||
%% alpha_to_lower(-C)// is semidet.
|
||||
%
|
||||
% Read a letter (class =alpha=) and return it as a lowercase
|
||||
% letter. In output mode this simply emits the character.
|
||||
|
||||
alpha_to_lower(L) -->
|
||||
{ integer(L) }, !,
|
||||
[L].
|
||||
alpha_to_lower(L) -->
|
||||
[C],
|
||||
{ code_type(C, alpha),
|
||||
code_type(C, to_upper(L))
|
||||
}.
|
||||
|
||||
|
||||
/*******************************
|
||||
* NUMBERS *
|
||||
*******************************/
|
||||
|
||||
%% digits(?Chars)// is det.
|
||||
%% digit(?Char)// is det.
|
||||
%% integer(?Integer)// is det.
|
||||
%
|
||||
% Number processing. The predicate digits//1 matches a posibly
|
||||
% empty set of digits, digit//1 processes a single digit and
|
||||
% integer processes an optional sign followed by a non-empty
|
||||
% sequence of digits into an integer.
|
||||
|
||||
digits([H|T]) -->
|
||||
digit(H), !,
|
||||
digits(T).
|
||||
digits([]) -->
|
||||
[].
|
||||
|
||||
digit(C) -->
|
||||
[C],
|
||||
{ code_type(C, digit)
|
||||
}.
|
||||
|
||||
integer(I, Head, Tail) :-
|
||||
integer(I), !,
|
||||
format(codes(Head, Tail), '~w', [I]).
|
||||
integer(I) -->
|
||||
int_codes(Codes),
|
||||
{ number_codes(I, Codes)
|
||||
}.
|
||||
|
||||
int_codes([C,D0|D]) -->
|
||||
sign(C), !,
|
||||
digit(D0),
|
||||
digits(D).
|
||||
int_codes([D0|D]) -->
|
||||
digit(D0),
|
||||
digits(D).
|
||||
|
||||
|
||||
%% float(?Float)// is det.
|
||||
%
|
||||
% Process a floating point number. The actual conversion is
|
||||
% controlled by number_codes/2.
|
||||
|
||||
float(F, Head, Tail) :-
|
||||
float(F), !,
|
||||
with_output_to(codes(Head, Tail), write(F)).
|
||||
float(F) -->
|
||||
number(F),
|
||||
{ float(F) }.
|
||||
|
||||
%% number(+Number)// is det.
|
||||
%% number(-Number)// is semidet.
|
||||
%
|
||||
% Generate extract a number. Handles both integers and floating
|
||||
% point numbers.
|
||||
|
||||
number(N, Head, Tail) :-
|
||||
number(N), !,
|
||||
format(codes(Head, Tail), '~w', N).
|
||||
number(N) -->
|
||||
int_codes(I),
|
||||
( dot,
|
||||
digit(DF0),
|
||||
digits(DF)
|
||||
-> {F = [0'., DF0|DF]}
|
||||
; {F = ""}
|
||||
),
|
||||
( exp
|
||||
-> int_codes(DI),
|
||||
{E=[0'e|DI]}
|
||||
; {E = ""}
|
||||
),
|
||||
{ append([I, F, E], Codes),
|
||||
number_codes(N, Codes)
|
||||
}.
|
||||
|
||||
sign(0'-) --> "-".
|
||||
sign(0'+) --> "+".
|
||||
|
||||
dot --> ".".
|
||||
|
||||
exp --> "e".
|
||||
exp --> "E".
|
||||
|
||||
/*******************************
|
||||
* HEX NUMBERS *
|
||||
*******************************/
|
||||
|
||||
%% xinteger(+Integer)// is det.
|
||||
%% xinteger(-Integer)// is semidet.
|
||||
%
|
||||
% Generate or extract an integer from a sequence of hexadecimal
|
||||
% digits.
|
||||
|
||||
xinteger(Val, Head, Tail) :-
|
||||
integer(Val),
|
||||
format(codes(Head, Tail), '~16r', [Val]).
|
||||
xinteger(Val) -->
|
||||
xdigit(D0),
|
||||
xdigits(D),
|
||||
{ mkval([D0|D], 16, Val)
|
||||
}.
|
||||
|
||||
%% xdigit(-Weight)// is semidet.
|
||||
%
|
||||
% True if the next code is a hexdecimal digit with Weight. Weight
|
||||
% is between 0 and 15.
|
||||
|
||||
xdigit(D) -->
|
||||
[C],
|
||||
{ code_type(C, xdigit(D))
|
||||
}.
|
||||
|
||||
%% xdigits(-WeightList)// is det.
|
||||
%
|
||||
% List of weights of a sequence of hexadecimal codes. WeightList
|
||||
% may be empty.
|
||||
|
||||
xdigits([D0|D]) -->
|
||||
xdigit(D0), !,
|
||||
xdigits(D).
|
||||
xdigits([]) -->
|
||||
[].
|
||||
|
||||
mkval([W0|Weights], Base, Val) :-
|
||||
mkval(Weights, Base, W0, Val).
|
||||
|
||||
mkval([], _, W, W).
|
||||
mkval([H|T], Base, W0, W) :-
|
||||
W1 is W0*Base+H,
|
||||
mkval(T, Base, W1, W).
|
||||
|
||||
|
||||
/*******************************
|
||||
* END-OF-STRING *
|
||||
*******************************/
|
||||
|
||||
%% eos//
|
||||
%
|
||||
% True if at end of input list.
|
||||
|
||||
eos([], []).
|
||||
|
||||
/*******************************
|
||||
* GENERATION *
|
||||
*******************************/
|
||||
|
||||
%% atom(+Atom)// is det.
|
||||
%
|
||||
% Generate codes of Atom. Current implementation uses write/1,
|
||||
% dealing with any Prolog term.
|
||||
|
||||
atom(Atom, Head, Tail) :-
|
||||
format(codes(Head, Tail), '~w', [Atom]).
|
||||
68
packages/http/examples/README
Normal file
68
packages/http/examples/README
Normal file
@ -0,0 +1,68 @@
|
||||
This is a simple demo of the HTTP server facilities, providing a simple
|
||||
body and the three documented server instantiations.
|
||||
|
||||
---+ The server main programs are:
|
||||
|
||||
$ demo_threads.pl :
|
||||
Run threaded server. Requires SWI-Prolog with thread-support.
|
||||
The server is started at port 3000 using server/0. server/2
|
||||
allows to specify options. tm/0 provides a graphical display
|
||||
of the runing threads. See source-file.
|
||||
|
||||
$ demo_xpce.pl :
|
||||
Run XPCE-based event-driven server. Requires XPCE. Use
|
||||
?- server(3000). to start the server at port 3000.
|
||||
|
||||
$ demo_inetd :
|
||||
To install this, adjust the first line of this file to point
|
||||
to the installed Prolog executable and add the following line
|
||||
to /etc/inetd.conf (adjust as needed):
|
||||
|
||||
4001 stream tcp nowait nobody /usr/sbin/tcpd /usr/lib/pl-5.1.4/library/http/demo/demo_inetd
|
||||
|
||||
---+ Session management demo:
|
||||
|
||||
$ calc.pl :
|
||||
Multi-threaded server with session management using the
|
||||
html_write.pl library. See source for usage.
|
||||
|
||||
---+ File serving demo:
|
||||
|
||||
$ demo_files.pl :
|
||||
Is a multi-threaded server that serves static files and
|
||||
directory indices.
|
||||
|
||||
---+ Client demo
|
||||
|
||||
$ demo_client.pl :
|
||||
Simple multi-threaded client to test the server under
|
||||
different conditions. Requires SWI-Prolog with thread-support.
|
||||
See source for usage.
|
||||
|
||||
---+ Performance testing
|
||||
|
||||
A very early start of some routines to validate the server platform.
|
||||
Eventually, stress_server.pl will serve different tests from multiple
|
||||
locations and stress_client.pl will contain client code to run
|
||||
individual tests as well as doing multi-threaded tests.
|
||||
|
||||
$ stress_server.pl :
|
||||
Server platform.
|
||||
|
||||
$ stress_client.pl :
|
||||
Client.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
92
packages/http/examples/calc.pl
Normal file
92
packages/http/examples/calc.pl
Normal file
@ -0,0 +1,92 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): Public domain
|
||||
*/
|
||||
|
||||
:- use_module(library('http/thread_httpd')).
|
||||
:- use_module(library('http/html_write')).
|
||||
:- use_module(library('http/http_session')).
|
||||
:- use_module(library('http/http_error')).
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
This demo shows session state management in a very simple calculator
|
||||
package. It also demonstrates the use of the html_write library. To use
|
||||
it, start Prolog, load this file and run
|
||||
|
||||
?- server.
|
||||
|
||||
Now direct your browser to http://localhost:3000/
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
server :-
|
||||
server(3000, []).
|
||||
|
||||
server(Port, Options) :-
|
||||
http_server(reply,
|
||||
[ port(Port),
|
||||
timeout(20)
|
||||
| Options
|
||||
]).
|
||||
|
||||
reply(Request) :-
|
||||
memberchk(path(Path), Request),
|
||||
reply(Path, Request).
|
||||
|
||||
reply(/, _Request) :-
|
||||
http_session_retractall(formula(_)),
|
||||
Formula = 0,
|
||||
http_session_assert(formula(Formula)),
|
||||
page(Formula).
|
||||
|
||||
reply('/calc', Request) :-
|
||||
memberchk(search(Search), Request),
|
||||
memberchk(operation=Op, Search),
|
||||
memberchk(value=AtomVal, Search),
|
||||
atom_number(AtomVal, Val),
|
||||
http_session_retract(formula(Formula0)),
|
||||
debug(calc, 'Formula0 = ~w', [Formula0]),
|
||||
Formula =.. [Op, Formula0, Val],
|
||||
http_session_assert(formula(Formula)),
|
||||
page(Formula).
|
||||
|
||||
|
||||
page(Formula) :-
|
||||
reply_page('HTTP Session DEMO',
|
||||
[ h2('Simple session demo'),
|
||||
form([ action('/calc'),
|
||||
method('GET')
|
||||
],
|
||||
table([align(center), border(1)],
|
||||
[ tr(td(\formula(Formula))),
|
||||
tr(td([ \ops,
|
||||
input([ name(value) ]),
|
||||
input([ type(submit),
|
||||
value('Calc!')
|
||||
])
|
||||
]))
|
||||
]))
|
||||
]).
|
||||
|
||||
formula(Formula) -->
|
||||
{ sformat(S, '~w', [Formula]),
|
||||
Value is Formula
|
||||
},
|
||||
html([ S, ' = ', Value ]).
|
||||
|
||||
ops -->
|
||||
html(select(name(operation),
|
||||
[ option([selected], +),
|
||||
option([], -),
|
||||
option([], /),
|
||||
option([], *)
|
||||
])).
|
||||
|
||||
reply_page(Title, Content) :-
|
||||
phrase(page(title(Title), Content), HTML),
|
||||
format('Content-type: text/html~n~n'),
|
||||
print_html(HTML).
|
||||
212
packages/http/examples/demo_body.pl
Normal file
212
packages/http/examples/demo_body.pl
Normal file
@ -0,0 +1,212 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2002, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(demo_body,
|
||||
[ reply/1
|
||||
]).
|
||||
:- use_module(library('http/http_client')).
|
||||
:- use_module(library('http/http_mime_plugin')). % Decode multipart data
|
||||
:- use_module(library('http/http_image')). % make XPCE generate images
|
||||
|
||||
|
||||
:- style_check(-atom). % allow long atoms
|
||||
|
||||
reply(_) :-
|
||||
flag(request, N, N+1),
|
||||
fail.
|
||||
|
||||
% /quit
|
||||
%
|
||||
% Explicitely close the connection
|
||||
|
||||
reply(Request) :-
|
||||
member(path('/quit'), Request), !,
|
||||
format('Connection: close~n', []),
|
||||
format('Content-type: text/html~n~n', []),
|
||||
format('Bye Bye~n').
|
||||
|
||||
% /xpce?class=box
|
||||
%
|
||||
% Make XPCE reply with a graphics image. The demo-body pce_reply/1
|
||||
% is called embedded in a message to XPCE to force the XPCE
|
||||
% incremental garbage collector to reclaim objects created while
|
||||
% serving the request. pce_reply/1 replies to ?class=box using a
|
||||
% blue box with rounded corners.
|
||||
|
||||
reply(Request) :-
|
||||
member(path('/xpce'), Request), !,
|
||||
send(@prolog, call, demo_body:pce_reply(Request)).
|
||||
|
||||
% /env
|
||||
%
|
||||
% Reply with the output of printenv (Unix systems only).
|
||||
|
||||
reply(Request) :-
|
||||
member(path('/env'), Request), !,
|
||||
expand_file_name(~, Home),
|
||||
format('Content-type: text/html~n~n', []),
|
||||
format('<html>~n', []),
|
||||
flag(request, RN, RN),
|
||||
format('Request ~d~n', [RN]),
|
||||
format('<pre>~n', []),
|
||||
format('HOME = ~w~n~n', [Home]),
|
||||
open(pipe(printenv), read, Fd),
|
||||
copy_stream_data(Fd, current_output),
|
||||
close(Fd),
|
||||
format('</pre>~n', []),
|
||||
format('</html>~n', []).
|
||||
|
||||
% /upload
|
||||
% /upload_reply
|
||||
%
|
||||
% Provide a form for uploading a file, and deal with the resulting
|
||||
% upload. Contributed by Nicos Angelopoulos.
|
||||
|
||||
reply(Request) :-
|
||||
member(path('/upload'), Request), !,
|
||||
format('Content-type: text/html~n~n', []),
|
||||
format('<html>~n', []),
|
||||
format('<form action="/upload_reply" enctype="multipart/form-data" method="post">~n', []),
|
||||
format('<input type="file" name="datafile">'),
|
||||
format('<input type="submit" name="sent">'),
|
||||
format('</body>~n', []),
|
||||
format('</html>~n', []).
|
||||
|
||||
reply(Request) :-
|
||||
member(path('/upload_reply'), Request), !,
|
||||
format('Content-type: text/html~n~n', []),
|
||||
format('<html>~n', []),
|
||||
format('<pre>~n', []),
|
||||
write( req(Request) ), nl,
|
||||
http_read_data(Request, Data, []),
|
||||
write( data(Data) ), nl,
|
||||
format('</pre>'),
|
||||
format('</body>~n', []),
|
||||
format('</html>~n', []).
|
||||
|
||||
% /xml
|
||||
%
|
||||
% Return a simple formatted XML message.
|
||||
|
||||
reply(Request) :-
|
||||
member(path('/xml'), Request), !,
|
||||
format('Content-type: text/xml~n~n', []),
|
||||
format('\
|
||||
<message>
|
||||
<head>
|
||||
<from>Jan Wielemaker</from>
|
||||
<to>Prolog users</to>
|
||||
<subject>The SWI-Prolog web-server</subject>
|
||||
</head>
|
||||
<body>
|
||||
<p>
|
||||
This is the first demo of the web-server serving an XML message
|
||||
</p>
|
||||
</body>
|
||||
</message>
|
||||
', []).
|
||||
|
||||
% /foreign
|
||||
%
|
||||
% Test emitting text using UTF-8 encoding
|
||||
|
||||
reply(Request) :-
|
||||
member(path('/foreign'), Request), !,
|
||||
format('Content-type: text/html~n~n', []),
|
||||
format('\
|
||||
<html>
|
||||
<head><title>Foreign characters</title></head>
|
||||
<body>
|
||||
<p>Chinese for book is ~s
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
[ [23398, 20064]
|
||||
]).
|
||||
|
||||
|
||||
% /work
|
||||
%
|
||||
% Do a lot of work and then say 'ok'. Can be used to test
|
||||
% concurrent access using the multi-threaded server.
|
||||
|
||||
reply(Request) :-
|
||||
member(path('/work'), Request),
|
||||
format(user_error, 'Starting work ...', []),
|
||||
forall(between(1, 10000000, _), atom_codes(_, "hello")),
|
||||
format(user_error, 'done!~n', []),
|
||||
format('Content-type: text/plain~n~n', []),
|
||||
format('ok~n').
|
||||
|
||||
% /error
|
||||
%
|
||||
% Produce an error. Load http_error to see the effect.
|
||||
|
||||
reply(Request) :-
|
||||
member(path('/error'), Request),
|
||||
A is 1/0,
|
||||
format('Content-type: text/plain~n~n', []),
|
||||
format('A = ~w~n', [A]).
|
||||
|
||||
% ... Otherwise
|
||||
%
|
||||
% Print the request itself.
|
||||
|
||||
reply(Request) :-
|
||||
format('Content-type: text/html~n~n', []),
|
||||
format('<html>~n', []),
|
||||
format('<table border=1>~n'),
|
||||
print_request(Request),
|
||||
format('~n</table>~n'),
|
||||
format('</html>~n', []).
|
||||
|
||||
|
||||
print_request([]).
|
||||
print_request([H|T]) :-
|
||||
H =.. [Name, Value],
|
||||
format('<tr><td>~w<td>~w~n', [Name, Value]),
|
||||
print_request(T).
|
||||
|
||||
|
||||
/*******************************
|
||||
* PCE BASED REQUESTS *
|
||||
*******************************/
|
||||
|
||||
pce_reply(Request) :-
|
||||
memberchk(search(Search), Request),
|
||||
memberchk(class=box, Search),
|
||||
new(Box, box(200,200)),
|
||||
send(Box, radius, 20),
|
||||
send(Box, fill_pattern, colour(skyblue)),
|
||||
reply_image(Box, []).
|
||||
|
||||
|
||||
|
||||
161
packages/http/examples/demo_client.pl
Normal file
161
packages/http/examples/demo_client.pl
Normal file
@ -0,0 +1,161 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2002, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- use_module(library('http/http_client')).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library('http/http_sgml_plugin')).
|
||||
|
||||
|
||||
% stress(+Times, +Threads, +URLOrAlias)
|
||||
%
|
||||
% Typical use: stress(1000, 3, 1): run the test 1000 times with
|
||||
% 3 client threads on the /xml test from demo_body.pl and verify
|
||||
% the parsed result.
|
||||
|
||||
stress(Times, Parallel, Alias) :-
|
||||
answer(Alias, URL, _), !,
|
||||
stress(Times, Parallel, URL).
|
||||
stress(Times, Parallel, URL) :-
|
||||
( pool(pool, _)
|
||||
-> delete_pool(pool)
|
||||
; true
|
||||
),
|
||||
create_pool(pool, Parallel),
|
||||
stress(Times, URL),
|
||||
wait_done(Times),
|
||||
delete_pool(pool).
|
||||
|
||||
wait_done(0) :- !.
|
||||
wait_done(N) :-
|
||||
thread_get_message(done, Result),
|
||||
put(Result), flush,
|
||||
N1 is N - 1,
|
||||
wait_done(N1).
|
||||
|
||||
stress(0, _) :- !.
|
||||
stress(N, URL) :-
|
||||
thread_send_message(pool, stress_url(URL)),
|
||||
NN is N - 1,
|
||||
stress(NN, URL).
|
||||
|
||||
stress_url(URL) :-
|
||||
thread_self(Me),
|
||||
atom_number(N, Me),
|
||||
( catch(http_get(URL, X, [connection(close)]), E, true)
|
||||
-> ( var(E)
|
||||
-> ( answer(_, URL, Correct)
|
||||
-> ( X == Correct
|
||||
-> thread_send_message(done, N)
|
||||
; thread_send_message(done, !)
|
||||
)
|
||||
; thread_send_message(done, ?)
|
||||
)
|
||||
; print_message(error, E),
|
||||
thread_send_message(done, 'E')
|
||||
)
|
||||
; thread_send_message(done, -)
|
||||
).
|
||||
|
||||
:- dynamic
|
||||
pool/2. % name, threads
|
||||
|
||||
create_pool(Name, N) :-
|
||||
message_queue_create(Name),
|
||||
findall(Id, (between(1, N, _),
|
||||
thread_create(worker(Name), Id, [])), Threads),
|
||||
assert(pool(Name, Threads)).
|
||||
|
||||
|
||||
delete_pool(Name) :-
|
||||
pool(Name, Threads),
|
||||
forall(member(_, Threads), thread_send_message(Name, thread_exit(ok))),
|
||||
forall(member(Id, Threads), thread_join(Id, _)),
|
||||
message_queue_destroy(Name),
|
||||
retract(pool(Name, Threads)).
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
worker(Queue) :-
|
||||
repeat,
|
||||
thread_get_message(Queue, Goal),
|
||||
( catch(Goal, E, true)
|
||||
-> ( var(E)
|
||||
-> true
|
||||
; print_message(error, E)
|
||||
)
|
||||
; print_message(error, goal_failed(Goal))
|
||||
),
|
||||
fail.
|
||||
|
||||
|
||||
/*******************************
|
||||
* CORRECT ANSWERS *
|
||||
*******************************/
|
||||
|
||||
|
||||
answer(1, 'http://localhost:3000/xml',
|
||||
[ element(message,
|
||||
[],
|
||||
[ '\n ',
|
||||
element(head,
|
||||
[],
|
||||
[ '\n ',
|
||||
element(from,
|
||||
[],
|
||||
[ 'Jan Wielemaker'
|
||||
]),
|
||||
'\n ',
|
||||
element(to,
|
||||
[],
|
||||
[ 'Prolog users'
|
||||
]),
|
||||
'\n ',
|
||||
element(subject,
|
||||
[],
|
||||
[ 'The SWI-Prolog web-server'
|
||||
]),
|
||||
'\n '
|
||||
]),
|
||||
'\n ',
|
||||
element(body,
|
||||
[],
|
||||
[ '\n',
|
||||
element(p,
|
||||
[],
|
||||
[ '\nThis is the first demo of the web-server serving an XML message\n'
|
||||
]),
|
||||
'\n '
|
||||
]),
|
||||
'\n'
|
||||
])
|
||||
]).
|
||||
50
packages/http/examples/demo_files.pl
Normal file
50
packages/http/examples/demo_files.pl
Normal file
@ -0,0 +1,50 @@
|
||||
:- use_module(library(http/thread_httpd)).
|
||||
:- use_module(library(http/html_write)).
|
||||
:- use_module(library(http/http_dispatch)).
|
||||
:- use_module(library(http/http_dirindex)).
|
||||
|
||||
:- http_handler(root(.), serve_files, [prefix]).
|
||||
|
||||
%% server(+Port, +DirSpec) is det.
|
||||
%
|
||||
% Start the server at port Port, serving directories below
|
||||
% DirSpec. DirSpec may contain ~ and $var.
|
||||
%
|
||||
% This simple example defines a complete web-server for static
|
||||
% pages. Note that more specific handlers than the bave (i.e.
|
||||
% using a longer path) have priority over this handler and can
|
||||
% thus be used to add dynamic parts to your server.
|
||||
|
||||
server(Port, DirSpec) :-
|
||||
expand_file_name(DirSpec, [Dir]),
|
||||
assert(user:file_search_path(document_root, Dir)),
|
||||
http_server(http_dispatch, [port(Port)]).
|
||||
|
||||
%% serve_files(Request)
|
||||
%
|
||||
% Server a file or directory according to the path_info field,
|
||||
% which contains the path *after* the http-location matched by the
|
||||
% handler. If the handler is matched *exactly*, path_info is
|
||||
% missing.
|
||||
%
|
||||
% http_safe_file/1 checks the path for attempts to escape from the
|
||||
% hierarchy defined by the =document_root= alias. We find the path
|
||||
% before calling one of the two reply functions because we want to
|
||||
% know whether we are dealing with a directory or a file. After
|
||||
% that, the path is absolute and we must pass unsafe(true) to
|
||||
% avoid the path-checker in the reply-functions complaining.
|
||||
|
||||
serve_files(Request) :-
|
||||
( memberchk(path_info(PathInfo), Request)
|
||||
-> true
|
||||
; PathInfo = './'
|
||||
),
|
||||
http_safe_file(document_root(PathInfo), []),
|
||||
absolute_file_name(document_root(PathInfo), Path,
|
||||
[ access(read)] ),
|
||||
( exists_directory(Path)
|
||||
-> http_reply_dirindex(Path, [unsafe(true)], Request)
|
||||
; http_reply_file(Path, [unsafe(true)], Request)
|
||||
).
|
||||
|
||||
|
||||
18
packages/http/examples/demo_inetd
Executable file
18
packages/http/examples/demo_inetd
Executable file
@ -0,0 +1,18 @@
|
||||
#!/usr/bin/pl -t main -q -f
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi.psy.uva.nl/projects/SWI-Prolog/
|
||||
Copying: GPL-2. See the file COPYING or http://www.gnu.org
|
||||
|
||||
Copyright (C) 1990-2001 SWI, University of Amsterdam. All rights reserved.
|
||||
*/
|
||||
|
||||
:- use_module(demo_body).
|
||||
:- use_module(library('http/inetd_httpd')).
|
||||
|
||||
main :-
|
||||
http_server(reply, []).
|
||||
173
packages/http/examples/demo_openid.pl
Normal file
173
packages/http/examples/demo_openid.pl
Normal file
@ -0,0 +1,173 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2007-2010, University of Amsterdam,
|
||||
VU University Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
|
||||
:- asserta(file_search_path(library, '..')).
|
||||
|
||||
:- use_module(library(uri)).
|
||||
:- use_module(library(http/http_openid)).
|
||||
:- use_module(library(http/http_host)).
|
||||
:- use_module(library(http/http_dispatch)).
|
||||
:- use_module(library(http/http_path)).
|
||||
:- use_module(library(http/thread_httpd)).
|
||||
:- use_module(library(http/html_write)).
|
||||
:- use_module(library(http/http_error)).
|
||||
|
||||
http:location(openid, root(openid), []).
|
||||
|
||||
:- multifile
|
||||
http_openid:openid_hook/1.
|
||||
|
||||
http_openid:openid_hook(trusted(_OpenID, Server)) :-
|
||||
debug(openid(test), 'Trusting server ~q', [Server]).
|
||||
|
||||
|
||||
%% server
|
||||
%
|
||||
% Create demo server and client. After starting the server,
|
||||
% contact http://localhost:8000/
|
||||
|
||||
server :-
|
||||
debug(openid(_)),
|
||||
Port = 8000,
|
||||
http_server(http_dispatch,
|
||||
[ port(Port)
|
||||
]),
|
||||
debug(openid(test), 'Server started at http://localhost:~w/', [Port]).
|
||||
|
||||
|
||||
assoc :-
|
||||
openid_associate('http://localhost:8000/openid/server', Handle, Assoc),
|
||||
writeln(Handle-Assoc).
|
||||
|
||||
%% secret(+Request) is det.
|
||||
%
|
||||
% Example of a handler that requires an OpenID login. If the user
|
||||
% is not logged it, it will be redirected to the login page, from
|
||||
% there to the OpenID server and back here. All this is completely
|
||||
% transparent to us.
|
||||
|
||||
:- http_handler(root('secret'), secret, []).
|
||||
|
||||
secret(Request) :-
|
||||
openid_user(Request, User, []),
|
||||
reply_html_page(title('Secret'),
|
||||
[ 'You\'ve reached the secret page as user ', %'
|
||||
a(href(User), User)
|
||||
]).
|
||||
|
||||
%% root(+Request).
|
||||
%% allow(+Request).
|
||||
%
|
||||
% Shows an indirect login.
|
||||
|
||||
:- http_handler(root(.), root, []).
|
||||
:- http_handler(root('test/verify'), openid_verify([return_to(allow)]), []).
|
||||
:- http_handler(root('test/allow'), allow, []).
|
||||
|
||||
root(_Request) :-
|
||||
reply_html_page(title('Demo OpenID consumer'),
|
||||
[ h1('OpenID consumer'),
|
||||
form([ name(login),
|
||||
action('/test/verify'),
|
||||
method('GET')
|
||||
],
|
||||
[ div([ 'OpenID: ',
|
||||
input([ name(openid_url),
|
||||
size(40),
|
||||
value('http://localhost:8000/user/bob') % test
|
||||
]),
|
||||
input([type(submit), value('Verify!')])
|
||||
])
|
||||
]),
|
||||
p([ 'Or go directly to the ', a(href=secret, 'secret page') ])
|
||||
]).
|
||||
|
||||
|
||||
allow(Request) :-
|
||||
openid_authenticate(Request, Server, Identity, _ReturnTo),
|
||||
reply_html_page(title('Success'),
|
||||
[ h1('OpenID login succeeded'),
|
||||
p([ 'The OpenID server ',
|
||||
a(href(Server),Server),
|
||||
' verified you as ',
|
||||
a(href(Identity), Identity)
|
||||
])
|
||||
]).
|
||||
|
||||
|
||||
/*******************************
|
||||
* OpenID SERVER *
|
||||
*******************************/
|
||||
|
||||
:- http_handler(root('user/'), user_page, [prefix]).
|
||||
:- http_handler(openid(server), openid_server([]), []).
|
||||
:- http_handler(openid(grant), openid_grant, []).
|
||||
|
||||
:- multifile
|
||||
http_openid:openid_hook/1.
|
||||
|
||||
http_openid:openid_hook(grant(_Request, Options)) :-
|
||||
debug(openid(test), 'Granting access to ~p', [Options]).
|
||||
|
||||
%% user_page(+Request) is det.
|
||||
%
|
||||
% Generate a page for user as /user/<user>.
|
||||
|
||||
user_page(Request) :-
|
||||
http_current_host(Request, Host, Port,
|
||||
[ global(true)
|
||||
]),
|
||||
http_location_by_id(openid_server, ServerLocation),
|
||||
uri_authority_data(host, AComp, Host),
|
||||
uri_authority_data(port, AComp, Port),
|
||||
uri_authority_components(Authority, AComp),
|
||||
uri_data(scheme, Components, http),
|
||||
uri_data(authority, Components, Authority),
|
||||
uri_data(path, Components, ServerLocation),
|
||||
uri_components(OpenIDServer, Components),
|
||||
memberchk(path_info(User), Request),
|
||||
reply_html_page([ link([ rel('openid.server'),
|
||||
href(OpenIDServer)
|
||||
]),
|
||||
title('OpenID page of ~w'-[User])
|
||||
],
|
||||
h1('OpenID page of ~w'-[User])).
|
||||
|
||||
|
||||
/*******************************
|
||||
* DEBUG *
|
||||
*******************************/
|
||||
|
||||
:- http_handler(root(.), print_request, [prefix]).
|
||||
|
||||
print_request(Request) :-
|
||||
format('Content-type: text/plain~n~n'),
|
||||
pp(Request).
|
||||
20
packages/http/examples/demo_pwp.pl
Normal file
20
packages/http/examples/demo_pwp.pl
Normal file
@ -0,0 +1,20 @@
|
||||
:- use_module(library(http/thread_httpd)).
|
||||
:- use_module(library(http/http_parameters)).
|
||||
:- use_module(library(http/http_dispatch)).
|
||||
:- use_module(library(http/http_error)).
|
||||
:- use_module(library(http/html_write)).
|
||||
:- use_module(library(http/http_pwp)).
|
||||
|
||||
:- prolog_load_context(directory, Dir),
|
||||
asserta(user:file_search_path(http_demo, Dir)).
|
||||
|
||||
user:file_search_path(pwp_demo, http_demo(pwp)).
|
||||
|
||||
:- http_handler(root(.),
|
||||
pwp_handler([path_alias(pwp_demo), view(true)]),
|
||||
[prefix]).
|
||||
|
||||
server(Port) :-
|
||||
http_server(http_dispatch, [port(Port)]).
|
||||
|
||||
|
||||
30
packages/http/examples/demo_threads.pl
Normal file
30
packages/http/examples/demo_threads.pl
Normal file
@ -0,0 +1,30 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi.psy.uva.nl/projects/SWI-Prolog/
|
||||
Copying: GPL-2. See the file COPYING or http://www.gnu.org
|
||||
|
||||
Copyright (C) 1990-2001 SWI, University of Amsterdam. All rights reserved.
|
||||
*/
|
||||
|
||||
:- load_files([ demo_body,
|
||||
library('http/thread_httpd')
|
||||
],
|
||||
[ silent(true)
|
||||
]).
|
||||
|
||||
server :-
|
||||
server(3000, []).
|
||||
|
||||
server(Port, Options) :-
|
||||
http_server(reply,
|
||||
[ port(Port),
|
||||
timeout(20)
|
||||
| Options
|
||||
]).
|
||||
|
||||
tm :-
|
||||
prolog_ide(thread_monitor).
|
||||
40
packages/http/examples/demo_xpce.pl
Normal file
40
packages/http/examples/demo_xpce.pl
Normal file
@ -0,0 +1,40 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2002, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- use_module(library('http/xpce_httpd')).
|
||||
:- use_module(demo_body).
|
||||
|
||||
server(Port) :-
|
||||
http_server(reply,
|
||||
[ port(Port)
|
||||
]).
|
||||
|
||||
|
||||
23
packages/http/examples/pwp/context.pwp
Normal file
23
packages/http/examples/pwp/context.pwp
Normal file
@ -0,0 +1,23 @@
|
||||
<?xml version="1.0"?>
|
||||
<!DOCTYPE html>
|
||||
|
||||
<html xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl">
|
||||
|
||||
<head>
|
||||
<title>Context variables for PWP scripts</title>
|
||||
</head>
|
||||
<body>
|
||||
<p>This PWP demo lists the context-parameters that are passed into
|
||||
the script.
|
||||
</p>
|
||||
<ul>
|
||||
<li pwp:ask="member(Name=Value, CONTEXT)">
|
||||
<span class=name pwp:use="Name"/>
|
||||
=
|
||||
<span class=value pwp:use="writeq(Value)"/>
|
||||
</li>
|
||||
</ul>
|
||||
</body>
|
||||
|
||||
</html>
|
||||
|
||||
25
packages/http/examples/pwp/index.pwp
Normal file
25
packages/http/examples/pwp/index.pwp
Normal file
@ -0,0 +1,25 @@
|
||||
<?xml version="1.0"?>
|
||||
<!DOCTYPE html>
|
||||
|
||||
<html xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl">
|
||||
|
||||
<head>
|
||||
<title>Index for PWP demos</title>
|
||||
</head>
|
||||
<body pwp:ask="atom_concat(SCRIPT_DIRECTORY, /, Prefix),
|
||||
atom_concat(Prefix, '*.pwp', Pattern),
|
||||
expand_file_name(Pattern, Paths),
|
||||
maplist(atom_concat(Prefix), Files, Paths)">
|
||||
|
||||
<h1>PWP scripts in this directory</h1>
|
||||
|
||||
<ul>
|
||||
<li pwp:ask="member(F, Files), F \== 'index.pwp'">
|
||||
<a pwp:use="F" pwp:att="$" href="$(F)$"/>
|
||||
<a pwp:att="$" href="$(F)$?view=source">source</a>
|
||||
</li>
|
||||
</ul>
|
||||
</body>
|
||||
|
||||
</html>
|
||||
|
||||
12
packages/http/examples/pwp/pwp1.pwp
Normal file
12
packages/http/examples/pwp/pwp1.pwp
Normal file
@ -0,0 +1,12 @@
|
||||
<?xml version="1.0"?>
|
||||
|
||||
<html
|
||||
xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl"
|
||||
pwp:ask = "ensure_loaded(pwp(pwpdb)), once(msg(Greeting))">
|
||||
<head>
|
||||
<title pwp:use="Greeting"/>
|
||||
</head>
|
||||
<body>
|
||||
<p><span pwp:use="Greeting" pwp:tag='-'/></p>
|
||||
</body>
|
||||
</html>
|
||||
10
packages/http/examples/pwp/pwp2.pwp
Normal file
10
packages/http/examples/pwp/pwp2.pwp
Normal file
@ -0,0 +1,10 @@
|
||||
<?xml version="1.0"?>
|
||||
|
||||
<html
|
||||
xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl">
|
||||
<head><title>Example 2</title></head>
|
||||
<body pwp:ask="Hello = 'Hello world', A = 20, B = 22">
|
||||
<h1 pwp:use="Hello"/>
|
||||
<p>The answer is <span pwp:tag='-' pwp:use="C" pwp:ask="C is A+B"/>.</p>
|
||||
</body>
|
||||
</html>
|
||||
25
packages/http/examples/pwp/pwp3.pwp
Normal file
25
packages/http/examples/pwp/pwp3.pwp
Normal file
@ -0,0 +1,25 @@
|
||||
<?xml version="1.0"?>
|
||||
|
||||
<html
|
||||
xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl"
|
||||
pwp:ask='ensure_loaded(pwp(pwpdb))'>
|
||||
<head>
|
||||
<title>Phone list for Full-Time staff.</title>
|
||||
</head>
|
||||
<body>
|
||||
<h1>Phone list for Full-Time staff.</h1>
|
||||
<table
|
||||
pwp:ask = "setof(FullName-Phone,
|
||||
N^O^E^(
|
||||
status(N, full_time),
|
||||
staff(N, FullName, O, Phone, E)
|
||||
),
|
||||
Staff_List)">
|
||||
<tr><th>Name</th><th>Phone</th></tr>
|
||||
<tr pwp:ask="member(FullName-Phone, Staff_List)">
|
||||
<td pwp:use="FullName"/>
|
||||
<td pwp:use="Phone"/>
|
||||
</tr>
|
||||
</table>
|
||||
</body>
|
||||
</html>
|
||||
23
packages/http/examples/pwp/pwp4.pwp
Normal file
23
packages/http/examples/pwp/pwp4.pwp
Normal file
@ -0,0 +1,23 @@
|
||||
<?xml version="1.0"?>
|
||||
|
||||
<html
|
||||
xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl"
|
||||
pwp:ask='ensure_loaded(pwp(pwpdb))'>
|
||||
<head>
|
||||
<title>Phone list for Full-Time staff.</title>
|
||||
</head>
|
||||
<body>
|
||||
<h1>Phone list for Full-Time staff.</h1>
|
||||
<table
|
||||
pwp:ask = "setof(FullName-E_Mail,
|
||||
N^O^P^staff(N, FullName, O, P, E_Mail),
|
||||
Staff_List)">
|
||||
<tr><th>Name</th><th>Address</th></tr>
|
||||
<tr pwp:ask="member(FullName-E_Mail, Staff_List)">
|
||||
<td pwp:use="FullName"/>
|
||||
<td><a pwp:use="E_Mail"
|
||||
pwp:att='$' href="mailto:$(E_Mail)$"/></td>
|
||||
</tr>
|
||||
</table>
|
||||
</body>
|
||||
</html>
|
||||
11
packages/http/examples/pwp/pwp5.pwp
Normal file
11
packages/http/examples/pwp/pwp5.pwp
Normal file
@ -0,0 +1,11 @@
|
||||
<?xml version="1.0"?>
|
||||
|
||||
<html
|
||||
xmlns:pwp="http://www.cs.otago.ac.nz/staffpriv/ok/pwp.pl">
|
||||
<head><title>$SHELL</title></head>
|
||||
<body>
|
||||
<p pwp:ask="getenv('SHELL', Shell)"
|
||||
>The default shell is <span pwp:tag="-" pwp:use="Shell"/>.</p>
|
||||
<p pwp:ask="\+getenv('SHELL',_)">There is no default shell.</p>
|
||||
</body>
|
||||
</html>
|
||||
3
packages/http/examples/pwp/pwp6.pwp
Normal file
3
packages/http/examples/pwp/pwp6.pwp
Normal file
@ -0,0 +1,3 @@
|
||||
<?xml version="1.0"?>
|
||||
|
||||
<a>b</a>
|
||||
3
packages/http/examples/pwp/pwp7.pwp
Normal file
3
packages/http/examples/pwp/pwp7.pwp
Normal file
@ -0,0 +1,3 @@
|
||||
<?xml version="1.0"?>
|
||||
|
||||
<a><b pwp:use='27' pwp:tag='-'/></a>
|
||||
3
packages/http/examples/pwp/pwp8.pwp
Normal file
3
packages/http/examples/pwp/pwp8.pwp
Normal file
@ -0,0 +1,3 @@
|
||||
<?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
Normal file
12
packages/http/examples/pwp/pwpdb.pl
Normal file
@ -0,0 +1,12 @@
|
||||
% This is a tiny data base for testing PWP.
|
||||
|
||||
msg('Hello, World!').
|
||||
|
||||
status(tom, full_time).
|
||||
status(dick, part_time).
|
||||
status(harry, full_time).
|
||||
|
||||
staff(tom, 'Tom Cat', 1-21, 'x1234', 'tom@jerry.example.org').
|
||||
staff(dick, 'Dick Tater', 2-50, 'x9999', 'boss@hq.example.org').
|
||||
staff(harry, 'Harry Ett', 3-14, 'x7654', 'h.ett@kit.example.org').
|
||||
|
||||
52
packages/http/examples/stress_client.pl
Normal file
52
packages/http/examples/stress_client.pl
Normal file
@ -0,0 +1,52 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2007, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_stress_client,
|
||||
[ client/2, % +Port, +Test
|
||||
client/3 % +Port, +Test, +Times
|
||||
]).
|
||||
|
||||
:- use_module(library(http/http_client)).
|
||||
|
||||
/** <module> Sample HTTP client to run some stress tests
|
||||
|
||||
*/
|
||||
|
||||
client(Port, Action, Times) :-
|
||||
forall(between(1, Times, _),
|
||||
client(Port, Action)).
|
||||
|
||||
|
||||
client(Port, ping) :-
|
||||
http_get([ host(localhost),
|
||||
port(Port),
|
||||
path('/ping')
|
||||
], _, []).
|
||||
129
packages/http/examples/stress_server.pl
Normal file
129
packages/http/examples/stress_server.pl
Normal file
@ -0,0 +1,129 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2007, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_stress_server,
|
||||
[ server/1, % +Port
|
||||
profile/0
|
||||
]).
|
||||
:- load_files([ library(http/thread_httpd),
|
||||
library(http/html_write),
|
||||
library(http/http_session),
|
||||
library(http/http_dispatch),
|
||||
library(http/http_parameters),
|
||||
library(http/http_error),
|
||||
library(thread_pool)
|
||||
],
|
||||
[ silent(true)
|
||||
]).
|
||||
|
||||
/** <module> Sample HTTP server to run some stress tests
|
||||
|
||||
*/
|
||||
|
||||
%% server(+Port) is det.
|
||||
%
|
||||
% Start the server at Port.
|
||||
|
||||
server(Port) :-
|
||||
create_pools,
|
||||
server(Port,
|
||||
[ workers(1)
|
||||
]).
|
||||
|
||||
server(Port, Options) :-
|
||||
http_server(http_dispatch,
|
||||
[ port(Port),
|
||||
timeout(20)
|
||||
| Options
|
||||
]).
|
||||
|
||||
%% create_pools
|
||||
%
|
||||
% Create our thread pools.
|
||||
|
||||
create_pools :-
|
||||
thread_pool_create(single, 1, [backlog(0)]).
|
||||
|
||||
%% profile
|
||||
%
|
||||
% Run thread profiler on the one and only server.
|
||||
|
||||
profile :-
|
||||
findall(Id, http_current_worker(_, Id), Ids),
|
||||
( Ids = [Id]
|
||||
-> tprofile(Id)
|
||||
; Ids == []
|
||||
-> format(user_error, 'No HTTP server!~n', []),
|
||||
fail
|
||||
; format(user_error, 'Multiple HTPP workers: ~p~n', [Ids]),
|
||||
fail
|
||||
).
|
||||
|
||||
|
||||
/*******************************
|
||||
* METHODS *
|
||||
*******************************/
|
||||
|
||||
:- http_handler('/ping', ping, []).
|
||||
:- http_handler('/wait', wait, [chunked]).
|
||||
:- http_handler(prefix('/spawn/'), spawn, [spawn(single)]).
|
||||
:- http_handler(prefix('/spawn2/'), spawn, [spawn(single)]).
|
||||
|
||||
ping(_Request) :-
|
||||
format('Content-type: text/plain~n~n'),
|
||||
format('alife~n').
|
||||
|
||||
wait(Request) :-
|
||||
http_parameters(Request,
|
||||
[ wait(Time, [default(1)]),
|
||||
count(N, [default(10)])
|
||||
]),
|
||||
wait(Time, N).
|
||||
|
||||
wait(Time, N) :-
|
||||
format('Content-type: text/plain~n~n'),
|
||||
forall(between(1, N, I),
|
||||
( sleep(Time),
|
||||
format('~D~n', [I]),
|
||||
flush_output
|
||||
)).
|
||||
|
||||
%% spawn(+Request)
|
||||
%
|
||||
% Run requests under /spawn/ in their own thread.
|
||||
|
||||
spawn(Request) :-
|
||||
selectchk(path(Path), Request, Request1),
|
||||
( sub_atom(Path, Start, _, _, /), Start > 0
|
||||
-> sub_atom(Path, Start, _, 0, NewPath)
|
||||
),
|
||||
http_dispatch([path(NewPath)|Request1]).
|
||||
|
||||
1
packages/http/figs/.cvsignore
Normal file
1
packages/http/figs/.cvsignore
Normal file
@ -0,0 +1 @@
|
||||
*.pdf
|
||||
384
packages/http/figs/httpserver.eps
Normal file
384
packages/http/figs/httpserver.eps
Normal file
@ -0,0 +1,384 @@
|
||||
%!PS-Adobe-3.0 EPSF-3.0
|
||||
%%Creator: PCE 6.6.35, June 2007
|
||||
%%CreationDate: (Thu Jun 7 16:13:39 2007)
|
||||
%%Pages: 1
|
||||
%%DocumentFonts: (atend)
|
||||
%%BoundingBox: 70 70 570 361
|
||||
%%Object: @2548888/draw_canvas
|
||||
%%EndComments
|
||||
|
||||
/draw
|
||||
{ 0 currentlinewidth ne
|
||||
{ currentdash 0 eq exch [] eq and not
|
||||
{ gsave nodash 1 setgray stroke grestore
|
||||
} if
|
||||
stroke
|
||||
} if
|
||||
} def
|
||||
|
||||
/pspen
|
||||
{ 2 div
|
||||
} def
|
||||
|
||||
/pen
|
||||
{ pspen
|
||||
setlinewidth
|
||||
} def
|
||||
|
||||
/boxpath
|
||||
{ /r exch def
|
||||
/h exch def
|
||||
/w exch def
|
||||
/y exch def
|
||||
/x exch def
|
||||
/p exch def
|
||||
|
||||
r 0 eq
|
||||
{ 2 setlinecap newpath
|
||||
x p pspen add y p pspen add moveto
|
||||
w p sub 0 rlineto
|
||||
0 h p sub rlineto
|
||||
w p sub neg 0 rlineto
|
||||
0 h p sub neg rlineto
|
||||
}
|
||||
{ newpath
|
||||
/pr r p pspen add def
|
||||
x pr add y p pspen add moveto
|
||||
x w add pr sub y pr add r 270 360 arc
|
||||
x w add pr sub y h add pr sub r 0 90 arc
|
||||
x pr add y h add pr sub r 90 180 arc
|
||||
x pr add y pr add r 180 270 arc
|
||||
} ifelse
|
||||
|
||||
p pen
|
||||
} def
|
||||
|
||||
/nodash
|
||||
{ [] 0 setdash
|
||||
} def
|
||||
|
||||
/text
|
||||
{ /s exch def
|
||||
/w exch def
|
||||
|
||||
gsave
|
||||
1 eq { invert } if
|
||||
moveto s stringwidth pop w exch div -1 scale s show
|
||||
grestore
|
||||
} def
|
||||
|
||||
/startpath
|
||||
{ newpath moveto pen
|
||||
} def
|
||||
|
||||
/linepath
|
||||
{ /h exch def
|
||||
/w exch def
|
||||
newpath moveto w h rlineto
|
||||
pen
|
||||
} def
|
||||
|
||||
/dotted
|
||||
{ [1 5] 0 setdash
|
||||
} def
|
||||
|
||||
gsave
|
||||
|
||||
70 70 translate
|
||||
0.83 -0.83 scale
|
||||
-196 -425 translate
|
||||
%%EndProlog
|
||||
%%Page 0 1
|
||||
|
||||
%%Object: @2548888/draw_canvas
|
||||
gsave 0 0 translate 0.00 0.00 0.00 setrgbcolor
|
||||
|
||||
%%Object: @2787654/cml_drole
|
||||
gsave 222 158 translate
|
||||
|
||||
%%Object: @2744708/box
|
||||
gsave nodash 1 0 0 100 50 0 boxpath
|
||||
draw grestore
|
||||
|
||||
%%Object: @2788290/draw_text
|
||||
grestore
|
||||
|
||||
%%Object: @2788418/cml_drole
|
||||
gsave 222 158 translate
|
||||
|
||||
%%Object: @2744846/box
|
||||
gsave nodash 1 0 0 100 50 0 boxpath
|
||||
draw grestore
|
||||
|
||||
%%Object: @2788530/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
9 30 0 82 (thread_httpd.pl) text
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2788654/cml_drole
|
||||
gsave 222 241 translate
|
||||
|
||||
%%Object: @2795026/box
|
||||
gsave nodash 1 0 0 100 50 0 boxpath
|
||||
draw grestore
|
||||
|
||||
%%Object: @2795084/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
13 30 0 73 (xpce_httpd.pl) text
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2790930/cml_drole
|
||||
gsave 222 158 translate
|
||||
|
||||
%%Object: @2791042/box
|
||||
gsave nodash 1 0 0 100 50 0 boxpath
|
||||
draw grestore
|
||||
|
||||
%%Object: @2791100/draw_text
|
||||
grestore
|
||||
|
||||
%%Object: @2791312/cml_drole
|
||||
gsave 222 325 translate
|
||||
|
||||
%%Object: @2791424/box
|
||||
gsave nodash 1 0 0 100 50 0 boxpath
|
||||
draw grestore
|
||||
|
||||
%%Object: @2791482/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
14 30 0 73 (inetd_httpd.pl) text
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2790756/cml_drole
|
||||
gsave 390 241 translate
|
||||
|
||||
%%Object: @2794830/box
|
||||
gsave nodash 1 0 0 100 50 0 boxpath
|
||||
draw grestore
|
||||
|
||||
%%Object: @2794888/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
8 30 0 84 (http_wrapper.pl) text
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2790850/draw_rect_connection
|
||||
gsave
|
||||
grestore
|
||||
|
||||
%%Object: @2795558/path
|
||||
gsave 0 0 translate nodash 1 322 203 startpath
|
||||
356 203 lineto
|
||||
356 246 lineto 390 246 lineto
|
||||
draw
|
||||
|
||||
%%Object: @draw_default_arrow/arrow
|
||||
gsave nodash 0 pen newpath 380 249 moveto 390 246 lineto 380 243 lineto closepath gsave 0.00 setgray fill grestore
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2790364/draw_rect_connection
|
||||
gsave
|
||||
grestore
|
||||
|
||||
%%Object: @2795684/path
|
||||
gsave 0 0 translate nodash 1 322 266 startpath
|
||||
390 266 lineto
|
||||
|
||||
draw
|
||||
|
||||
%%Object: @draw_default_arrow/arrow
|
||||
gsave nodash 0 pen newpath 380 269 moveto 390 266 lineto 380 263 lineto closepath gsave 0.00 setgray fill grestore
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2791228/draw_rect_connection
|
||||
gsave
|
||||
grestore
|
||||
|
||||
%%Object: @2795816/path
|
||||
gsave 0 0 translate nodash 1 322 330 startpath
|
||||
356 330 lineto
|
||||
356 286 lineto 390 286 lineto
|
||||
draw
|
||||
|
||||
%%Object: @draw_default_arrow/arrow
|
||||
gsave nodash 0 pen newpath 380 289 moveto 390 286 lineto 380 283 lineto closepath gsave 0.00 setgray fill grestore
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2793566/cml_function
|
||||
gsave 681 165 translate
|
||||
|
||||
%%Object: @2793678/box
|
||||
gsave nodash 1 0 0 100 50 25 boxpath
|
||||
draw grestore
|
||||
|
||||
%%Object: @2793736/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
18 29 0 65 (handler_1/1) text
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2795976/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
205 387 0 134 (Unix inetd based servers) text
|
||||
grestore
|
||||
|
||||
%%Object: @2796080/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
199 303 0 147 (XPCE event-driven servers) text
|
||||
grestore
|
||||
|
||||
%%Object: @2796184/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
214 220 0 117 (Multi-threaded severs) text
|
||||
grestore
|
||||
|
||||
%%Object: @2796288/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
668 115 0 126 (User's application code) text
|
||||
grestore
|
||||
|
||||
%%Object: @2796392/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
385 115 0 77 (HTTP protocol) text
|
||||
grestore
|
||||
|
||||
%%Object: @2796556/draw_line
|
||||
gsave
|
||||
dotted 1 365 75 0 328 linepath draw
|
||||
grestore
|
||||
|
||||
%%Object: @2796618/draw_line
|
||||
gsave
|
||||
dotted 1 514 80 0 328 linepath draw
|
||||
grestore
|
||||
|
||||
%%Object: @2796684/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
223 115 0 97 (Select server-type) text
|
||||
grestore
|
||||
|
||||
%%Object: @2796788/draw_line
|
||||
gsave
|
||||
dotted 1 649 78 0 328 linepath draw
|
||||
grestore
|
||||
|
||||
%%Object: @2791796/cml_drole
|
||||
gsave 533 241 translate
|
||||
|
||||
%%Object: @2794634/box
|
||||
gsave nodash 1 0 0 100 50 0 boxpath
|
||||
draw grestore
|
||||
|
||||
%%Object: @2794692/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
8 29 0 85 (http_dispatch.pl) text
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2791606/draw_rect_connection
|
||||
gsave
|
||||
grestore
|
||||
|
||||
%%Object: @2796862/path
|
||||
gsave 0 0 translate nodash 1 490 266 startpath
|
||||
533 266 lineto
|
||||
|
||||
draw
|
||||
|
||||
%%Object: @draw_default_arrow/arrow
|
||||
gsave nodash 0 pen newpath 523 269 moveto 533 266 lineto 523 263 lineto closepath gsave 0.00 setgray fill grestore
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2791890/draw_rect_connection
|
||||
gsave
|
||||
grestore
|
||||
|
||||
%%Object: @2797002/path
|
||||
gsave 0 0 translate nodash 1 633 246 startpath
|
||||
657 246 lineto
|
||||
657 190 lineto 681 190 lineto
|
||||
draw
|
||||
|
||||
%%Object: @draw_default_arrow/arrow
|
||||
gsave nodash 0 pen newpath 671 193 moveto 681 190 lineto 671 187 lineto closepath gsave 0.00 setgray fill grestore
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2793944/cml_function
|
||||
gsave 681 241 translate
|
||||
|
||||
%%Object: @2794056/box
|
||||
gsave nodash 1 0 0 100 50 25 boxpath
|
||||
draw grestore
|
||||
|
||||
%%Object: @2794114/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
18 29 0 65 (handler_2/1) text
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2793860/draw_rect_connection
|
||||
gsave
|
||||
grestore
|
||||
|
||||
%%Object: @2797162/path
|
||||
gsave 0 0 translate nodash 1 633 266 startpath
|
||||
681 266 lineto
|
||||
|
||||
draw
|
||||
|
||||
%%Object: @draw_default_arrow/arrow
|
||||
gsave nodash 0 pen newpath 671 269 moveto 681 266 lineto 671 263 lineto closepath gsave 0.00 setgray fill grestore
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2794322/cml_function
|
||||
gsave 681 375 translate
|
||||
|
||||
%%Object: @2794434/box
|
||||
gsave nodash 1 0 0 100 50 25 boxpath
|
||||
draw grestore
|
||||
|
||||
%%Object: @2794492/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
18 29 0 65 (handler_n/1) text
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2794238/draw_rect_connection
|
||||
gsave
|
||||
grestore
|
||||
|
||||
%%Object: @2797294/path
|
||||
gsave 0 0 translate nodash 1 633 286 startpath
|
||||
657 286 lineto
|
||||
657 400 lineto 681 400 lineto
|
||||
draw
|
||||
|
||||
%%Object: @draw_default_arrow/arrow
|
||||
gsave nodash 0 pen newpath 671 403 moveto 681 400 lineto 671 397 lineto closepath gsave 0.00 setgray fill grestore
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Object: @2797450/draw_line
|
||||
gsave
|
||||
dotted 1 731 305 0 50 linepath draw
|
||||
grestore
|
||||
|
||||
%%Object: @2797582/draw_text
|
||||
gsave /Helvetica findfont 12 scalefont setfont
|
||||
543 115 0 80 (Dispatch paths) text
|
||||
grestore
|
||||
grestore
|
||||
|
||||
%%Trailer
|
||||
grestore
|
||||
%%DocumentFonts:
|
||||
showpage
|
||||
BIN
packages/http/figs/httpserver.pd
Normal file
BIN
packages/http/figs/httpserver.pd
Normal file
Binary file not shown.
503
packages/http/html_head.pl
Normal file
503
packages/http/html_head.pl
Normal file
@ -0,0 +1,503 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2009, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(html_head,
|
||||
[ html_resource/2, % +Resource, +Attributes
|
||||
html_requires//1 % +Resource
|
||||
]).
|
||||
:- use_module(library(http/html_write)).
|
||||
:- use_module(library(http/mimetype)).
|
||||
:- use_module(library(http/http_path)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(settings)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(occurs)).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(library(ordsets)).
|
||||
:- use_module(library(assoc)).
|
||||
:- use_module(library(ugraphs)).
|
||||
:- use_module(library(broadcast)).
|
||||
:- use_module(library(apply)).
|
||||
:- use_module(library(debug)).
|
||||
|
||||
|
||||
/** <module> Automatic inclusion of CSS and scripts links
|
||||
|
||||
This library allows for abstract declaration of available CSS and
|
||||
Javascript resources and their dependencies using html_resource/2. Based
|
||||
on these declarations, html generating code can declare that it depends
|
||||
on specific CSS or Javascript functionality, after which this library
|
||||
ensures that the proper links appear in the HTML head. The
|
||||
implementation is based on mail system implemented by html_post/2 of
|
||||
library html_write.pl.
|
||||
|
||||
Declarations come in two forms. First of all http locations are declared
|
||||
using the http_path.pl library. Second, html_resource/2 specifies HTML
|
||||
resources to be used in the =head= and their dependencies. Resources are
|
||||
currently limited to Javascript files (.js) and style sheets (.css). It
|
||||
is trivial to add support for other material in the head. See
|
||||
html_include//1.
|
||||
|
||||
For usage in HTML generation, there is the DCG rule html_requires//1
|
||||
that demands named resources in the HTML head.
|
||||
|
||||
---++ About resource ordering
|
||||
|
||||
All calls to html_requires//1 for the page are collected and duplicates
|
||||
are removed. Next, the following steps are taken:
|
||||
|
||||
1. Add all dependencies to the set
|
||||
2. Replace multiple members by `aggregate' scripts or css files.
|
||||
see use_agregates/4.
|
||||
3. Order all resources by demanding that their dependencies
|
||||
preceede the resource itself. Note that the ordering of
|
||||
resources in the dependency list is *ignored*. This implies
|
||||
that if the order matters the dependency list must be split
|
||||
and only the primary dependency must be added.
|
||||
|
||||
---++ Debugging dependencies
|
||||
|
||||
Use ?- debug(html(script)). to see the requested and final set of
|
||||
resources. All declared resources are in html_resource/3. The edit/1
|
||||
command recognises the names of HTML resources.
|
||||
|
||||
@tbd Possibly we should add img//2 to include images from symbolic
|
||||
path notation.
|
||||
@tbd It would be nice if the HTTP file server could use our location
|
||||
declarations.
|
||||
*/
|
||||
|
||||
:- dynamic
|
||||
html_resource/3. % Resource, Source, Properties
|
||||
|
||||
%% html_resource(+About, +Properties) is det.
|
||||
%
|
||||
% Register an HTML head resource. About is either an atom that
|
||||
% specifies an HTTP location or a term Alias(Sub). This works
|
||||
% similar to absolute_file_name/2. See http:location_path/2 for
|
||||
% details. Recognised properties are:
|
||||
%
|
||||
% * requires(+Requirements)
|
||||
% Other required script and css files. If this is a plain
|
||||
% file name, it is interpreted relative to the declared
|
||||
% resource. Requirements can be a list, which is equivalent
|
||||
% to multiple requires properties.
|
||||
%
|
||||
% * virtual(+Bool)
|
||||
% If =true= (default =false=), do not include About itself,
|
||||
% but only its dependencies. This allows for defining an
|
||||
% alias for one or more resources.
|
||||
%
|
||||
% * aggregate(+List)
|
||||
% States that About is an aggregate of the resources in
|
||||
% List.
|
||||
|
||||
html_resource(About, Properties) :-
|
||||
source_location(File, Line), !,
|
||||
retractall(html_resource(About, File:Line, _)),
|
||||
assert_resource(About, File:Line, Properties).
|
||||
html_resource(About, Properties) :-
|
||||
assert_resource(About, -, Properties).
|
||||
|
||||
assert_resource(About, Location, Properties) :-
|
||||
assert(html_resource(About, Location, Properties)),
|
||||
clean_same_about_cache,
|
||||
( memberchk(aggregate(_), Properties)
|
||||
-> clean_aggregate_cache
|
||||
; true
|
||||
).
|
||||
|
||||
|
||||
%% html_requires(+ResourceOrList)// is det.
|
||||
%
|
||||
% Include ResourceOrList and all dependencies derived from it and
|
||||
% add them to the HTML =head= using html_post/2. The actual
|
||||
% dependencies are computed during the HTML output phase by
|
||||
% html_insert_resource//1.
|
||||
|
||||
html_requires(Required) -->
|
||||
html_post(head, 'html required'(Required)).
|
||||
|
||||
:- multifile
|
||||
html_write:html_head_expansion/2.
|
||||
|
||||
html_write:html_head_expansion(In, Out) :-
|
||||
require_commands(In, Required, Rest),
|
||||
Required \== [], !,
|
||||
flatten(Required, Plain),
|
||||
Out = [ html_head:(\html_insert_resource(Plain))
|
||||
| Rest
|
||||
].
|
||||
|
||||
require_commands([], [], []).
|
||||
require_commands([_:('html required'(Required))|T0], [Required|TR], R) :- !,
|
||||
require_commands(T0, TR, R).
|
||||
require_commands([R|T0], TR, [R|T]) :- !,
|
||||
require_commands(T0, TR, T).
|
||||
|
||||
|
||||
%% html_insert_resource(+ResourceOrList)// is det.
|
||||
%
|
||||
% Actually include HTML head resources. Called through
|
||||
% html_post//2 from html_requires//1 after rewrite by
|
||||
% html_head_expansion/2. We are guaranteed we will only get one
|
||||
% call that is passed a flat list of requested requirements. We
|
||||
% have three jobs:
|
||||
%
|
||||
% 1. Figure out all indirect requirements
|
||||
% 2. See whether we can use any `aggregate' resources
|
||||
% 3. Put required resources before their requiree.
|
||||
|
||||
html_insert_resource(Required) -->
|
||||
{ requirements(Required, Paths),
|
||||
debug(html(script), 'Requirements: ~q~nFinal: ~q', [Required, Paths])
|
||||
},
|
||||
html_include(Paths).
|
||||
|
||||
requirements(Required, Paths) :-
|
||||
phrase(requires(Required), List),
|
||||
sort(List, Paths0), % remove duplicates
|
||||
use_agregates(Paths0, Paths1, AggregatedBy),
|
||||
order_html_resources(Paths1, AggregatedBy, Paths).
|
||||
|
||||
%% use_agregates(+Paths, -Aggregated, -AggregatedBy) is det.
|
||||
%
|
||||
% Try to replace sets of resources by an `aggregate', a large
|
||||
% javascript or css file that combines the content of multiple
|
||||
% small ones to reduce the number of files that must be
|
||||
% transferred to the server. The current rule says that aggregates
|
||||
% are used if at least half of the members are used.
|
||||
|
||||
use_agregates(Paths, Aggregated, AggregatedBy) :-
|
||||
empty_assoc(AggregatedBy0),
|
||||
use_agregates(Paths, Aggregated, AggregatedBy0, AggregatedBy).
|
||||
|
||||
use_agregates(Paths, Aggregated, AggregatedBy0, AggregatedBy) :-
|
||||
current_aggregate(Aggregate, Parts, Size),
|
||||
ord_subtract(Paths, Parts, NotCovered),
|
||||
length(Paths, Len0),
|
||||
length(NotCovered, Len1),
|
||||
Covered is Len0-Len1,
|
||||
Covered >= Size/2, !,
|
||||
ord_add_element(NotCovered, Aggregate, NewPaths),
|
||||
add_aggregated_by(Parts, AggregatedBy0, Aggregate, AggregatedBy1),
|
||||
use_agregates(NewPaths, Aggregated, AggregatedBy1, AggregatedBy).
|
||||
use_agregates(Paths, Paths, AggregatedBy, AggregatedBy).
|
||||
|
||||
add_aggregated_by([], Assoc, _, Assoc).
|
||||
add_aggregated_by([H|T], Assoc0, V, Assoc) :-
|
||||
put_assoc(H, Assoc0, V, Assoc1),
|
||||
add_aggregated_by(T, Assoc1, V, Assoc).
|
||||
|
||||
|
||||
:- dynamic
|
||||
aggregate_cache_filled/0,
|
||||
aggregate_cache/3.
|
||||
:- volatile
|
||||
aggregate_cache_filled/0,
|
||||
aggregate_cache/3.
|
||||
|
||||
clean_aggregate_cache :-
|
||||
retractall(aggregate_cache_filled).
|
||||
|
||||
%% current_aggregate(-Aggregate, -Parts, -Size) is nondet.
|
||||
%
|
||||
% True if Aggregate is a defined aggregate with Size Parts. All
|
||||
% parts are canonical absolute HTTP locations and Parts is sorted
|
||||
% to allow for processing using ordered set predicates.
|
||||
|
||||
current_aggregate(Path, Parts, Size) :-
|
||||
aggregate_cache_filled, !,
|
||||
aggregate_cache(Path, Parts, Size).
|
||||
current_aggregate(Path, Parts, Size) :-
|
||||
retractall(aggregate_cache(_,_, _)),
|
||||
forall(uncached_aggregate(Path, Parts, Size),
|
||||
assert(aggregate_cache(Path, Parts, Size))),
|
||||
assert(aggregate_cache_filled),
|
||||
aggregate_cache(Path, Parts, Size).
|
||||
|
||||
uncached_aggregate(Path, APartsS, Size) :-
|
||||
html_resource(Aggregate, _, Properties),
|
||||
memberchk(aggregate(Parts), Properties),
|
||||
http_absolute_location(Aggregate, Path, []),
|
||||
absolute_paths(Parts, Path, AParts),
|
||||
sort(AParts, APartsS),
|
||||
length(APartsS, Size).
|
||||
|
||||
absolute_paths([], _, []).
|
||||
absolute_paths([H0|T0], Base, [H|T]) :-
|
||||
http_absolute_location(H0, H, [relative_to(Base)]),
|
||||
absolute_paths(T0, Base, T).
|
||||
|
||||
|
||||
%% requires(+Spec)// is det.
|
||||
%% requires(+Spec, +Base)// is det.
|
||||
%
|
||||
% True if Files is the set of files that need to be loaded for
|
||||
% Spec. Note that Spec normally appears in Files, but this is not
|
||||
% necessary (i.e. virtual resources or the usage of aggregate
|
||||
% resources).
|
||||
|
||||
requires(Spec) -->
|
||||
requires(Spec, /).
|
||||
|
||||
requires([], _) --> !,
|
||||
[].
|
||||
requires([H|T], Base) --> !,
|
||||
requires(H, Base),
|
||||
requires(T, Base).
|
||||
requires(Spec, Base) -->
|
||||
requires(Spec, Base, true).
|
||||
|
||||
requires(Spec, Base, Virtual) -->
|
||||
{ res_properties(Spec, Properties),
|
||||
http_absolute_location(Spec, File, [relative_to(Base)])
|
||||
},
|
||||
( { option(virtual(true), Properties)
|
||||
; Virtual == false
|
||||
}
|
||||
-> []
|
||||
; [File]
|
||||
),
|
||||
requires_from_properties(Properties, File).
|
||||
|
||||
|
||||
requires_from_properties([], _) -->
|
||||
[].
|
||||
requires_from_properties([H|T], Base) -->
|
||||
requires_from_property(H, Base),
|
||||
requires_from_properties(T, Base).
|
||||
|
||||
requires_from_property(requires(What), Base) --> !,
|
||||
requires(What, Base).
|
||||
requires_from_property(_, _) -->
|
||||
[].
|
||||
|
||||
|
||||
%% order_html_resources(+Requirements, +AggregatedBy, -Ordered) is det.
|
||||
%
|
||||
% Establish a proper order for the collected (sorted and unique)
|
||||
% list of Requirements.
|
||||
|
||||
order_html_resources(Requirements, AggregatedBy, Ordered) :-
|
||||
requirements_graph(Requirements, AggregatedBy, Graph),
|
||||
( top_sort(Graph, Ordered)
|
||||
-> true
|
||||
; connect_graph(Graph, Start, Connected),
|
||||
top_sort(Connected, Ordered0),
|
||||
Ordered0 = [Start|Ordered]
|
||||
).
|
||||
|
||||
%% requirements_graph(+Requirements, +AggregatedBy, -Graph) is det.
|
||||
%
|
||||
% Produce an S-graph (see library(ugraphs)) that represents the
|
||||
% dependencies in the list of Requirements. Edges run from
|
||||
% required to requirer.
|
||||
|
||||
requirements_graph(Requirements, AggregatedBy, Graph) :-
|
||||
phrase(prerequisites(Requirements, AggregatedBy, Vertices, []), Edges),
|
||||
vertices_edges_to_ugraph(Vertices, Edges, Graph).
|
||||
|
||||
prerequisites([], _, Vs, Vs) -->
|
||||
[].
|
||||
prerequisites([R|T], AggregatedBy, Vs, Vt) -->
|
||||
prerequisites_for(R, AggregatedBy, Vs, Vt0),
|
||||
prerequisites(T, AggregatedBy, Vt0, Vt).
|
||||
|
||||
prerequisites_for(R, AggregatedBy, Vs, Vt) -->
|
||||
{ phrase(requires(R, /, false), Req) },
|
||||
( {Req == []}
|
||||
-> {Vs = [R|Vt]}
|
||||
; req_edges(Req, AggregatedBy, R),
|
||||
{Vs = Vt}
|
||||
).
|
||||
|
||||
req_edges([], _, _) -->
|
||||
[].
|
||||
req_edges([H|T], AggregatedBy, R) -->
|
||||
( { get_assoc(H, AggregatedBy, Aggregate) }
|
||||
-> [Aggregate-R]
|
||||
; [H-R]
|
||||
),
|
||||
req_edges(T, AggregatedBy, R).
|
||||
|
||||
|
||||
%% connect_graph(+Graph, -Start, -Connected) is det.
|
||||
%
|
||||
% Turn Graph into a connected graph by putting a shared starting
|
||||
% point before all vertices.
|
||||
|
||||
connect_graph([], 0, []) :- !.
|
||||
connect_graph(Graph, Start, [Start-Vertices|Graph]) :-
|
||||
vertices(Graph, Vertices),
|
||||
Vertices = [First|_],
|
||||
before(First, Start).
|
||||
|
||||
%% before(+Term, -Before) is det.
|
||||
%
|
||||
% Unify Before to a term that comes before Term in the standard
|
||||
% order of terms.
|
||||
%
|
||||
% @error instantiation_error if Term is unbound.
|
||||
|
||||
before(X, _) :-
|
||||
var(X), !,
|
||||
instantiation_error(X).
|
||||
before(Number, Start) :-
|
||||
number(Number), !,
|
||||
Start is Number - 1.
|
||||
before(_, 0).
|
||||
|
||||
|
||||
%% res_properties(+Spec, -Properties) is det.
|
||||
%
|
||||
% True if Properties is the set of defined properties on Spec.
|
||||
|
||||
res_properties(Spec, Properties) :-
|
||||
findall(P, res_property(Spec, P), Properties0),
|
||||
list_to_set(Properties0, Properties).
|
||||
|
||||
res_property(Spec, Property) :-
|
||||
same_about(Spec, About),
|
||||
html_resource(About, _, Properties),
|
||||
member(Property, Properties).
|
||||
|
||||
:- dynamic
|
||||
same_about_cache/2.
|
||||
:- volatile
|
||||
same_about_cache/2.
|
||||
|
||||
clean_same_about_cache :-
|
||||
retractall(same_about_cache(_,_)).
|
||||
|
||||
same_about(Spec, About) :-
|
||||
same_about_cache(Spec, Same), !,
|
||||
member(About, Same).
|
||||
same_about(Spec, About) :-
|
||||
findall(A, uncached_same_about(Spec, A), List),
|
||||
assert(same_about_cache(Spec, List)),
|
||||
member(About, List).
|
||||
|
||||
uncached_same_about(Spec, About) :-
|
||||
html_resource(About, _, _),
|
||||
same_resource(Spec, About).
|
||||
|
||||
|
||||
%% same_resource(+R1, +R2) is semidet.
|
||||
%
|
||||
% True if R1 an R2 represent the same resource. R1 and R2 are
|
||||
% resource specifications are defined by http_absolute_location/3.
|
||||
|
||||
same_resource(R, R) :- !.
|
||||
same_resource(R1, R2) :-
|
||||
resource_base_name(R1, B),
|
||||
resource_base_name(R2, B),
|
||||
http_absolute_location(R1, Path, []),
|
||||
http_absolute_location(R2, Path, []).
|
||||
|
||||
:- dynamic
|
||||
base_cache/2.
|
||||
:- volatile
|
||||
base_cache/2.
|
||||
|
||||
resource_base_name(Spec, Base) :-
|
||||
( base_cache(Spec, Base0)
|
||||
-> Base = Base0
|
||||
; uncached_resource_base_name(Spec, Base0),
|
||||
assert(base_cache(Spec, Base0)),
|
||||
Base = Base0
|
||||
).
|
||||
|
||||
uncached_resource_base_name(Atom, Base) :-
|
||||
atomic(Atom), !,
|
||||
file_base_name(Atom, Base).
|
||||
uncached_resource_base_name(Compound, Base) :-
|
||||
arg(1, Compound, Base0),
|
||||
file_base_name(Base0, Base).
|
||||
|
||||
%% html_include(+PathOrList)// is det.
|
||||
%
|
||||
% Include to HTML resources that must be in the HTML <head>
|
||||
% element. Currently onlu supports =|.js|= and =|.css|= files.
|
||||
% Extend this to support more header material. Do not use this
|
||||
% predicate directly. html_requires//1 is the public interface to
|
||||
% include HTML resources.
|
||||
%
|
||||
% @param HTTP location or list of these.
|
||||
|
||||
html_include([]) --> !.
|
||||
html_include([H|T]) --> !,
|
||||
html_include(H),
|
||||
html_include(T).
|
||||
html_include(Path) -->
|
||||
{ file_mime_type(Path, Mime) }, !,
|
||||
html_include(Mime, Path).
|
||||
|
||||
html_include(text/css, Path) --> !,
|
||||
html(link([ rel(stylesheet),
|
||||
type('text/css'),
|
||||
href(Path)
|
||||
], [])).
|
||||
html_include(text/javascript, Path) --> !,
|
||||
html(script([ type('text/javascript'),
|
||||
src(Path)
|
||||
], [])).
|
||||
html_include(Mime, Path) -->
|
||||
{ print_message(warning, html_include(dont_know, Mime, Path))
|
||||
}.
|
||||
|
||||
|
||||
/*******************************
|
||||
* CACHE CLEANUP *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
user:message_hook/3.
|
||||
:- dynamic
|
||||
user:message_hook/3.
|
||||
|
||||
user:message_hook(make(done(Reload)), _Level, _Lines) :-
|
||||
Reload \== [],
|
||||
clean_same_about_cache,
|
||||
clean_aggregate_cache,
|
||||
fail.
|
||||
|
||||
|
||||
/*******************************
|
||||
* EDIT *
|
||||
*******************************/
|
||||
|
||||
% Allow edit(Location) to edit the :- html_resource declaration.
|
||||
:- multifile
|
||||
prolog_edit:locate/3.
|
||||
|
||||
prolog_edit:locate(Path, html_resource(Spec), [file(File), line(Line)]) :-
|
||||
atom(Path),
|
||||
html_resource(Spec, File:Line, _Properties),
|
||||
sub_term(Path, Spec).
|
||||
1278
packages/http/html_write.pl
Normal file
1278
packages/http/html_write.pl
Normal file
File diff suppressed because it is too large
Load Diff
1837
packages/http/http.doc
Normal file
1837
packages/http/http.doc
Normal file
File diff suppressed because it is too large
Load Diff
221
packages/http/http_authenticate.pl
Normal file
221
packages/http/http_authenticate.pl
Normal file
@ -0,0 +1,221 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2007, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
|
||||
:- module(authenticate,
|
||||
[ http_authenticate/3 % +Check, +Header, -User
|
||||
]).
|
||||
:- use_module(library(base64)).
|
||||
:- use_module(library('http/dcg_basics')).
|
||||
:- use_module(library(readutil)).
|
||||
:- use_module(library(crypt)).
|
||||
:- use_module(library(debug)).
|
||||
|
||||
/** <module> Authenticate HTTP connections using 401 headers
|
||||
|
||||
This module provides the basics to validate an HTTP =Authorization=
|
||||
error. User and password information are read from a Unix/Apache
|
||||
compatible password file. This information, as well as the validation
|
||||
process is cached to achieve optimal performance.
|
||||
|
||||
@author Jan Wielemaker
|
||||
*/
|
||||
|
||||
%% http_authenticate(+Type, +Request, -Fields)
|
||||
%
|
||||
% True if Request contains the information to continue according
|
||||
% to Type. Type identifies the required authentication technique:
|
||||
%
|
||||
% * basic(+PasswordFile)
|
||||
% Use HTTP =Basic= authetication and verify the password
|
||||
% from PasswordFile. PasswordFile is a file holding
|
||||
% usernames and passwords in a format compatible to
|
||||
% Unix and Apache. Each line is record with =|:|=
|
||||
% separated fields. The first field is the username and
|
||||
% the second the password _hash_. Password hashes are
|
||||
% validated using crypt/2.
|
||||
%
|
||||
% Successful authorization is cached for 60 seconds to avoid
|
||||
% overhead of decoding and lookup of the user and password data.
|
||||
%
|
||||
% http_authenticate/3 just validates the header. If authorization
|
||||
% is not provided the browser must be challenged, in response to
|
||||
% which it normally opens a user-password dialogue. Example code
|
||||
% realising this is below. The exception causes the HTTP wrapper
|
||||
% code to generate an HTTP 401 reply.
|
||||
%
|
||||
% ==
|
||||
% ( http_authenticate(basic(passwd), Request, Fields)
|
||||
% -> true
|
||||
% ; throw(http_reply(authorise(basic, Realm)))
|
||||
% ).
|
||||
% ==
|
||||
%
|
||||
% @tbd Should we also cache failures to reduce the risc of
|
||||
% DoS attacks?
|
||||
|
||||
http_authenticate(basic(File), Request, [user(User)]) :-
|
||||
memberchk(authorization(Text), Request),
|
||||
debug(http_authenticate, 'Authorization: ~w', [Text]),
|
||||
( cached_authenticated(Text, File, User)
|
||||
-> true
|
||||
; user_and_passwd(Text, Method, UserChars, Password),
|
||||
downcase_atom(Method, basic),
|
||||
debug(http_authenticate,
|
||||
'User: ~s, Password: ~s', [UserChars, Password]),
|
||||
atom_codes(User, UserChars),
|
||||
validate(File, User, Password),
|
||||
get_time(Now),
|
||||
assert(authenticated(Text, File, User, Now)),
|
||||
debug(http_authenticate, 'Authenticated ~w~n', [User])
|
||||
).
|
||||
|
||||
%% user_and_passwd(+AuthorizeText, -Method, -User, -Password) is det.
|
||||
%
|
||||
% Decode the HTTP =Authorization= header.
|
||||
|
||||
user_and_passwd(Text, Method, User, Password) :-
|
||||
atom_codes(Text, Codes),
|
||||
phrase(authorization(Method, Cookie), Codes),
|
||||
phrase(base64(UserPwd), Cookie),
|
||||
phrase(ident(User, Password), UserPwd).
|
||||
|
||||
authorization(Method, Cookie) -->
|
||||
nonblanks(MethodChars),
|
||||
{ atom_codes(Method, MethodChars)
|
||||
},
|
||||
blanks,
|
||||
nonblanks(Cookie),
|
||||
blanks.
|
||||
|
||||
ident(User, Password) -->
|
||||
string(User),
|
||||
":",
|
||||
string(Password).
|
||||
|
||||
%% cached_authenticated(+Authorization, +File, -User)
|
||||
%
|
||||
% Validate using the cache. If the entry is not in the cache, we
|
||||
% also remove all outdated entries from the cache.
|
||||
|
||||
:- dynamic
|
||||
authenticated/4. % Authorization, File, User, Time
|
||||
|
||||
cached_authenticated(Authorization, File, User) :-
|
||||
authenticated(Authorization, File, User, Time),
|
||||
get_time(Now),
|
||||
Now-Time =< 60, !. % 60-second timeout
|
||||
cached_authenticated(_, _, _) :-
|
||||
get_time(Now),
|
||||
( clause(authenticated(_, _, _, Time), true, Ref),
|
||||
Now-Time > 60,
|
||||
erase(Ref),
|
||||
fail
|
||||
).
|
||||
|
||||
|
||||
%% validate(+File, +User, +Passwd)
|
||||
%
|
||||
% True if User and Passwd combination appears in File. File uses
|
||||
% the same format as .htaccess files from Apache or Unix password
|
||||
% files. I.e. it consists of one line per entry with fields
|
||||
% separated by =|:|=. The first field is the User field, The
|
||||
% second contains the Passwd in DES or MD5 encrypted format. See
|
||||
% crypt/2 for details.
|
||||
|
||||
validate(File, User, Password) :-
|
||||
update_passwd(File, Path),
|
||||
passwd(User, Path, Hash),
|
||||
crypt(Password, Hash).
|
||||
|
||||
%% update_passwd(+File, -Path) is det.
|
||||
%
|
||||
% Update passwd/3 to reflect the correct passwords for File. Path
|
||||
% is the absolute path for File.
|
||||
|
||||
:- dynamic
|
||||
passwd/3, % User, File, Encrypted
|
||||
last_modified/2. % File, Stamp
|
||||
|
||||
update_passwd(File, Path) :-
|
||||
absolute_file_name(File, Path, [access(read)]),
|
||||
time_file(Path, Stamp),
|
||||
( last_modified(Path, Stamp)
|
||||
-> true
|
||||
; with_mutex(http_passwd, reload_passwd_file(Path, Stamp))
|
||||
).
|
||||
|
||||
reload_passwd_file(Path, Stamp) :-
|
||||
last_modified(Path, Stamp), !. % another thread did the work
|
||||
reload_passwd_file(Path, Stamp) :-
|
||||
retractall(last_modified(Path, _)),
|
||||
retractall(passwd(_, Path, _)),
|
||||
open(Path, read, Fd),
|
||||
read_line_to_codes(Fd, Line),
|
||||
read_passwd_file(Line, Fd, Path),
|
||||
close(Fd),
|
||||
assert(last_modified(Path, Stamp)).
|
||||
|
||||
read_passwd_file(end_of_file, _, _) :- !.
|
||||
read_passwd_file(Line, Fd, Path) :-
|
||||
( phrase(password_line(User, Hash), Line, _)
|
||||
-> assert(passwd(User, Path, Hash))
|
||||
; true % TBD: warning
|
||||
),
|
||||
read_line_to_codes(Fd, Line2),
|
||||
read_passwd_file(Line2, Fd, Path).
|
||||
|
||||
|
||||
password_line(User, Hash) -->
|
||||
string(UserCodes),
|
||||
":",
|
||||
string(HashCodes),
|
||||
( ":"
|
||||
; eos
|
||||
), !,
|
||||
{ atom_codes(User, UserCodes),
|
||||
atom_codes(Hash, HashCodes)
|
||||
}.
|
||||
|
||||
|
||||
/*******************************
|
||||
* PLUGIN FOR HTTP_DISPATCH *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
http:authenticate/3.
|
||||
|
||||
http:authenticate(basic(File, Realm), Request, User) :-
|
||||
( http_authenticate(basic(File), Request, User)
|
||||
-> true
|
||||
; throw(http_reply(authorise(basic, Realm)))
|
||||
).
|
||||
|
||||
293
packages/http/http_chunked.c
Normal file
293
packages/http/http_chunked.c
Normal file
@ -0,0 +1,293 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2007-2009, University of Amsterdam
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
This library is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
*/
|
||||
|
||||
#define O_DEBUG 1
|
||||
#include <SWI-Stream.h>
|
||||
#include <SWI-Prolog.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <assert.h>
|
||||
#include <time.h>
|
||||
#include <errno.h>
|
||||
|
||||
#define MAXHDR 1024 /* max size of chink header line */
|
||||
|
||||
static atom_t ATOM_close_parent; /* close_parent(Bool) */
|
||||
static atom_t ATOM_max_chunk_size; /* max_chunk_size(Int) */
|
||||
|
||||
|
||||
/*******************************
|
||||
* TYPES *
|
||||
*******************************/
|
||||
|
||||
#define BUFSIZE SIO_BUFSIZE /* raw I/O buffer */
|
||||
|
||||
typedef struct chunked_context
|
||||
{ IOSTREAM *stream; /* Original stream */
|
||||
IOSTREAM *chunked_stream; /* Stream I'm handle of */
|
||||
int close_parent; /* close parent on close */
|
||||
IOENC parent_encoding; /* Saved encoding of parent */
|
||||
size_t avail; /* data available */
|
||||
} chunked_context;
|
||||
|
||||
|
||||
static chunked_context*
|
||||
alloc_chunked_context(IOSTREAM *s)
|
||||
{ chunked_context *ctx = PL_malloc(sizeof(*ctx));
|
||||
|
||||
memset(ctx, 0, sizeof(*ctx));
|
||||
ctx->stream = s;
|
||||
ctx->close_parent = FALSE;
|
||||
|
||||
return ctx;
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
free_chunked_context(chunked_context *ctx)
|
||||
{ if ( ctx->stream->upstream )
|
||||
Sset_filter(ctx->stream, NULL);
|
||||
else
|
||||
PL_release_stream(ctx->stream);
|
||||
|
||||
PL_free(ctx);
|
||||
}
|
||||
|
||||
|
||||
/*******************************
|
||||
* CHUNKED I/O *
|
||||
*******************************/
|
||||
|
||||
static ssize_t /* decode */
|
||||
chunked_read(void *handle, char *buf, size_t size)
|
||||
{ chunked_context *ctx = handle;
|
||||
|
||||
for(;;)
|
||||
{ if ( ctx->avail > 0 ) /* data waiting */
|
||||
{ size_t max_rd = ctx->avail < size ? ctx->avail : size;
|
||||
ssize_t rc;
|
||||
|
||||
if ( (rc = Sfread(buf, sizeof(char), max_rd, ctx->stream)) > 0 )
|
||||
{ ctx->avail -= rc;
|
||||
|
||||
if ( ctx->avail == 0 )
|
||||
{ if ( Sgetc(ctx->stream) != '\r' ||
|
||||
Sgetc(ctx->stream) != '\n' )
|
||||
{ Sseterr(ctx->chunked_stream, 0, "Chunk not followed by \\r\\n");
|
||||
return -1;
|
||||
}
|
||||
}
|
||||
|
||||
return rc;
|
||||
} else if ( rc == 0 )
|
||||
{ Sseterr(ctx->chunked_stream, 0, "Unexpected EOF in chunked data");
|
||||
return -1;
|
||||
} else
|
||||
{ return -1;
|
||||
}
|
||||
} else
|
||||
{ char hdr[MAXHDR];
|
||||
char *s;
|
||||
|
||||
|
||||
if ( (s = Sfgets(hdr, sizeof(hdr), ctx->stream)) )
|
||||
{ char *ehdr;
|
||||
long len;
|
||||
|
||||
errno = 0;
|
||||
len = strtol(hdr, &ehdr, 16);
|
||||
if ( errno || len < 0 )
|
||||
{ Sseterr(ctx->chunked_stream, 0, "Bad chunk length");
|
||||
return -1;
|
||||
}
|
||||
if ( len == 0 )
|
||||
{ do
|
||||
{ s = Sfgets(hdr, sizeof(hdr), ctx->stream);
|
||||
} while ( s && strcmp(s, "\r\n") != 0 );
|
||||
if ( s )
|
||||
return 0;
|
||||
Sseterr(ctx->chunked_stream, 0, "Bad end-of-stream");
|
||||
return -1;
|
||||
}
|
||||
ctx->avail = len;
|
||||
/*continue*/
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static ssize_t /* encode */
|
||||
chunked_write(void *handle, char *buf, size_t size)
|
||||
{ chunked_context *ctx = handle;
|
||||
|
||||
if ( Sfprintf(ctx->stream, "%x\r\n", size) >= 0 &&
|
||||
Sfwrite(buf, sizeof(char), size, ctx->stream) == size &&
|
||||
Sfprintf(ctx->stream, "\r\n") >= 0 )
|
||||
return size;
|
||||
|
||||
return -1;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
chunked_control(void *handle, int op, void *data)
|
||||
{ chunked_context *ctx = handle;
|
||||
|
||||
switch(op)
|
||||
{ case SIO_FLUSHOUTPUT:
|
||||
case SIO_SETENCODING:
|
||||
return 0; /* allow switching encoding */
|
||||
default:
|
||||
if ( ctx->stream->functions->control )
|
||||
return (*ctx->stream->functions->control)(ctx->stream->handle, op, data);
|
||||
return -1;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
chunked_close(void *handle)
|
||||
{ chunked_context *ctx = handle;
|
||||
int rc = 0;
|
||||
|
||||
DEBUG(1, Sdprintf("chunked_close() ...\n"));
|
||||
|
||||
if ( (ctx->chunked_stream->flags & SIO_OUTPUT) )
|
||||
{ if ( Sfprintf(ctx->stream, "0\r\n\r\n") < 0 )
|
||||
rc = -1;
|
||||
}
|
||||
|
||||
ctx->stream->encoding = ctx->parent_encoding;
|
||||
|
||||
if ( ctx->close_parent )
|
||||
{ IOSTREAM *parent = ctx->stream;
|
||||
int rc2;
|
||||
|
||||
free_chunked_context(ctx);
|
||||
rc2 = Sclose(parent);
|
||||
if ( rc == 0 )
|
||||
rc = rc2;
|
||||
} else
|
||||
{ free_chunked_context(ctx);
|
||||
}
|
||||
|
||||
return rc;
|
||||
}
|
||||
|
||||
|
||||
static IOFUNCTIONS chunked_functions =
|
||||
{ chunked_read,
|
||||
chunked_write,
|
||||
NULL, /* seek */
|
||||
chunked_close,
|
||||
chunked_control, /* zcontrol */
|
||||
NULL, /* seek64 */
|
||||
};
|
||||
|
||||
|
||||
/*******************************
|
||||
* PROLOG CONNECTION *
|
||||
*******************************/
|
||||
|
||||
#define COPY_FLAGS (SIO_INPUT|SIO_OUTPUT| \
|
||||
SIO_TEXT| \
|
||||
SIO_REPXML|SIO_REPPL|\
|
||||
SIO_RECORDPOS)
|
||||
|
||||
static foreign_t
|
||||
pl_http_chunked_open(term_t org, term_t new, term_t options)
|
||||
{ term_t tail = PL_copy_term_ref(options);
|
||||
term_t head = PL_new_term_ref();
|
||||
chunked_context *ctx;
|
||||
IOSTREAM *s, *s2;
|
||||
int close_parent = FALSE;
|
||||
int max_chunk_size = 0;
|
||||
|
||||
while(PL_get_list(tail, head, tail))
|
||||
{ atom_t name;
|
||||
int arity;
|
||||
term_t arg = PL_new_term_ref();
|
||||
|
||||
if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
|
||||
return type_error(head, "option");
|
||||
_PL_get_arg(1, head, arg);
|
||||
|
||||
if ( name == ATOM_max_chunk_size )
|
||||
{ if ( !get_int_ex(arg, &max_chunk_size) )
|
||||
return FALSE;
|
||||
if ( max_chunk_size <= 0 )
|
||||
return domain_error(arg, "positive_integer");
|
||||
} else if ( name == ATOM_close_parent )
|
||||
{ if ( !get_bool_ex(arg, &close_parent) )
|
||||
return FALSE;
|
||||
}
|
||||
}
|
||||
if ( !PL_get_nil(tail) )
|
||||
return type_error(tail, "list");
|
||||
|
||||
if ( !PL_get_stream_handle(org, &s) )
|
||||
return FALSE; /* Error */
|
||||
ctx = alloc_chunked_context(s);
|
||||
ctx->close_parent = close_parent;
|
||||
|
||||
if ( !(s2 = Snew(ctx,
|
||||
(s->flags©_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);
|
||||
}
|
||||
482
packages/http/http_client.pl
Normal file
482
packages/http/http_client.pl
Normal file
@ -0,0 +1,482 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2010, University of Amsterdam, VU University Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
|
||||
:- module(http_client,
|
||||
[ http_get/3, % +URL, -Reply, +Options
|
||||
http_delete/3, % +URL, -Reply, +Options
|
||||
http_post/4, % +URL, +In, -Reply, +Options
|
||||
http_put/4, % +URL, +In, -Reply, +Options
|
||||
http_read_data/3, % +Header, -Data, +Options
|
||||
http_disconnect/1 % +What
|
||||
]).
|
||||
:- use_module(library(socket)).
|
||||
:- use_module(library(url)).
|
||||
:- use_module(http_header).
|
||||
:- use_module(http_stream).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(memfile)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(dcg_basics).
|
||||
|
||||
:- multifile
|
||||
http_convert_data/4, % http_read_data plugin-hook
|
||||
post_data_hook/3, % http_post_data/3 hook
|
||||
open_connection/4, % do_connect/5 hook
|
||||
close_connection/4.
|
||||
|
||||
%% open_connection(+Scheme, +Address, -In, -Out) is semidet.
|
||||
%
|
||||
% Hook to open a connection for the given URL-scheme to the given
|
||||
% address. If successful, In and Out must be two valid Prolog
|
||||
% streams that connect to the server.
|
||||
%
|
||||
% @param Scheme is the URL schema (=http= or =https=)
|
||||
% @param Address is a term Host:Port as used by tcp_connect/4.
|
||||
|
||||
%% close_connection(+Scheme, +Address, +In, +Out) is semidet.
|
||||
%
|
||||
% Hook to close a specific connection. If the hook succeeds, the
|
||||
% HTTP client assumes that In and Out are no longer to be used. If
|
||||
% the hook fails, the client calls close/2 on both streams.
|
||||
|
||||
:- dynamic
|
||||
connection/5. % Host:Port, Protocol, Thread, In, Out
|
||||
|
||||
:- expects_dialect(swi).
|
||||
:- assert(system:swi_io).
|
||||
|
||||
user_agent('SWI-Prolog (http://www.swi-prolog.org)').
|
||||
|
||||
%% connect(+UrlParts, -Read, -Write, +Options) is det.
|
||||
%% disconnect(+UrlParts) is det.
|
||||
%
|
||||
% Connect/disconnect on the basis of a parsed URL.
|
||||
|
||||
connect(Parts, Read, Write, _) :-
|
||||
memberchk(socket(Read, Write), Parts), !.
|
||||
connect(Parts, Read, Write, Options) :-
|
||||
address(Parts, Address, Protocol, Options),
|
||||
with_mutex(http_client_connect,
|
||||
connect2(Address, Protocol, Read, Write, Options)).
|
||||
|
||||
connect2(Address, Protocol, In, Out, _) :-
|
||||
thread_self(Self),
|
||||
connection(Address, Protocol, Self, In, Out), !.
|
||||
connect2(Address, Protocol, In, Out, Options) :-
|
||||
thread_self(Self),
|
||||
do_connect(Address, Protocol, In, Out, Options),
|
||||
assert(connection(Address, Protocol, Self, In, Out)).
|
||||
|
||||
do_connect(Address, Protocol, In, Out, Options) :-
|
||||
debug(http(client), 'http_client: Connecting to ~p ...', [Address]),
|
||||
( open_connection(Protocol, Address, In, Out)
|
||||
-> true
|
||||
; tcp_socket(Socket),
|
||||
catch(tcp_connect(Socket, Address, In, Out),
|
||||
E,
|
||||
( tcp_close_socket(Socket),
|
||||
throw(E)
|
||||
))
|
||||
),
|
||||
debug(http(client), '\tok ~p --> ~p', [In, Out]),
|
||||
( memberchk(timeout(Timeout), Options)
|
||||
-> set_stream(In, timeout(Timeout))
|
||||
; true
|
||||
), !.
|
||||
do_connect(Address, _, _, _, _) :- % can this happen!?
|
||||
throw(error(failed(connect, Address), _)).
|
||||
|
||||
|
||||
disconnect(Parts) :-
|
||||
protocol(Parts, Protocol),
|
||||
address(Parts, Protocol, Address, []), !,
|
||||
disconnect(Address, Protocol).
|
||||
|
||||
disconnect(Address, Protocol) :-
|
||||
with_mutex(http_client_connect,
|
||||
disconnect_locked(Address, Protocol)).
|
||||
|
||||
disconnect_locked(Address, Protocol) :-
|
||||
thread_self(Me),
|
||||
debug(connection, '~w: Closing connection to ~w~n', [Me, Address]),
|
||||
thread_self(Self),
|
||||
retract(connection(Address, Protocol, Self, In, Out)), !,
|
||||
disconnect(Protocol, Address, In, Out).
|
||||
|
||||
disconnect(Protocol, Address, In, Out) :-
|
||||
close_connection(Protocol, Address, In, Out), !.
|
||||
disconnect(_, _, In, Out) :-
|
||||
close(Out, [force(true)]),
|
||||
close(In, [force(true)]).
|
||||
|
||||
%% http_disconnect(+Connections) is det.
|
||||
%
|
||||
% Close down some connections. Currently Connections must have the
|
||||
% value =all=, closing all connections.
|
||||
|
||||
http_disconnect(all) :-
|
||||
( thread_self(Self),
|
||||
connection(Address, Protocol, Self, _, _),
|
||||
disconnect(Address, Protocol),
|
||||
fail
|
||||
; true
|
||||
).
|
||||
|
||||
address(_Parts, Host:Port, Protocol, Options) :-
|
||||
( memberchk(proxy(Host, Port, Protocol), Options)
|
||||
-> true
|
||||
; memberchk(proxy(Host, Port), Options),
|
||||
Protocol = http
|
||||
).
|
||||
address(Parts, Host:Port, Protocol, _Options) :-
|
||||
memberchk(host(Host), Parts),
|
||||
port(Parts, Port),
|
||||
protocol(Parts, Protocol).
|
||||
|
||||
port(Parts, Port) :-
|
||||
memberchk(port(Port), Parts), !.
|
||||
port(Parts, 80) :-
|
||||
memberchk(protocol(http), Parts).
|
||||
|
||||
protocol(Parts, Protocol) :-
|
||||
memberchk(protocol(Protocol), Parts), !.
|
||||
protocol(_, http).
|
||||
|
||||
/*******************************
|
||||
* GET *
|
||||
*******************************/
|
||||
|
||||
%% http_delete(+URL, -Data, +Options) is det.
|
||||
%
|
||||
% Execute a DELETE method on the server.
|
||||
%
|
||||
% @tbd Properly map the 201, 202 and 204 replies.
|
||||
|
||||
http_delete(URL, Data, Options) :-
|
||||
http_get(URL, Data, [method('DELETE')|Options]).
|
||||
|
||||
|
||||
%% http_get(+URL, -Data, +Options) is det.
|
||||
%
|
||||
% Get data from an HTTP server.
|
||||
|
||||
http_get(URL, Data, Options) :-
|
||||
atomic(URL), !,
|
||||
parse_url(URL, Parts),
|
||||
http_get(Parts, Data, Options).
|
||||
http_get(Parts, Data, Options) :-
|
||||
must_be(list, Options),
|
||||
memberchk(connection(Connection), Options),
|
||||
downcase_atom(Connection, 'keep-alive'), !,
|
||||
between(0, 1, _),
|
||||
catch(http_do_get(Parts, Data, Options), E,
|
||||
( message_to_string(E, Msg),
|
||||
debug(keep_alive, 'Error: ~w; retrying~n', [Msg]),
|
||||
disconnect(Parts),
|
||||
fail
|
||||
)), !.
|
||||
http_get(Parts, Data, Options) :-
|
||||
address(Parts, Address, Protocol, Options),
|
||||
do_connect(Address, Protocol, Read, Write, Options),
|
||||
call_cleanup(http_do_get([socket(Read, Write)|Parts], Data, Options),
|
||||
disconnect(Protocol, Address, Read, Write)).
|
||||
|
||||
http_do_get(Parts, Data, Options) :-
|
||||
connect(Parts, Read, Write, Options),
|
||||
( select(proxy(_,_), Options, Options1)
|
||||
-> parse_url(Location, Parts)
|
||||
; http_location(Parts, Location),
|
||||
Options1 = Options
|
||||
),
|
||||
memberchk(host(Host), Parts),
|
||||
option(method(Method), Options, 'GET'),
|
||||
http_write_header(Write, Method, Location, Host,
|
||||
Options1, ReplyOptions),
|
||||
write(Write, '\r\n'),
|
||||
flush_output(Write),
|
||||
http_read_reply(Read, Data0, ReplyOptions), !,
|
||||
( Data0 = redirect(Redirect),
|
||||
nonvar(Redirect)
|
||||
-> debug(http(redirect), 'Redirect to ~w', [Redirect]),
|
||||
parse_url(Redirect, Parts, NewParts),
|
||||
http_get(NewParts, Data, Options)
|
||||
; Data = Data0
|
||||
).
|
||||
http_do_get(Parts, _Data, _Options) :-
|
||||
throw(error(failed(http_get, Parts), _)).
|
||||
|
||||
http_read_reply(In, Data, Options) :-
|
||||
between(0, 1, _),
|
||||
http_read_reply_header(In, Fields),
|
||||
\+ memberchk(status(continue, _), Fields), !,
|
||||
( memberchk(location(Location), Fields),
|
||||
( memberchk(status(moved, _), Fields)
|
||||
; memberchk(status(moved_temporary, _), Fields)
|
||||
; memberchk(status(see_other, _), Fields)
|
||||
)
|
||||
-> Data = redirect(Location)
|
||||
; ( select(reply_header(Fields), Options, ReadOptions)
|
||||
-> true
|
||||
; ReadOptions = Options
|
||||
),
|
||||
http_read_data(In, Fields, Data, ReadOptions)
|
||||
),
|
||||
( memberchk(connection(Connection), Fields),
|
||||
downcase_atom(Connection, 'keep-alive')
|
||||
-> true
|
||||
; thread_self(Self),
|
||||
connection(Address, Protocol, Self, In, _Out)
|
||||
-> disconnect(Address, Protocol)
|
||||
; true
|
||||
).
|
||||
http_read_reply(In, _Data, _Options) :-
|
||||
format(user_error, 'Get FAILED~n', []),
|
||||
throw(error(failed(read_reply, In), _)).
|
||||
|
||||
|
||||
%% http_write_header(+Out, +Method, +Location,
|
||||
%% +Host, +Options, -RestOptions) is det.
|
||||
%
|
||||
% Write the request header. It accepts the following options:
|
||||
%
|
||||
% * http_version(Major-Minor)
|
||||
% * connection(Connection)
|
||||
% * user_agent(Agent)
|
||||
% * request_header(Name=Value)
|
||||
%
|
||||
% Remaining options are returned in RestOptions.
|
||||
|
||||
http_write_header(Out, Method, Location, Host, Options, RestOptions) :-
|
||||
( select(http_version(Major-Minor), Options, Options1)
|
||||
-> true
|
||||
; Major = 1, Minor = 1,
|
||||
Options1 = Options
|
||||
),
|
||||
format(Out, '~w ~w HTTP/~w.~w\r\n', [Method, Location, Major, Minor]),
|
||||
format(Out, 'Host: ~w\r\n', [Host]),
|
||||
( select(connection(Connection), Options1, Options2)
|
||||
-> true
|
||||
; Connection = 'Keep-Alive',
|
||||
Options2 = Options1
|
||||
),
|
||||
( select(user_agent(Agent), Options2, Options3)
|
||||
-> true
|
||||
; user_agent(Agent),
|
||||
Options3 = Options2
|
||||
),
|
||||
format(Out, 'User-Agent: ~w\r\n\
|
||||
Connection: ~w\r\n', [Agent, Connection]),
|
||||
x_headers(Options3, Out, RestOptions).
|
||||
|
||||
%% x_headers(+Options, +Out, -RestOptions) is det.
|
||||
%
|
||||
% Pass additional request options. For example:
|
||||
%
|
||||
% request_header('Accept-Language' = 'nl, en')
|
||||
%
|
||||
% No checking is performed on the fieldname or value. Both are
|
||||
% copied literally and in the order of appearance to the request.
|
||||
|
||||
x_headers([], _, []).
|
||||
x_headers([H|T0], Out, Options) :-
|
||||
x_header(H, Out), !,
|
||||
x_headers(T0, Out, Options).
|
||||
x_headers([H|T0], Out, [H|T]) :-
|
||||
x_headers(T0, Out, T).
|
||||
|
||||
x_header(request_header(Name=Value), Out) :-
|
||||
format(Out, '~w: ~w\r\n', [Name, Value]).
|
||||
x_header(proxy_authorization(ProxyAuthorization), Out) :-
|
||||
proxy_auth_header(ProxyAuthorization, Out).
|
||||
x_header(range(Spec), Out) :-
|
||||
Spec =.. [Unit, From, To],
|
||||
( To == end
|
||||
-> ToT = ''
|
||||
; must_be(integer, To),
|
||||
ToT = To
|
||||
),
|
||||
format(Out, 'Range: ~w=~d-~w\r\n', [Unit, From, ToT]).
|
||||
|
||||
proxy_auth_header(basic(User, Password), Out) :- !,
|
||||
format(codes(Codes), '~w:~w', [User, Password]),
|
||||
phrase(base64(Codes), Base64Codes),
|
||||
format(Out, 'Proxy-Authorization: basic ~s\r\n', [Base64Codes]).
|
||||
proxy_auth_header(Auth, _) :-
|
||||
domain_error(authorization, Auth).
|
||||
|
||||
%% http_read_data(+Fields, -Data, +Options) is det.
|
||||
%
|
||||
% Read data from an HTTP connection. Options must contain a term
|
||||
% input(In) that provides the input stream from the HTTP server.
|
||||
% Fields is the parsed http reply-header. Options is one of:
|
||||
%
|
||||
% * to(stream(+WriteStream))
|
||||
% Append the content of the message to Stream
|
||||
% * to(atom)
|
||||
% Return the reply as an atom
|
||||
% * to(codes)
|
||||
% Return the reply as a list of codes
|
||||
|
||||
http_read_data(Fields, Data, Options) :-
|
||||
memberchk(input(In), Fields),
|
||||
( http_read_data(In, Fields, Data, Options)
|
||||
-> true
|
||||
; throw(error(failed(http_read_data), _))
|
||||
).
|
||||
|
||||
|
||||
http_read_data(In, Fields, Data, Options) :- % Transfer-encoding: chunked
|
||||
select(transfer_encoding(chunked), Fields, RestFields), !,
|
||||
http_chunked_open(In, DataStream, []),
|
||||
call_cleanup(http_read_data(DataStream, RestFields, Data, Options),
|
||||
close(DataStream)).
|
||||
http_read_data(In, Fields, Data, Options) :-
|
||||
memberchk(to(X), Options), !,
|
||||
( X = stream(Stream)
|
||||
-> ( memberchk(content_length(Bytes), Fields)
|
||||
-> copy_stream_data(In, Stream, Bytes)
|
||||
; copy_stream_data(In, Stream)
|
||||
)
|
||||
; new_memory_file(MemFile),
|
||||
open_memory_file(MemFile, write, Stream, [encoding(octet)]),
|
||||
( memberchk(content_length(Bytes), Fields)
|
||||
-> copy_stream_data(In, Stream, Bytes)
|
||||
; copy_stream_data(In, Stream)
|
||||
),
|
||||
close(Stream),
|
||||
encoding(Fields, Encoding),
|
||||
( X == atom
|
||||
-> memory_file_to_atom(MemFile, Data0, Encoding)
|
||||
; X == codes
|
||||
-> memory_file_to_codes(MemFile, Data0, Encoding)
|
||||
; domain_error(return_type, X)
|
||||
),
|
||||
free_memory_file(MemFile),
|
||||
Data = Data0
|
||||
).
|
||||
http_read_data(In, Fields, Data, _) :-
|
||||
memberchk(content_type('application/x-www-form-urlencoded'), Fields), !,
|
||||
http_read_data(In, Fields, Codes, [to(codes)]),
|
||||
parse_url_search(Codes, Data).
|
||||
http_read_data(In, Fields, Data, Options) :- % call hook
|
||||
( select(content_type(Type), Options, Options1)
|
||||
-> delete(Fields, content_type(_), Fields1),
|
||||
http_convert_data(In, [content_type(Type)|Fields1], Data, Options1)
|
||||
; http_convert_data(In, Fields, Data, Options)
|
||||
), !.
|
||||
http_read_data(In, Fields, Data, Options) :-
|
||||
http_read_data(In, Fields, Data, [to(atom)|Options]).
|
||||
|
||||
|
||||
encoding(Fields, utf8) :-
|
||||
memberchk(content_type(Type), Fields),
|
||||
( sub_atom(Type, _, _, _, 'UTF-8')
|
||||
-> true
|
||||
; sub_atom(Type, _, _, _, 'utf-8')
|
||||
), !.
|
||||
encoding(_, octet).
|
||||
|
||||
|
||||
/*******************************
|
||||
* POST *
|
||||
*******************************/
|
||||
|
||||
%% http_put(+URL, +In, -Out, +Options)
|
||||
%
|
||||
% Issue an HTTP PUT request.
|
||||
|
||||
http_put(URL, In, Out, Options) :-
|
||||
http_post(URL, In, Out, [method('PUT')|Options]).
|
||||
|
||||
|
||||
%% http_post(+URL, +In, -Out, +Options)
|
||||
%
|
||||
% Issue an HTTP POST request, In is modelled after the reply
|
||||
% from the HTTP server module. In is one of:
|
||||
%
|
||||
% * string(String)
|
||||
% * string(MimeType, String)
|
||||
% * html(Tokens)
|
||||
% * file(MimeType, File)
|
||||
|
||||
http_post(URL, In, Out, Options) :-
|
||||
atomic(URL), !,
|
||||
parse_url(URL, Parts),
|
||||
http_post(Parts, In, Out, Options).
|
||||
http_post(Parts, In, Out, Options) :-
|
||||
memberchk(connection(Connection), Options),
|
||||
downcase_atom(Connection, 'keep-alive'), !,
|
||||
between(0, 1, _),
|
||||
catch(http_do_post(Parts, In, Out, Options), error(io_error, _),
|
||||
( disconnect(Parts),
|
||||
fail
|
||||
)), !.
|
||||
http_post(Parts, In, Out, Options) :-
|
||||
address(Parts, Address, Protocol, Options),
|
||||
do_connect(Address, Protocol, Read, Write, Options),
|
||||
call_cleanup(http_do_post([socket(Read, Write)|Parts],
|
||||
In, Out, Options),
|
||||
disconnect(Protocol, Address, Read, Write)).
|
||||
|
||||
http_do_post(Parts, In, Out, Options) :-
|
||||
connect(Parts, Read, Write, Options),
|
||||
( memberchk(proxy(_,_), Options)
|
||||
-> parse_url(Location, Parts)
|
||||
; http_location(Parts, Location)
|
||||
),
|
||||
memberchk(host(Host), Parts),
|
||||
split_options(Options, PostOptions, ReplyOptions),
|
||||
write_post_header(Write, Location, Host, In, PostOptions),
|
||||
http_read_reply(Read, Out, ReplyOptions).
|
||||
|
||||
write_post_header(Out, Location, Host, In, Options) :-
|
||||
option(method(Method), Options, 'POST'),
|
||||
http_write_header(Out, Method, Location, Host, Options, DataOptions),
|
||||
http_post_data(In, Out, DataOptions),
|
||||
flush_output(Out).
|
||||
|
||||
post_option(connection(_)).
|
||||
post_option(http_version(_)).
|
||||
post_option(cache_control(_)).
|
||||
post_option(request_header(_)).
|
||||
|
||||
split_options([], [], []).
|
||||
split_options([H|T], [H|P], R) :-
|
||||
post_option(H), !,
|
||||
split_options(T, P, R).
|
||||
split_options([H|T], P, [H|R]) :-
|
||||
split_options(T, P, R).
|
||||
|
||||
:- retract(system:swi_io).
|
||||
|
||||
202
packages/http/http_dirindex.pl
Normal file
202
packages/http/http_dirindex.pl
Normal file
@ -0,0 +1,202 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2009, VU University Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_dirindex,
|
||||
[ http_reply_dirindex/3 % +PhysicalDir, +Options, +Request
|
||||
]).
|
||||
:- use_module(library(http/html_write)).
|
||||
:- use_module(library(http/http_path)).
|
||||
:- use_module(library(http/http_dispatch)).
|
||||
:- use_module(library(http/http_server_files)).
|
||||
:- use_module(library(http/html_head)).
|
||||
:- use_module(library(apply)).
|
||||
:- use_module(library(option)).
|
||||
|
||||
/** <module> HTTP directory listings
|
||||
|
||||
This module provides a simple API to generate an index for a physical
|
||||
directory. The index can be customised by overruling the dirindex.css
|
||||
CSS file and by defining additional rules for icons using the hook
|
||||
http:file_extension_icon/2.
|
||||
|
||||
@tbd Provide more options (sorting, selecting columns, hiding files)
|
||||
*/
|
||||
|
||||
%% http_reply_dirindex(+DirSpec, +Options, +Request) is det.
|
||||
%
|
||||
% Provide a directory listing for Request, assuming it is an index
|
||||
% for the physical directrory Dir. If the request-path does not
|
||||
% end with /, first return a moved (301 Moved Permanently) reply.
|
||||
%
|
||||
% The calling conventions allows for direct calling from
|
||||
% http_handler/3.
|
||||
|
||||
http_reply_dirindex(DirSpec, Options, Request) :-
|
||||
http_safe_file(DirSpec, Options),
|
||||
absolute_file_name(DirSpec, Dir,
|
||||
[ file_type(directory),
|
||||
access(read)
|
||||
]),
|
||||
memberchk(path(Path), Request),
|
||||
( atom_concat(PlainPath, /, Path),
|
||||
merge_options(Options,
|
||||
[ title(['Index of ', PlainPath]) ],
|
||||
Options1)
|
||||
-> dir_index(Dir, Options1)
|
||||
; atom_concat(Path, /, NewLocation),
|
||||
throw(http_reply(moved(NewLocation)))
|
||||
).
|
||||
|
||||
dir_index(Dir, Options) :-
|
||||
directory_members(Dir, SubDirs, Files),
|
||||
option(title(Title), Options, Dir),
|
||||
reply_html_page(title(Title),
|
||||
[ \html_requires(http_dirindex),
|
||||
h1(Title),
|
||||
table(class(dirindex),
|
||||
[ \dirindex_title,
|
||||
\back
|
||||
| \dirmembers(SubDirs, Files)
|
||||
])
|
||||
]).
|
||||
|
||||
directory_members(Dir, Dirs, Files) :-
|
||||
atom_concat(Dir, '/*', Pattern),
|
||||
expand_file_name(Pattern, Matches),
|
||||
partition(exists_directory, Matches, Dirs, Files).
|
||||
|
||||
dirindex_title -->
|
||||
html(tr(class(dirindex_header),
|
||||
[ th(class(icon), ''),
|
||||
th(class(name), 'Name'),
|
||||
th(class(modified), 'Last modified'),
|
||||
th(class(size), 'Size')
|
||||
])).
|
||||
|
||||
back -->
|
||||
html(tr([ \icon_cell('back.png', '[UP]'),
|
||||
\name_cell(.., 'Up'),
|
||||
td(class(modified), -),
|
||||
td(class(size), -)
|
||||
])).
|
||||
|
||||
dirmembers(Dirs, Files) -->
|
||||
dir_rows(Dirs, odd, End),
|
||||
file_rows(Files, End, _).
|
||||
|
||||
dir_rows([], OE, OE) --> [].
|
||||
dir_rows([H|T], OE0, OE) -->
|
||||
dir_row(H, OE0),
|
||||
{ oe(OE0, OE1) },
|
||||
dir_rows(T, OE1, OE).
|
||||
|
||||
file_rows([], OE, OE) --> [].
|
||||
file_rows([H|T], OE0, OE) -->
|
||||
file_row(H, OE0),
|
||||
{oe(OE0, OE1)},
|
||||
file_rows(T, OE1, OE).
|
||||
|
||||
oe(odd, even).
|
||||
oe(even, odd).
|
||||
|
||||
dir_row(Dir, OE) -->
|
||||
{ file_base_name(Dir, Name)
|
||||
},
|
||||
html(tr(class(OE),
|
||||
[ \icon_cell('folder.png', '[DIR]'),
|
||||
\name_cell(Name, Name),
|
||||
\modified_cell(Dir),
|
||||
td(class(size), -)
|
||||
])).
|
||||
|
||||
|
||||
file_row(File, OE) -->
|
||||
{ file_base_name(File, Name),
|
||||
file_name_extension(_, Ext, Name),
|
||||
file_type_icon(Ext, IconName)
|
||||
},
|
||||
html(tr(class(OE),
|
||||
[ \icon_cell(IconName, '[FILE]'),
|
||||
\name_cell(Name, Name),
|
||||
\modified_cell(File),
|
||||
td(class(size), \size(File))
|
||||
])).
|
||||
|
||||
icon_cell(IconName, Alt) -->
|
||||
{ http_absolute_location(icons(IconName), Icon, [])
|
||||
},
|
||||
html(td(class(icon), img([src(Icon), alt(Alt)]))).
|
||||
|
||||
|
||||
name_cell(Ref, Name) -->
|
||||
html(td(class(name), a(href(Ref), Name))).
|
||||
|
||||
|
||||
modified_cell(Name) -->
|
||||
{ time_file(Name, Stamp),
|
||||
format_time(string(Date), '%+', Stamp)
|
||||
},
|
||||
html(td(class(modified), Date)).
|
||||
|
||||
size(Name) -->
|
||||
{ size_file(Name, Size)
|
||||
},
|
||||
html('~D'-[Size]).
|
||||
|
||||
%% file_type_icon(+Extension, -Icon) is det.
|
||||
%
|
||||
% Determine the icon that is used to show a file of the given
|
||||
% extension. This predicate can be hooked using the multifile
|
||||
% http:file_extension_icon/2 hook with the same signature. Icon is
|
||||
% the plain name of an image file that appears in the
|
||||
% file-search-path =icons=.
|
||||
|
||||
file_type_icon(Ext, Icon) :-
|
||||
http:file_extension_icon(Ext, Icon), !.
|
||||
file_type_icon(_, 'generic.png').
|
||||
|
||||
:- multifile
|
||||
http:file_extension_icon/2.
|
||||
|
||||
http:file_extension_icon(pdf, 'layout.png').
|
||||
http:file_extension_icon(c, 'c.png').
|
||||
http:file_extension_icon(gz, 'compressed.png').
|
||||
http:file_extension_icon(tgz, 'compressed.png').
|
||||
http:file_extension_icon(zip, 'compressed.png').
|
||||
|
||||
|
||||
/*******************************
|
||||
* RESOURCES *
|
||||
*******************************/
|
||||
|
||||
:- html_resource(http_dirindex,
|
||||
[ virtual(true),
|
||||
requires([ css('dirindex.css')
|
||||
])
|
||||
]).
|
||||
855
packages/http/http_dispatch.pl
Normal file
855
packages/http/http_dispatch.pl
Normal file
@ -0,0 +1,855 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2007-2009, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_dispatch,
|
||||
[ http_dispatch/1, % +Request
|
||||
http_handler/3, % +Path, +Predicate, +Options
|
||||
http_delete_handler/1, % +Path
|
||||
http_reply_file/3, % +File, +Options, +Request
|
||||
http_redirect/3, % +How, +Path, +Request
|
||||
http_current_handler/2, % ?Path, ?Pred
|
||||
http_current_handler/3, % ?Path, ?Pred
|
||||
http_location_by_id/2, % +ID, -Location
|
||||
http_link_to_id/3, % +ID, +Parameters, -HREF
|
||||
http_safe_file/2 % +Spec, +Options
|
||||
]).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(time)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(settings)).
|
||||
:- use_module(library(uri)).
|
||||
:- use_module(library(http/mimetype)).
|
||||
:- use_module(library(http/http_path)).
|
||||
:- use_module(library(http/http_header)).
|
||||
:- use_module(library(http/thread_httpd)).
|
||||
|
||||
/** <module> Dispatch requests in the HTTP server
|
||||
|
||||
This module can be placed between http_wrapper.pl and the application
|
||||
code to associate HTTP _locations_ to predicates that serve the pages.
|
||||
In addition, it associates parameters with locations that deal with
|
||||
timeout handling and user authentication. The typical setup is:
|
||||
|
||||
==
|
||||
server(Port, Options) :-
|
||||
http_server(http_dispatch,
|
||||
[ port(Port),
|
||||
| Options
|
||||
]).
|
||||
|
||||
:- http_handler('/index.html', write_index, []).
|
||||
|
||||
write_index(Request) :-
|
||||
...
|
||||
==
|
||||
*/
|
||||
|
||||
:- setting(http:time_limit, nonneg, 300,
|
||||
'Time limit handling a single query (0=infinite)').
|
||||
|
||||
%% http_handler(+Path, :Closure, +Options) is det.
|
||||
%
|
||||
% Register Closure as a handler for HTTP requests. Path is a
|
||||
% specification as provided by http_path.pl. If an HTTP
|
||||
% request arrives at the server that matches Path, Closure
|
||||
% is called with one extra argument: the parsed HTTP request.
|
||||
% Options is a list containing the following options:
|
||||
%
|
||||
% * authentication(+Type)
|
||||
% Demand authentication. Authentication methods are
|
||||
% pluggable. The library http_authenticate.pl provides
|
||||
% a plugin for user/password based =Basic= HTTP
|
||||
% authentication.
|
||||
%
|
||||
% * chunked
|
||||
% Use =|Transfer-encoding: chunked|= if the client
|
||||
% allows for it.
|
||||
%
|
||||
% * id(+Term)
|
||||
% Identifier of the handler. The default identifier is
|
||||
% the predicate name. Used by http_location_by_id/2.
|
||||
%
|
||||
% * priority(+Integer)
|
||||
% If two handlers handle the same path, the one with the
|
||||
% highest priority is used. If equal, the last registered
|
||||
% is used. Please be aware that the order of clauses in
|
||||
% multifile predicates can change due to reloading files.
|
||||
% The default priority is 0 (zero).
|
||||
%
|
||||
% * prefix
|
||||
% Call Pred on any location that is a specialisation of
|
||||
% Path. If multiple handlers match, the one with the
|
||||
% longest path is used.
|
||||
%
|
||||
% * spawn(+SpawnOptions)
|
||||
% Run the handler in a seperate thread. If SpawnOptions
|
||||
% is an atom, it is interpreted as a thread pool name
|
||||
% (see create_thread_pool/3). Otherwise the options
|
||||
% are passed to http_spawn/2 and from there to
|
||||
% thread_create/3. These options are typically used to
|
||||
% set the stack limits.
|
||||
%
|
||||
% * time_limit(+Spec)
|
||||
% One of =infinite=, =default= or a positive number
|
||||
% (seconds)
|
||||
%
|
||||
% * content_type(+Term)
|
||||
% Specifies the content-type of the reply. This value is
|
||||
% currently not used by this library. It enhances the
|
||||
% reflexive capabilities of this library through
|
||||
% http_current_handler/3.
|
||||
%
|
||||
% Note that http_handler/3 is normally invoked as a directive and
|
||||
% processed using term-expansion. Using term-expansion ensures
|
||||
% proper update through make/0 when the specification is modified.
|
||||
% We do not expand when the cross-referencer is running to ensure
|
||||
% proper handling of the meta-call.
|
||||
%
|
||||
% @error existence_error(http_location, Location)
|
||||
% @see http_reply_file/3 and http_redirect/3 are generic
|
||||
% handlers to serve files and achieve redirects.
|
||||
|
||||
:- dynamic handler/4. % Path, Action, IsPrefix, Options
|
||||
:- multifile handler/4.
|
||||
:- dynamic generation/1.
|
||||
|
||||
:- meta_predicate
|
||||
http_handler(+, :, +),
|
||||
http_current_handler(?, :),
|
||||
http_current_handler(?, :, ?).
|
||||
|
||||
http_handler(Path, Pred, Options) :-
|
||||
strip_module(Pred, M, P),
|
||||
compile_handler(Path, M:P, Options, Clause),
|
||||
next_generation,
|
||||
assert(Clause).
|
||||
|
||||
:- multifile
|
||||
system:term_expansion/2.
|
||||
|
||||
system:term_expansion((:- http_handler(Path, Pred, Options)), Clause) :-
|
||||
\+ current_prolog_flag(xref, true),
|
||||
prolog_load_context(module, M),
|
||||
compile_handler(Path, M:Pred, Options, Clause),
|
||||
next_generation.
|
||||
|
||||
|
||||
%% http_delete_handler(+Path) is det.
|
||||
%
|
||||
% Delete handler for Path. Typically, this should only be used for
|
||||
% handlers that are registered dynamically.
|
||||
|
||||
http_delete_handler(Path) :-
|
||||
retractall(handler(Path, _Pred, _, _Options)),
|
||||
next_generation.
|
||||
|
||||
|
||||
%% next_generation is det.
|
||||
%% current_generation(-G) is det.
|
||||
%
|
||||
% Increment the generation count.
|
||||
|
||||
next_generation :-
|
||||
retractall(id_location_cache(_,_)),
|
||||
with_mutex(http_dispatch, next_generation_unlocked).
|
||||
|
||||
next_generation_unlocked :-
|
||||
retract(generation(G0)), !,
|
||||
G is G0 + 1,
|
||||
assert(generation(G)).
|
||||
next_generation_unlocked :-
|
||||
assert(generation(1)).
|
||||
|
||||
current_generation(G) :-
|
||||
with_mutex(http_dispatch, generation(G)), !.
|
||||
current_generation(0).
|
||||
|
||||
|
||||
%% compile_handler(+Path, :Pred, +Options) is det.
|
||||
%
|
||||
% Compile a handler specification. For now we this is a no-op, but
|
||||
% in the feature can make this more efficiently, especially in the
|
||||
% presence of one or multiple prefix declarations. We can also use
|
||||
% this to detect conflicts.
|
||||
|
||||
compile_handler(prefix(Path), Pred, Options,
|
||||
http_dispatch:handler(Path, Pred, true, Options)) :- !,
|
||||
check_path(Path, Path1),
|
||||
print_message(warning, http_dispatch(prefix(Path1))).
|
||||
compile_handler(Path, Pred, Options0,
|
||||
http_dispatch:handler(Path1, Pred, IsPrefix, Options)) :-
|
||||
check_path(Path, Path1),
|
||||
( select(prefix, Options0, Options)
|
||||
-> IsPrefix = true
|
||||
; IsPrefix = false,
|
||||
Options = Options0
|
||||
).
|
||||
|
||||
%% check_path(+PathSpecIn, -PathSpecOut) is det.
|
||||
%
|
||||
% Validate the given path specification. We want one of
|
||||
%
|
||||
% * AbsoluteLocation
|
||||
% * Alias(Relative)
|
||||
%
|
||||
% Similar to absolute_file_name/3, Relative can be a term
|
||||
% _|Component/Component/...|_
|
||||
%
|
||||
% @error domain_error, type_error
|
||||
% @see http_absolute_location/3
|
||||
|
||||
check_path(Path, Path) :-
|
||||
atom(Path), !,
|
||||
( sub_atom(Path, 0, _, _, /)
|
||||
-> true
|
||||
; domain_error(absolute_http_location, Path)
|
||||
).
|
||||
check_path(Alias, AliasOut) :-
|
||||
compound(Alias),
|
||||
Alias =.. [Name, Relative], !,
|
||||
to_atom(Relative, Local),
|
||||
( sub_atom(Local, 0, _, _, /)
|
||||
-> domain_error(relative_location, Relative)
|
||||
; AliasOut =.. [Name, Local]
|
||||
).
|
||||
check_path(PathSpec, _) :-
|
||||
type_error(path_or_alias, PathSpec).
|
||||
|
||||
to_atom(Atom, Atom) :-
|
||||
atom(Atom), !.
|
||||
to_atom(Path, Atom) :-
|
||||
phrase(path_to_list(Path), Components), !,
|
||||
atomic_list_concat(Components, '/', Atom).
|
||||
to_atom(Path, _) :-
|
||||
ground(Path), !,
|
||||
type_error(relative_location, Path).
|
||||
to_atom(Path, _) :-
|
||||
instantiation_error(Path).
|
||||
|
||||
path_to_list(Var) -->
|
||||
{ var(Var), !,
|
||||
fail
|
||||
}.
|
||||
path_to_list(A/B) -->
|
||||
path_to_list(A),
|
||||
path_to_list(B).
|
||||
path_to_list(Atom) -->
|
||||
{ atom(Atom) },
|
||||
[Atom].
|
||||
|
||||
|
||||
|
||||
%% http_dispatch(Request) is det.
|
||||
%
|
||||
% Dispatch a Request using http_handler/3 registrations.
|
||||
|
||||
http_dispatch(Request) :-
|
||||
memberchk(path(Path), Request),
|
||||
find_handler(Path, Pred, Options),
|
||||
authentication(Options, Request, Fields),
|
||||
append(Fields, Request, AuthRequest),
|
||||
action(Pred, AuthRequest, Options).
|
||||
|
||||
|
||||
%% http_current_handler(+Location, :Closure) is semidet.
|
||||
%% http_current_handler(-Location, :Closure) is nondet.
|
||||
%
|
||||
% True if Location is handled by Closure.
|
||||
|
||||
http_current_handler(Path, Closure) :-
|
||||
atom(Path), !,
|
||||
path_tree(Tree),
|
||||
find_handler(Tree, Path, Closure, _).
|
||||
http_current_handler(Path, M:C) :-
|
||||
handler(Spec, M:C, _, _),
|
||||
http_absolute_location(Spec, Path, []).
|
||||
|
||||
%% http_current_handler(+Location, :Closure, -Options) is semidet.
|
||||
%% http_current_handler(?Location, :Closure, ?Options) is nondet.
|
||||
%
|
||||
% Resolve the current handler and options to execute it.
|
||||
|
||||
http_current_handler(Path, Closure, Options) :-
|
||||
atom(Path), !,
|
||||
path_tree(Tree),
|
||||
find_handler(Tree, Path, Closure, Options).
|
||||
http_current_handler(Path, M:C, Options) :-
|
||||
handler(Spec, M:C, _, _),
|
||||
http_absolute_location(Spec, Path, []),
|
||||
path_tree(Tree),
|
||||
find_handler(Tree, Path, _, Options).
|
||||
|
||||
|
||||
%% http_location_by_id(+ID, -Location) is det.
|
||||
%
|
||||
% Find the HTTP Location of handler with ID. If the setting (see
|
||||
% setting/2) http:prefix is active, Location is the handler
|
||||
% location prefixed with the prefix setting. Handler IDs can be
|
||||
% specified in two ways:
|
||||
%
|
||||
% * id(ID)
|
||||
% If this appears in the option list of the handler, this
|
||||
% it is used and takes preference over using the predicate.
|
||||
% * M:PredName
|
||||
% The module-qualified name of the predicate.
|
||||
% * PredName
|
||||
% The unqualified name of the predicate.
|
||||
%
|
||||
% @error existence_error(http_handler_id, Id).
|
||||
|
||||
:- dynamic
|
||||
id_location_cache/2.
|
||||
|
||||
http_location_by_id(ID, Location) :-
|
||||
must_be(ground, ID),
|
||||
id_location_cache(ID, L0), !,
|
||||
Location = L0.
|
||||
http_location_by_id(ID, Location) :-
|
||||
findall(P-L, location_by_id(ID, L, P), List),
|
||||
keysort(List, RevSorted),
|
||||
reverse(RevSorted, Sorted),
|
||||
( Sorted = [_-One]
|
||||
-> assert(id_location_cache(ID, One)),
|
||||
Location = One
|
||||
; List == []
|
||||
-> existence_error(http_handler_id, ID)
|
||||
; List = [P0-Best,P1-_|_]
|
||||
-> ( P0 == P1
|
||||
-> print_message(warning,
|
||||
http_dispatch(ambiguous_id(ID, Sorted, Best)))
|
||||
; true
|
||||
),
|
||||
assert(id_location_cache(ID, Best)),
|
||||
Location = Best
|
||||
).
|
||||
|
||||
location_by_id(ID, Location, Priority) :-
|
||||
location_by_id_raw(ID, L0, Priority),
|
||||
to_path(L0, Location).
|
||||
|
||||
to_path(prefix(Path0), Path) :- !, % old style prefix notation
|
||||
add_prefix(Path0, Path).
|
||||
to_path(Path0, Path) :-
|
||||
atomic(Path0), !, % old style notation
|
||||
add_prefix(Path0, Path).
|
||||
to_path(Spec, Path) :- % new style notation
|
||||
http_absolute_location(Spec, Path, []).
|
||||
|
||||
add_prefix(P0, P) :-
|
||||
( catch(setting(http:prefix, Prefix), _, fail),
|
||||
Prefix \== ''
|
||||
-> atom_concat(Prefix, P0, P)
|
||||
; P = P0
|
||||
).
|
||||
|
||||
location_by_id_raw(ID, Location, Priority) :-
|
||||
handler(Location, _, _, Options),
|
||||
option(id(ID), Options),
|
||||
option(priority(P0), Options, 0),
|
||||
Priority is P0+1000. % id(ID) takes preference over predicate
|
||||
location_by_id_raw(ID, Location, Priority) :-
|
||||
handler(Location, M:C, _, Options),
|
||||
option(priority(Priority), Options, 0),
|
||||
functor(C, PN, _),
|
||||
( ID = M:PN
|
||||
; ID = PN
|
||||
), !.
|
||||
|
||||
|
||||
%% http_link_to_id(+HandleID, +Parameters, -HREF)
|
||||
%
|
||||
% HREF is a link on the local server to a handler with given ID,
|
||||
% passing the given Parameters.
|
||||
|
||||
http_link_to_id(HandleID, Parameters, HREF) :-
|
||||
http_location_by_id(HandleID, Location),
|
||||
uri_data(path, Components, Location),
|
||||
uri_query_components(String, Parameters),
|
||||
uri_data(search, Components, String),
|
||||
uri_components(HREF, Components).
|
||||
|
||||
|
||||
% hook into html_write:attribute_value//1.
|
||||
|
||||
:- multifile
|
||||
html_write:expand_attribute_value//1.
|
||||
|
||||
html_write:expand_attribute_value(location_by_id(ID)) -->
|
||||
{ http_location_by_id(ID, Location) },
|
||||
html_write:html_quoted_attribute(Location).
|
||||
|
||||
|
||||
%% authentication(+Options, +Request, -Fields) is det.
|
||||
%
|
||||
% Verify authentication information. If authentication is
|
||||
% requested through Options, demand it. The actual verification is
|
||||
% done by the multifile predicate http_dispatch:authenticate/3.
|
||||
% The library http_authenticate.pl provides an implementation
|
||||
% thereof.
|
||||
%
|
||||
% @error permission_error(access, http_location, Location)
|
||||
|
||||
:- multifile
|
||||
http:authenticate/3.
|
||||
|
||||
authentication([], _, []).
|
||||
authentication([authentication(Type)|Options], Request, Fields) :- !,
|
||||
( http:authenticate(Type, Request, XFields)
|
||||
-> append(XFields, More, Fields),
|
||||
authentication(Options, Request, More)
|
||||
; memberchk(path(Path), Request),
|
||||
throw(error(permission_error(access, http_location, Path), _))
|
||||
).
|
||||
authentication([_|Options], Request, Fields) :-
|
||||
authentication(Options, Request, Fields).
|
||||
|
||||
|
||||
%% find_handler(+Path, -Action, -Options) is det.
|
||||
%
|
||||
% Find the handler to call from Path. Rules:
|
||||
%
|
||||
% * If there is a matching handler, use this.
|
||||
% * If there are multiple prefix(Path) handlers, use the
|
||||
% longest.
|
||||
%
|
||||
% If there is a handler for =|/dir/|= and the requested path is
|
||||
% =|/dir|=, find_handler/3 throws a http_reply exception, causing
|
||||
% the wrapper to generate a 301 (Moved Permanently) reply.
|
||||
%
|
||||
% @error existence_error(http_location, Location)
|
||||
% @throw http_reply(moved(Dir))
|
||||
% @tbd Introduce automatic redirection to indexes here?
|
||||
|
||||
find_handler(Path, Action, Options) :-
|
||||
path_tree(Tree),
|
||||
( find_handler(Tree, Path, Action, Options)
|
||||
-> true
|
||||
; \+ sub_atom(Path, _, _, 0, /),
|
||||
atom_concat(Path, /, Dir),
|
||||
find_handler(Tree, Dir, Action, Options)
|
||||
-> throw(http_reply(moved(Dir)))
|
||||
; throw(error(existence_error(http_location, Path), _))
|
||||
).
|
||||
|
||||
|
||||
find_handler([node(prefix(Prefix), PAction, POptions, Children)|_],
|
||||
Path, Action, Options) :-
|
||||
sub_atom(Path, 0, _, After, Prefix), !,
|
||||
( find_handler(Children, Path, Action, Options)
|
||||
-> true
|
||||
; Action = PAction,
|
||||
path_info(After, Path, POptions, Options)
|
||||
).
|
||||
find_handler([node(Path, Action, Options, _)|_], Path, Action, Options) :- !.
|
||||
find_handler([_|Tree], Path, Action, Options) :-
|
||||
find_handler(Tree, Path, Action, Options).
|
||||
|
||||
path_info(0, _, Options,
|
||||
[prefix(true)|Options]) :- !.
|
||||
path_info(After, Path, Options,
|
||||
[path_info(PathInfo),prefix(true)|Options]) :-
|
||||
sub_atom(Path, _, After, 0, PathInfo).
|
||||
|
||||
|
||||
%% action(+Action, +Request, +Options) is det.
|
||||
%
|
||||
% Execute the action found. Here we take care of the options
|
||||
% =time_limit=, =chunked= and =spawn=.
|
||||
%
|
||||
% @error goal_failed(Goal)
|
||||
|
||||
action(Action, Request, Options) :-
|
||||
memberchk(chunked, Options), !,
|
||||
format('Transfer-encoding: chunked~n'),
|
||||
spawn_action(Action, Request, Options).
|
||||
action(Action, Request, Options) :-
|
||||
spawn_action(Action, Request, Options).
|
||||
|
||||
spawn_action(Action, Request, Options) :-
|
||||
option(spawn(Spawn), Options), !,
|
||||
spawn_options(Spawn, SpawnOption),
|
||||
http_spawn(time_limit_action(Action, Request, Options), SpawnOption).
|
||||
spawn_action(Action, Request, Options) :-
|
||||
time_limit_action(Action, Request, Options).
|
||||
|
||||
spawn_options([], []) :- !.
|
||||
spawn_options(Pool, Options) :-
|
||||
atom(Pool), !,
|
||||
Options = [pool(Pool)].
|
||||
spawn_options(List, List).
|
||||
|
||||
time_limit_action(Action, Request, Options) :-
|
||||
( option(time_limit(TimeLimit), Options),
|
||||
TimeLimit \== default
|
||||
-> true
|
||||
; setting(http:time_limit, TimeLimit)
|
||||
),
|
||||
number(TimeLimit),
|
||||
TimeLimit > 0, !,
|
||||
call_with_time_limit(TimeLimit, call_action(Action, Request, Options)).
|
||||
time_limit_action(Action, Request, Options) :-
|
||||
call_action(Action, Request, Options).
|
||||
|
||||
|
||||
%% call_action(+Action, +Request, +Options)
|
||||
%
|
||||
% @tbd reply_file is normal call?
|
||||
|
||||
call_action(reply_file(File, FileOptions), Request, _Options) :- !,
|
||||
http_reply_file(File, FileOptions, Request).
|
||||
call_action(Pred, Request, Options) :-
|
||||
memberchk(path_info(PathInfo), Options), !,
|
||||
call_action(Pred, [path_info(PathInfo)|Request]).
|
||||
call_action(Pred, Request, _Options) :-
|
||||
call_action(Pred, Request).
|
||||
|
||||
call_action(Pred, Request) :-
|
||||
( call(Pred, Request)
|
||||
-> true
|
||||
; extend(Pred, [Request], Goal),
|
||||
throw(error(goal_failed(Goal), _))
|
||||
).
|
||||
|
||||
extend(Var, _, Var) :-
|
||||
var(Var), !.
|
||||
extend(M:G0, Extra, M:G) :-
|
||||
extend(G0, Extra, G).
|
||||
extend(G0, Extra, G) :-
|
||||
G0 =.. List,
|
||||
append(List, Extra, List2),
|
||||
G =.. List2.
|
||||
|
||||
%% http_reply_file(+FileSpec, +Options, +Request) is det.
|
||||
%
|
||||
% Options is a list of
|
||||
%
|
||||
% * cache(+Boolean)
|
||||
% If =true= (default), handle If-modified-since and send
|
||||
% modification time.
|
||||
%
|
||||
% * mime_type(+Type)
|
||||
% Overrule mime-type guessing from the filename as
|
||||
% provided by file_mime_type/2.
|
||||
%
|
||||
% * unsafe(+Boolean)
|
||||
% If =false= (default), validate that FileSpec does not
|
||||
% contain references to parent directories. E.g.,
|
||||
% specifications such as =|www('../../etc/passwd')|= are
|
||||
% not allowed.
|
||||
%
|
||||
% If caching is not disabled, it processed the request headers
|
||||
% =|If-modified-since|= and =Range=.
|
||||
%
|
||||
% @throws http_reply(not_modified)
|
||||
% @throws http_reply(file(MimeType, Path))
|
||||
|
||||
http_reply_file(File, Options, Request) :-
|
||||
http_safe_file(File, Options),
|
||||
absolute_file_name(File, Path,
|
||||
[ access(read)
|
||||
]),
|
||||
( option(cache(true), Options, true)
|
||||
-> ( memberchk(if_modified_since(Since), Request),
|
||||
time_file(Path, Time),
|
||||
catch(http_timestamp(Time, Since), _, fail)
|
||||
-> throw(http_reply(not_modified))
|
||||
; true
|
||||
),
|
||||
( memberchk(range(Range), Request)
|
||||
-> Reply = file(Type, Path, Range)
|
||||
; Reply = file(Type, Path)
|
||||
)
|
||||
; Reply = tmp_file(Type, Path)
|
||||
),
|
||||
( option(mime_type(Type), Options)
|
||||
-> true
|
||||
; file_mime_type(Path, Type)
|
||||
-> true
|
||||
; Type = text/plain % fallback type
|
||||
),
|
||||
throw(http_reply(Reply)).
|
||||
|
||||
%% http_safe_file(+FileSpec, +Options) is det.
|
||||
%
|
||||
% True if FileSpec is considered _safe_. If it is an atom, it
|
||||
% cannot be absolute and cannot have references to parent
|
||||
% directories. If it is of the form alias(Sub), than Sub cannot
|
||||
% have references to parent directories.
|
||||
%
|
||||
% @error instantiation_error
|
||||
% @error permission_error(read, file, FileSpec)
|
||||
|
||||
http_safe_file(File, _) :-
|
||||
var(File), !,
|
||||
instantiation_error(File).
|
||||
http_safe_file(_, Options) :-
|
||||
option(unsafe(true), Options, false), !.
|
||||
http_safe_file(File, _) :-
|
||||
http_safe_file(File).
|
||||
|
||||
http_safe_file(File) :-
|
||||
compound(File),
|
||||
functor(File, _, 1), !,
|
||||
arg(1, File, Name),
|
||||
safe_name(Name, File).
|
||||
http_safe_file(Name) :-
|
||||
( is_absolute_file_name(Name)
|
||||
-> permission_error(read, file, Name)
|
||||
; true
|
||||
),
|
||||
safe_name(Name, Name).
|
||||
|
||||
safe_name(Name, _) :-
|
||||
must_be(atom, Name),
|
||||
\+ unsafe_name(Name), !.
|
||||
safe_name(_, Spec) :-
|
||||
permission_error(read, file, Spec).
|
||||
|
||||
unsafe_name(Name) :- Name == '..'.
|
||||
unsafe_name(Name) :- sub_atom(Name, 0, _, _, '../').
|
||||
unsafe_name(Name) :- sub_atom(Name, _, _, _, '/../').
|
||||
unsafe_name(Name) :- sub_atom(Name, _, _, 0, '/..').
|
||||
|
||||
|
||||
%% http_redirect(+How, +To, +Request) is det.
|
||||
%
|
||||
% Redirect to a new location. The argument order, using the
|
||||
% Request as last argument, allows for calling this directly from
|
||||
% the handler declaration:
|
||||
%
|
||||
% ==
|
||||
% :- http_handler(root(.),
|
||||
% http_redirect(moved, myapp('index.html')),
|
||||
% []).
|
||||
% ==
|
||||
%
|
||||
% @param How is one of =moved=, =moved_temporary= or =see_also=
|
||||
% @param To is an atom, a aliased path as defined by
|
||||
% http_absolute_location/3. or a term location_by_id(Id). If To is
|
||||
% not absolute, it is resolved relative to the current location.
|
||||
|
||||
http_redirect(How, To, Request) :-
|
||||
( To = location_by_id(Id)
|
||||
-> http_location_by_id(Id, URL)
|
||||
; memberchk(path(Base), Request),
|
||||
http_absolute_location(To, URL, [relative_to(Base)])
|
||||
),
|
||||
must_be(oneof([moved, moved_temporary, see_also]), How),
|
||||
Term =.. [How,URL],
|
||||
throw(http_reply(Term)).
|
||||
|
||||
|
||||
/*******************************
|
||||
* PATH COMPILATION *
|
||||
*******************************/
|
||||
|
||||
%% path_tree(-Tree) is det.
|
||||
%
|
||||
% Compile paths into a tree. The treee is multi-rooted and
|
||||
% represented as a list of nodes, where each node has the form:
|
||||
%
|
||||
% node(PathOrPrefix, Action, Options, Children)
|
||||
%
|
||||
% The tree is a potentially complicated structure. It is cached in
|
||||
% a global variable. Note that this cache is per-thread, so each
|
||||
% worker thread holds a copy of the tree. If handler facts are
|
||||
% changed the _generation_ is incremented using next_generation/0
|
||||
% and each worker thread will re-compute the tree on the next
|
||||
% ocasion.
|
||||
|
||||
path_tree(Tree) :-
|
||||
current_generation(G),
|
||||
nb_current(http_dispatch_tree, G-Tree), !. % Avoid existence error
|
||||
path_tree(Tree) :-
|
||||
findall(Prefix, prefix_handler(Prefix, _, _), Prefixes0),
|
||||
sort(Prefixes0, Prefixes),
|
||||
prefix_tree(Prefixes, [], PTree),
|
||||
prefix_options(PTree, [], OPTree),
|
||||
add_paths_tree(OPTree, Tree),
|
||||
current_generation(G),
|
||||
nb_setval(http_dispatch_tree, G-Tree).
|
||||
|
||||
prefix_handler(Prefix, Action, Options) :-
|
||||
handler(Spec, Action, true, Options),
|
||||
http_absolute_location(Spec, Prefix, []).
|
||||
|
||||
%% prefix_tree(PrefixList, +Tree0, -Tree)
|
||||
%
|
||||
% @param Tree list(Prefix-list(Children))
|
||||
|
||||
prefix_tree([], Tree, Tree).
|
||||
prefix_tree([H|T], Tree0, Tree) :-
|
||||
insert_prefix(H, Tree0, Tree1),
|
||||
prefix_tree(T, Tree1, Tree).
|
||||
|
||||
insert_prefix(Prefix, Tree0, Tree) :-
|
||||
select(P-T, Tree0, Tree1),
|
||||
sub_atom(Prefix, 0, _, _, P), !,
|
||||
insert_prefix(Prefix, T, T1),
|
||||
Tree = [P-T1|Tree1].
|
||||
insert_prefix(Prefix, Tree, [Prefix-[]|Tree]).
|
||||
|
||||
|
||||
%% prefix_options(+PrefixTree, +DefOptions, -OptionTree)
|
||||
%
|
||||
% Generate the option-tree for all prefix declarations.
|
||||
%
|
||||
% @tbd What to do if there are more?
|
||||
|
||||
prefix_options([], _, []).
|
||||
prefix_options([P-C|T0], DefOptions,
|
||||
[node(prefix(P), Action, Options, Children)|T]) :-
|
||||
once(prefix_handler(P, Action, Options0)),
|
||||
merge_options(Options0, DefOptions, Options),
|
||||
prefix_options(C, Options, Children),
|
||||
prefix_options(T0, DefOptions, T).
|
||||
|
||||
|
||||
%% add_paths_tree(+OPTree, -Tree) is det.
|
||||
%
|
||||
% Add the plain paths.
|
||||
|
||||
add_paths_tree(OPTree, Tree) :-
|
||||
findall(path(Path, Action, Options),
|
||||
plain_path(Path, Action, Options),
|
||||
Triples),
|
||||
add_paths_tree(Triples, OPTree, Tree).
|
||||
|
||||
add_paths_tree([], Tree, Tree).
|
||||
add_paths_tree([path(Path, Action, Options)|T], Tree0, Tree) :-
|
||||
add_path_tree(Path, Action, Options, [], Tree0, Tree1),
|
||||
add_paths_tree(T, Tree1, Tree).
|
||||
|
||||
|
||||
%% plain_path(-Path, -Action, -Options) is nondet.
|
||||
%
|
||||
% True if {Path,Action,Options} is registered and Path is a plain
|
||||
% (i.e. not _prefix_) location.
|
||||
|
||||
plain_path(Path, Action, Options) :-
|
||||
handler(Spec, Action, false, Options),
|
||||
http_absolute_location(Spec, Path, []).
|
||||
|
||||
|
||||
%% add_path_tree(+Path, +Action, +Options, +Tree0, -Tree) is det.
|
||||
%
|
||||
% Add a path to a tree. If a handler for the same path is already
|
||||
% defined, the one with the highest priority or the latest takes
|
||||
% precedence.
|
||||
|
||||
add_path_tree(Path, Action, Options0, DefOptions, [],
|
||||
[node(Path, Action, Options, [])]) :- !,
|
||||
merge_options(Options0, DefOptions, Options).
|
||||
add_path_tree(Path, Action, Options, _,
|
||||
[node(prefix(Prefix), PA, DefOptions, Children0)|RestTree],
|
||||
[node(prefix(Prefix), PA, DefOptions, Children)|RestTree]) :-
|
||||
sub_atom(Path, 0, _, _, Prefix), !,
|
||||
add_path_tree(Path, Action, Options, DefOptions, Children0, Children).
|
||||
add_path_tree(Path, Action, Options1, DefOptions, [H0|T], [H|T]) :-
|
||||
H0 = node(Path, _, Options2, _),
|
||||
option(priority(P1), Options1, 0),
|
||||
option(priority(P2), Options2, 0),
|
||||
P1 >= P2, !,
|
||||
merge_options(Options1, DefOptions, Options),
|
||||
H = node(Path, Action, Options, []).
|
||||
add_path_tree(Path, Action, Options, DefOptions, [H|T0], [H|T]) :-
|
||||
add_path_tree(Path, Action, Options, DefOptions, T0, T).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(http_dispatch(ambiguous_id(ID, _List, Selected))) -->
|
||||
[ 'HTTP dispatch: ambiguous handler ID ~q (selected ~q)'-[ID, Selected]
|
||||
].
|
||||
prolog:message(http_dispatch(prefix(_Path))) -->
|
||||
[ 'HTTP dispatch: prefix(Path) is replaced by the option prefix'-[]
|
||||
].
|
||||
|
||||
|
||||
/*******************************
|
||||
* XREF *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:meta_goal/2.
|
||||
:- dynamic
|
||||
prolog:meta_goal/2.
|
||||
|
||||
prolog:meta_goal(http_handler(_, G, _), [G+1]).
|
||||
prolog:meta_goal(http_current_handler(_, G), [G+1]).
|
||||
|
||||
|
||||
/*******************************
|
||||
* EDIT *
|
||||
*******************************/
|
||||
|
||||
% Allow edit(Location) to edit the implementation for an HTTP location.
|
||||
|
||||
:- multifile
|
||||
prolog_edit:locate/3.
|
||||
|
||||
prolog_edit:locate(Path, Spec, Location) :-
|
||||
atom(Path),
|
||||
Pred = _M:_H,
|
||||
http_current_handler(Path, Pred),
|
||||
closure_name_arity(Pred, 1, PI),
|
||||
prolog_edit:locate(PI, Spec, Location).
|
||||
|
||||
closure_name_arity(M:Term, Extra, M:Name/Arity) :- !,
|
||||
callable(Term),
|
||||
functor(Term, Name, Arity0),
|
||||
Arity is Arity0 + Extra.
|
||||
closure_name_arity(Term, Extra, Name/Arity) :-
|
||||
callable(Term),
|
||||
functor(Term, Name, Arity0),
|
||||
Arity is Arity0 + Extra.
|
||||
|
||||
|
||||
/*******************************
|
||||
* CACHE CLEANUP *
|
||||
*******************************/
|
||||
|
||||
:- listen(settings(changed(http:prefix, _, _)),
|
||||
next_generation).
|
||||
|
||||
:- multifile
|
||||
user:message_hook/3.
|
||||
:- dynamic
|
||||
user:message_hook/3.
|
||||
|
||||
user:message_hook(make(done(Reload)), _Level, _Lines) :-
|
||||
Reload \== [],
|
||||
next_generation,
|
||||
fail.
|
||||
171
packages/http/http_error.c
Normal file
171
packages/http/http_error.c
Normal file
@ -0,0 +1,171 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2007, University of Amsterdam
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
This library is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
*/
|
||||
|
||||
#include <SWI-Stream.h>
|
||||
#include <SWI-Prolog.h>
|
||||
|
||||
#define O_DEBUG 1
|
||||
|
||||
static functor_t FUNCTOR_error2; /* error(Formal, Context) */
|
||||
static functor_t FUNCTOR_type_error2; /* type_error(Term, Expected) */
|
||||
static functor_t FUNCTOR_domain_error2; /* domain_error(Term, Expected) */
|
||||
static functor_t FUNCTOR_permission_error3; /* permission_error(Op, Type, Term) */
|
||||
static functor_t FUNCTOR_existence_error2; /* existence_error(Type, Term) */
|
||||
static int debuglevel = 0;
|
||||
|
||||
#define MKFUNCTOR(name, arity) PL_new_functor(PL_new_atom(name), arity)
|
||||
|
||||
#ifdef O_DEBUG
|
||||
#define DEBUG(n, g) if ( debuglevel >= n ) g
|
||||
#else
|
||||
#define DEBUG(n, g) (void)0
|
||||
#endif
|
||||
|
||||
|
||||
#ifdef O_DEBUG
|
||||
static foreign_t
|
||||
http_stream_debug(term_t level)
|
||||
{ return PL_get_integer(level, &debuglevel);
|
||||
}
|
||||
#endif
|
||||
|
||||
|
||||
/*******************************
|
||||
* ERRORS *
|
||||
*******************************/
|
||||
|
||||
static int
|
||||
type_error(term_t actual, const char *expected)
|
||||
{ term_t ex;
|
||||
|
||||
if ( (ex = PL_new_term_ref()) &&
|
||||
PL_unify_term(ex,
|
||||
PL_FUNCTOR, FUNCTOR_error2,
|
||||
PL_FUNCTOR, FUNCTOR_type_error2,
|
||||
PL_CHARS, expected,
|
||||
PL_TERM, actual,
|
||||
PL_VARIABLE) )
|
||||
return PL_raise_exception(ex);
|
||||
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
domain_error(term_t actual, const char *domain)
|
||||
{ term_t ex;
|
||||
|
||||
if ( (ex = PL_new_term_ref()) &&
|
||||
PL_unify_term(ex,
|
||||
PL_FUNCTOR, FUNCTOR_error2,
|
||||
PL_FUNCTOR, FUNCTOR_domain_error2,
|
||||
PL_CHARS, domain,
|
||||
PL_TERM, actual,
|
||||
PL_VARIABLE) )
|
||||
return PL_raise_exception(ex);
|
||||
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
existence_error(term_t actual, const char *type)
|
||||
{ term_t ex;
|
||||
|
||||
if ( (ex = PL_new_term_ref()) &&
|
||||
PL_unify_term(ex,
|
||||
PL_FUNCTOR, FUNCTOR_error2,
|
||||
PL_FUNCTOR, FUNCTOR_existence_error2,
|
||||
PL_CHARS, type,
|
||||
PL_TERM, actual,
|
||||
PL_VARIABLE) )
|
||||
return PL_raise_exception(ex);
|
||||
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
permission_error(const char *op, const char *objtype, term_t obj)
|
||||
{ term_t ex;
|
||||
|
||||
if ( (ex = PL_new_term_ref()) &&
|
||||
PL_unify_term(ex,
|
||||
PL_FUNCTOR, FUNCTOR_error2,
|
||||
PL_FUNCTOR, FUNCTOR_permission_error3,
|
||||
PL_CHARS, op,
|
||||
PL_CHARS, objtype,
|
||||
PL_TERM, obj,
|
||||
PL_VARIABLE) )
|
||||
return PL_raise_exception(ex);
|
||||
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
instantiation_error()
|
||||
{ term_t ex;
|
||||
|
||||
if ( (ex = PL_new_term_ref()) &&
|
||||
PL_unify_term(ex,
|
||||
PL_FUNCTOR, FUNCTOR_error2,
|
||||
PL_CHARS, "instantiation_error",
|
||||
PL_VARIABLE) )
|
||||
return PL_raise_exception(ex);
|
||||
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
get_int_ex(term_t t, int *i)
|
||||
{ if ( PL_get_integer(t, i) )
|
||||
return TRUE;
|
||||
|
||||
return type_error(t, "integer");
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
get_bool_ex(term_t t, int *i)
|
||||
{ if ( PL_get_bool(t, i) )
|
||||
return TRUE;
|
||||
|
||||
return type_error(t, "boolean");
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
init_errors()
|
||||
{ FUNCTOR_error2 = MKFUNCTOR("error", 2);
|
||||
FUNCTOR_type_error2 = MKFUNCTOR("type_error", 2);
|
||||
FUNCTOR_domain_error2 = MKFUNCTOR("domain_error", 2);
|
||||
FUNCTOR_existence_error2 = MKFUNCTOR("existence_error", 2);
|
||||
FUNCTOR_permission_error3 = MKFUNCTOR("permission_error", 3);
|
||||
|
||||
#ifdef O_DEBUG
|
||||
PL_register_foreign("http_stream_debug", 1, http_stream_debug, 0);
|
||||
#endif
|
||||
}
|
||||
100
packages/http/http_error.pl
Normal file
100
packages/http/http_error.pl
Normal file
@ -0,0 +1,100 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2005, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_error,
|
||||
[
|
||||
]).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(prolog_stack)).
|
||||
|
||||
/** <module> Decorate uncaught exceptions with stack-trace
|
||||
|
||||
This module decorates uncaught exceptions of the user code with a full
|
||||
stack-trace. It is based on a hook introduced in SWI-Prolog 5.6.5.
|
||||
Please note that although loading this module greatly simplifies
|
||||
debugging, it also provides clues for hackers on how to compromise your
|
||||
site. The more information you give them, the easier it is to break into
|
||||
your server!
|
||||
|
||||
To use this file, simply load it.
|
||||
|
||||
@author Jan Wielemaker
|
||||
*/
|
||||
|
||||
:- multifile
|
||||
user:prolog_exception_hook/4.
|
||||
:- dynamic
|
||||
user:prolog_exception_hook/4.
|
||||
|
||||
guard(httpd_wrapper:call_handler/6). % old version
|
||||
guard(httpd_wrapper:wrapper/5).
|
||||
guard(httpd_wrapper:handler_with_output_to/5).
|
||||
|
||||
user:prolog_exception_hook(error(E, context(Ctx0,Msg)),
|
||||
error(E, context(prolog_stack(Stack),Msg)),
|
||||
Fr, Guard) :-
|
||||
Guard \== none,
|
||||
prolog_frame_attribute(Guard, predicate_indicator, Goal),
|
||||
debug(http_error, 'Got exception ~p (Ctx0=~p, Catcher=~p)',
|
||||
[E, Ctx0, Goal]),
|
||||
guard(Goal),
|
||||
get_prolog_backtrace(Fr, 50, Stack0),
|
||||
debug(http_error, 'Stack = ~w', [Stack0]),
|
||||
clean_stack(Stack0, Stack).
|
||||
|
||||
clean_stack([], []).
|
||||
clean_stack([H|_], [H]) :-
|
||||
guard_frame(H), !.
|
||||
clean_stack([H|T0], [H|T]) :-
|
||||
clean_stack(T0, T).
|
||||
|
||||
guard_frame(frame(_,clause(ClauseRef, _))) :-
|
||||
nth_clause(M:Head, _, ClauseRef),
|
||||
functor(Head, Name, Arity),
|
||||
guard(M:Name/Arity).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(error(Error, context(Stack, Message))) -->
|
||||
{ is_stack(Stack, Frames) }, !,
|
||||
'$messages':translate_message(error(Error, context(_, Message))),
|
||||
[ nl, 'In:', nl ],
|
||||
prolog_stack:message(Frames).
|
||||
|
||||
is_stack(Stack, Frames) :-
|
||||
nonvar(Stack),
|
||||
Stack = prolog_stack(Frames).
|
||||
112
packages/http/http_exception.pl
Normal file
112
packages/http/http_exception.pl
Normal file
@ -0,0 +1,112 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2009, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_exception,
|
||||
[ map_exception_to_http_status/3
|
||||
]).
|
||||
|
||||
/** <module> Internal module of the HTTP server
|
||||
|
||||
@see http_header.pl, http_wrapper.pl
|
||||
*/
|
||||
|
||||
%% map_exception_to_http_status(+Exception, -Reply, -HdrExtra)
|
||||
%
|
||||
% Map certain defined exceptions to special reply codes. The
|
||||
% http(not_modified) provides backward compatibility to
|
||||
% http_reply(not_modified).
|
||||
|
||||
map_exception_to_http_status(http(not_modified),
|
||||
not_modified,
|
||||
[connection('Keep-Alive')]) :- !.
|
||||
map_exception_to_http_status(http_reply(Reply),
|
||||
Reply,
|
||||
[connection(Close)]) :- !,
|
||||
( keep_alive(Reply)
|
||||
-> Close = 'Keep-Alive'
|
||||
; Close = close
|
||||
).
|
||||
map_exception_to_http_status(http_reply(Reply, HdrExtra0),
|
||||
Reply,
|
||||
HdrExtra) :- !,
|
||||
( memberchk(close(_), HdrExtra0)
|
||||
-> HdrExtra = HdrExtra0
|
||||
; HdrExtra = [close(Close)|HdrExtra0],
|
||||
( keep_alive(Reply)
|
||||
-> Close = 'Keep-Alive'
|
||||
; Close = close
|
||||
)
|
||||
).
|
||||
map_exception_to_http_status(error(existence_error(http_location, Location), _),
|
||||
not_found(Location),
|
||||
[connection(close)]) :- !.
|
||||
map_exception_to_http_status(error(permission_error(_, http_location, Location), _),
|
||||
forbidden(Location),
|
||||
[connection(close)]) :- !.
|
||||
map_exception_to_http_status(error(threads_in_pool(_Pool), _),
|
||||
busy,
|
||||
[connection(close)]) :- !.
|
||||
map_exception_to_http_status(E,
|
||||
resource_error(E),
|
||||
[connection(close)]) :-
|
||||
resource_error(E), !.
|
||||
map_exception_to_http_status(E,
|
||||
bad_request(E),
|
||||
[connection(close)]) :-
|
||||
bad_request_error(E), !.
|
||||
map_exception_to_http_status(E,
|
||||
server_error(E),
|
||||
[connection(close)]).
|
||||
|
||||
resource_error(error(resource_error(_), _)).
|
||||
|
||||
bad_request_error(error(domain_error(http_request, _), _)).
|
||||
|
||||
%% keep_alive(+Reply) is semidet.
|
||||
%
|
||||
% If true for Reply, the default is to keep the connection open.
|
||||
|
||||
keep_alive(not_modified).
|
||||
keep_alive(file(_Type, _File)).
|
||||
keep_alive(tmp_file(_Type, _File)).
|
||||
keep_alive(stream(_In, _Len)).
|
||||
keep_alive(cgi_stream(_In, _Len)).
|
||||
|
||||
|
||||
/*******************************
|
||||
* IDE SUPPORT *
|
||||
*******************************/
|
||||
|
||||
% See library('trace/exceptions')
|
||||
|
||||
:- multifile
|
||||
prolog:general_exception/2.
|
||||
|
||||
prolog:general_exception(http_reply(_), http_reply(_)).
|
||||
prolog:general_exception(http_reply(_,_), http_reply(_,_)).
|
||||
1519
packages/http/http_header.pl
Normal file
1519
packages/http/http_header.pl
Normal file
File diff suppressed because it is too large
Load Diff
84
packages/http/http_hook.pl
Normal file
84
packages/http/http_hook.pl
Normal file
@ -0,0 +1,84 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2008, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_hook,
|
||||
[]).
|
||||
|
||||
/** <module> HTTP library hooks
|
||||
|
||||
Get the declarations of the HTTP package using
|
||||
|
||||
==
|
||||
:- use_module(library(http/http_hook)).
|
||||
==
|
||||
|
||||
@tbd This should be using include, but then it cannot be a module
|
||||
and this would cause more overhead in SWI-Prolog
|
||||
@tbd Complete this and document the hooks.
|
||||
*/
|
||||
|
||||
/*******************************
|
||||
* HTTP-PATH *
|
||||
*******************************/
|
||||
|
||||
:- multifile http:location/3.
|
||||
:- dynamic http:location/3.
|
||||
|
||||
|
||||
/*******************************
|
||||
* HTML-WRITE *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
html_write:expand//1,
|
||||
html_write:expand_attribute_value//1,
|
||||
html_write:html_head_expansion/2,
|
||||
html_write:layout/3.
|
||||
|
||||
|
||||
/*******************************
|
||||
* HTTP-DISPATCH *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
http:authenticate/3.
|
||||
|
||||
|
||||
/*******************************
|
||||
* HTTP-PARAMETERS *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
http:convert_parameter/3.
|
||||
|
||||
%% http:convert_parameter(+Type, +ValueIn, -ValueOut) is semidet.
|
||||
%
|
||||
% Hook to execute a step in the HTTP parameter conversion process.
|
||||
%
|
||||
% @see http_parameters:check_type/4.
|
||||
123
packages/http/http_host.pl
Normal file
123
packages/http/http_host.pl
Normal file
@ -0,0 +1,123 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2007-2010, University of Amsterdam,
|
||||
VU University Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_host,
|
||||
[ http_current_host/4 % +Request, -Host, -Port, +Options
|
||||
]).
|
||||
:- use_module(library('http/thread_httpd')).
|
||||
:- use_module(library(socket)).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(library(settings)).
|
||||
|
||||
:- setting(http:public_host, atom, '',
|
||||
'Name the outside world can use to contact me').
|
||||
:- setting(http:public_port, integer, 80,
|
||||
'Port on the public server').
|
||||
|
||||
|
||||
/** <module> Obtain public server location
|
||||
|
||||
This library finds the public address of the running server. This can be
|
||||
used to construct URLs that are visible from anywhere on the internet.
|
||||
This module was introduced to deal with OpenID, where a reques is
|
||||
redirected to the OpenID server, which in turn redirects to our server
|
||||
(see http_openid.pl).
|
||||
|
||||
The address is established from the settings http:public_host and
|
||||
http:public_port if provided. Otherwise it is deduced from the request.
|
||||
*/
|
||||
|
||||
|
||||
%% http_current_host(+Request, -Hostname, -Port, Options) is det.
|
||||
%
|
||||
% Current global host and port of the HTTP server. This is the
|
||||
% basis to form absolute address, which we need for redirection
|
||||
% based interaction such as the OpenID protocol. Options are:
|
||||
%
|
||||
% * global(+Bool)
|
||||
% If =true= (default =false=), try to replace a local hostname
|
||||
% by a world-wide accessible name.
|
||||
|
||||
http_current_host(_, Host, Port, _) :-
|
||||
setting(http:public_host, PublicHost), PublicHost \== '', !,
|
||||
Host = PublicHost,
|
||||
setting(http:public_port, Port).
|
||||
http_current_host(Request, Host, Port, Options) :-
|
||||
( memberchk(x_forwarded_host(Forwarded), Request)
|
||||
-> Port = 80,
|
||||
primary_forwarded_host(Forwarded, Host)
|
||||
; memberchk(host(Host0), Request),
|
||||
( option(global(true), Options, false)
|
||||
-> global_host(Host0, Host)
|
||||
; Host = Host0
|
||||
),
|
||||
option(port(Port), Request, 80)
|
||||
-> true
|
||||
; gethostname(Host),
|
||||
http_current_server(_Pred, Port) % TBD: May be more
|
||||
).
|
||||
|
||||
|
||||
%% primary_forwarded_host(+Spec, -Host) is det.
|
||||
%
|
||||
% x_forwarded host contains multiple hosts seperated by ', ' if
|
||||
% there are multiple proxy servers in between. The first one is
|
||||
% the one the user's browser knows about.
|
||||
|
||||
primary_forwarded_host(Spec, Host) :-
|
||||
sub_atom(Spec, B, _, _, ','), !,
|
||||
sub_atom(Spec, 0, B, _, Host).
|
||||
primary_forwarded_host(Host, Host).
|
||||
|
||||
|
||||
%% global_host(+HostIn, -Host)
|
||||
%
|
||||
% Globalize a hostname. Used if we need to pass our hostname to a
|
||||
% client and expect the client to be able to contact us. In this
|
||||
% case we cannot use a name such as `localhost' or the plain
|
||||
% hostname of the machine. We assume (possibly wrongly) that if
|
||||
% the host contains a '.', it is globally accessible.
|
||||
%
|
||||
% If the heuristics used by this predicate do not suffice, the
|
||||
% setting http:public_host can be used to override.
|
||||
|
||||
global_host(_, Host) :-
|
||||
setting(http:public_host, PublicHost), PublicHost \== '', !,
|
||||
Host = PublicHost.
|
||||
global_host(localhost, Host) :- !,
|
||||
gethostname(Host).
|
||||
global_host(Local, Host) :-
|
||||
sub_atom(Local, _, _, _, '.'), !,
|
||||
Host = Local.
|
||||
global_host(Local, Host) :-
|
||||
tcp_host_to_address(Local, IP),
|
||||
tcp_host_to_address(Host, IP).
|
||||
|
||||
|
||||
206
packages/http/http_json.pl
Normal file
206
packages/http/http_json.pl
Normal file
@ -0,0 +1,206 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2007, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_json,
|
||||
[ reply_json/1, % +JSON
|
||||
reply_json/2, % +JSON, Options
|
||||
http_read_json/2, % +Request, -JSON
|
||||
http_read_json/3 % +Request, -JSON, +Options
|
||||
]).
|
||||
:- use_module(http_client).
|
||||
:- use_module(http_header).
|
||||
:- use_module(http_stream).
|
||||
:- use_module(json).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(memfile)).
|
||||
|
||||
:- multifile
|
||||
http_client:http_convert_data/4,
|
||||
http_client:post_data_hook/3,
|
||||
json_type/1.
|
||||
|
||||
|
||||
/** <module> HTTP JSON Plugin module
|
||||
|
||||
This module inserts the JSON parser for documents of MIME type
|
||||
=|application/jsonrequest|= and =|application/json|= requested through
|
||||
the http_client.pl library.
|
||||
|
||||
Typically JSON is used by Prolog HTTP servers. Below is a skeleton for
|
||||
handling a JSON request, answering in JSON.
|
||||
|
||||
==
|
||||
handle(Request) :-
|
||||
http_read_json(Request, JSONIn),
|
||||
json_to_prolog(JSONIn, PrologIn),
|
||||
<compute>(PrologIn, PrologOut), % application body
|
||||
prolog_to_json(PrologOut, JSONOut),
|
||||
reply_json(JSONOut).
|
||||
==
|
||||
|
||||
This module also integrates JSON support into the http client provided
|
||||
by http_client.pl. Posting a JSON query and processing the JSON reply
|
||||
(or any other reply understood by http_read_data/3) is as simple as
|
||||
below, where Term is a JSON term as described in json.pl and reply is
|
||||
of the same format if the server replies with JSON.
|
||||
|
||||
==
|
||||
...,
|
||||
http_post(URL, json(Term), Reply, [])
|
||||
==
|
||||
|
||||
@see JSON Requests are discussed in http://json.org/JSONRequest.html
|
||||
@see json.pl describes how JSON objects are represented in Prolog terms.
|
||||
@see json_convert.pl converts between more natural Prolog terms and json
|
||||
terms.
|
||||
*/
|
||||
|
||||
http_client:http_convert_data(In, Fields, Data, Options) :-
|
||||
memberchk(content_type(Type), Fields),
|
||||
is_json_type(Type), !,
|
||||
( memberchk(content_length(Bytes), Fields)
|
||||
-> stream_range_open(In, Range, [size(Bytes)]),
|
||||
set_stream(Range, encoding(utf8)),
|
||||
call_cleanup(json_read(Range, Data, Options), close(Range))
|
||||
; set_stream(In, encoding(utf8)),
|
||||
json_read(In, Data, Options)
|
||||
).
|
||||
|
||||
|
||||
is_json_type(Type) :-
|
||||
json_type(Type), !.
|
||||
is_json_type(ContentType) :-
|
||||
json_type(Type),
|
||||
sub_atom(ContentType, 0, _, _, Type), !,
|
||||
strip_utf8(ContentType, Plain),
|
||||
json_type(Plain).
|
||||
|
||||
|
||||
%% strip_utf8(+ContentTypeIn, -ContentType) is det.
|
||||
%
|
||||
% Strip an optional =|; charset=UTF-8|=. JSON data is always
|
||||
% UTF-8, but some clients seem to insist in sending this.
|
||||
|
||||
strip_utf8(ContentType, Plain) :-
|
||||
sub_atom(ContentType, B, _, A, ;),
|
||||
sub_atom(ContentType, _, A, 0, Ext),
|
||||
normalize_space(atom('charset=UTF-8'), Ext), !,
|
||||
sub_atom(ContentType, 0, B, _, CT),
|
||||
normalize_space(atom(Plain), CT).
|
||||
strip_utf8(ContentType, ContentType).
|
||||
|
||||
|
||||
%% json_type(?MIMEType:atom) is semidet.
|
||||
%
|
||||
% True if MIMEType is a JSON mimetype. http_json:json_type/1 is a
|
||||
% multifile predicate and may be extended to facilitate
|
||||
% non-conforming clients.
|
||||
|
||||
json_type('application/jsonrequest').
|
||||
json_type('application/json').
|
||||
|
||||
|
||||
% http_client:post_data_hook(+Data, +Out:stream, +HdrExtra) is semidet.
|
||||
%
|
||||
% Hook into http_post_data/3 that allows for
|
||||
%
|
||||
% ==
|
||||
% http_post(URL, json(Term), Reply, Options)
|
||||
% ==
|
||||
%
|
||||
% @tbd avoid creation of intermediate data using chunked output.
|
||||
|
||||
http_client:post_data_hook(json(Term), Out, HdrExtra) :-
|
||||
http_client:post_data_hook(json(Term, []), Out, HdrExtra).
|
||||
http_client:post_data_hook(json(Term, Options), Out, HdrExtra) :-
|
||||
option(content_type(Type), HdrExtra, 'application/json'),
|
||||
new_memory_file(MemFile),
|
||||
open_memory_file(MemFile, write, Handle),
|
||||
format(Handle, 'Content-type: ~w~n~n', [Type]),
|
||||
json_write(Handle, Term, Options),
|
||||
close(Handle),
|
||||
open_memory_file(MemFile, read, RdHandle),
|
||||
call_cleanup(http_post_data(cgi_stream(RdHandle), Out, HdrExtra),
|
||||
( close(RdHandle),
|
||||
free_memory_file(MemFile))).
|
||||
|
||||
|
||||
%% http_read_json(+Request, -JSON) is det.
|
||||
%% http_read_json(+Request, -JSON, +Options) is det.
|
||||
%
|
||||
% Extract JSON data posted to this HTTP request.
|
||||
%
|
||||
% @error domain_error(mimetype, Found) if the mimetype is
|
||||
% not known (see json_type/1).
|
||||
% @error domain_error(method, Method) if the request is not
|
||||
% a POST request.
|
||||
|
||||
http_read_json(Request, JSON) :-
|
||||
http_read_json(Request, JSON, []).
|
||||
|
||||
http_read_json(Request, JSON, Options) :-
|
||||
select_option(content_type(Type), Options, Rest), !,
|
||||
delete(Request, content_type(_), Request2),
|
||||
request_to_json([content_type(Type)|Request2], JSON, Rest).
|
||||
http_read_json(Request, JSON, Options) :-
|
||||
request_to_json(Request, JSON, Options).
|
||||
|
||||
request_to_json(Request, JSON, Options) :-
|
||||
memberchk(method(Method), Request),
|
||||
memberchk(content_type(Type), Request),
|
||||
( Method == post
|
||||
-> true
|
||||
; domain_error(method, Method)
|
||||
),
|
||||
( is_json_type(Type)
|
||||
-> true
|
||||
; domain_error(mimetype, Type)
|
||||
),
|
||||
http_read_data(Request, JSON, Options).
|
||||
|
||||
|
||||
%% reply_json(+JSONTerm) is det.
|
||||
%% reply_json(+JSONTerm, +Options) is det.
|
||||
%
|
||||
% Formulate a JSON HTTP reply. See json_write/2 for details.
|
||||
% Options accepts content_type(+Type) and options accepted by
|
||||
% json_write/3.
|
||||
|
||||
reply_json(Term) :-
|
||||
format('Content-type: application/json~n~n'),
|
||||
json_write(current_output, Term).
|
||||
|
||||
reply_json(Term, Options) :-
|
||||
select_option(content_type(Type), Options, Rest, 'application/json'),
|
||||
format('Content-type: ~w~n~n', [Type]),
|
||||
json_write(current_output, Term, Rest).
|
||||
263
packages/http/http_log.pl
Normal file
263
packages/http/http_log.pl
Normal file
@ -0,0 +1,263 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2009, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_log,
|
||||
[ http_log_stream/1, % -Stream
|
||||
http_log/2, % +Format, +Args
|
||||
http_log_close/1 % +Reason
|
||||
]).
|
||||
:- use_module(library(settings)).
|
||||
:- use_module(library(broadcast)).
|
||||
|
||||
:- setting(http:logfile, atom, 'httpd.log',
|
||||
'File in which to log HTTP requests').
|
||||
|
||||
/** <module> HTTP Logging module
|
||||
|
||||
Simple module for logging HTTP requests to a file. Logging is enabled by
|
||||
loading this file and ensure the setting http:logfile is not the empty
|
||||
atom. The default file for writing the log is =|httpd.log|=. See
|
||||
library(settings) for details.
|
||||
|
||||
The level of logging can modified using the multifile predicate
|
||||
http_log:nolog/1 to hide HTTP request fields from the logfile and
|
||||
http_log:password_field/1 to hide passwords from HTTP search
|
||||
specifications (e.g. =|/topsecret?password=secret|=).
|
||||
*/
|
||||
|
||||
:- multifile
|
||||
nolog/1,
|
||||
password_field/1.
|
||||
|
||||
% If the log settings change, simply close the log and it will be
|
||||
% reopened with the new settings.
|
||||
|
||||
:- listen(settings(changed(http:logfile, _, New)),
|
||||
http_log_close(changed(New))).
|
||||
:- listen(http(Message),
|
||||
http_message(Message)).
|
||||
|
||||
|
||||
http_message(request_start(Id, Request)) :- !,
|
||||
http_log_stream(Stream),
|
||||
log_started(Request, Id, Stream).
|
||||
http_message(request_finished(Id, Code, Status, CPU, Bytes)) :- !,
|
||||
http_log_stream(Stream),
|
||||
log_completed(Code, Status, Bytes, Id, CPU, Stream).
|
||||
|
||||
|
||||
/*******************************
|
||||
* LOG ACTIVITY *
|
||||
*******************************/
|
||||
|
||||
:- dynamic
|
||||
log_stream/1.
|
||||
|
||||
%% http_log_stream(-Stream) is semidet.
|
||||
%
|
||||
% Returns handle to open logfile. Fails if no logfile is open and
|
||||
% none is defined.
|
||||
|
||||
http_log_stream(Stream) :-
|
||||
log_stream(Stream), !,
|
||||
Stream \== [].
|
||||
http_log_stream(Stream) :-
|
||||
setting(http:logfile, File),
|
||||
File \== '', !,
|
||||
with_mutex(http_log,
|
||||
( open(File, append, Stream,
|
||||
[ close_on_abort(false),
|
||||
encoding(utf8),
|
||||
buffer(line)
|
||||
]),
|
||||
get_time(Time),
|
||||
format(Stream,
|
||||
'server(started, ~0f).~n',
|
||||
[ Time ]),
|
||||
assert(log_stream(Stream)),
|
||||
at_halt(close_log(stopped))
|
||||
)).
|
||||
http_log_stream(_) :-
|
||||
assert(log_stream([])).
|
||||
|
||||
%% http_log_close(+Reason) is det.
|
||||
%
|
||||
% If there is a currently open HTTP logfile, close it after adding
|
||||
% a term server(Reason, Time). to the logfile. This call is
|
||||
% intended for cooperation with the Unix logrotate facility
|
||||
% using the following schema:
|
||||
%
|
||||
% * Move logfile (the HTTP server keeps writing to the moved
|
||||
% file)
|
||||
% * Inform the server using an HTTP request that calls
|
||||
% http_log_close/1
|
||||
% * Compress the moved logfile
|
||||
%
|
||||
% @author Suggested by Jacco van Ossenbruggen
|
||||
|
||||
http_log_close(Reason) :-
|
||||
with_mutex(http_log, close_log(Reason)).
|
||||
|
||||
close_log(Reason) :-
|
||||
retract(log_stream(Stream)), !,
|
||||
( Stream == []
|
||||
-> true
|
||||
; get_time(Time),
|
||||
format(Stream, 'server(~q, ~0f).~n', [ Reason, Time ]),
|
||||
close(Stream)
|
||||
).
|
||||
close_log(_).
|
||||
|
||||
%% http_log(+Format, +Args) is det.
|
||||
%
|
||||
% Write message from Format and Args to log-stream. See format/2
|
||||
% for details. Succeed without side effects if logging is not
|
||||
% enabled.
|
||||
|
||||
http_log(Format, Args) :-
|
||||
( http_log_stream(Stream)
|
||||
-> format(Stream, Format, Args)
|
||||
; true
|
||||
).
|
||||
|
||||
|
||||
%% log_started(+Request, +Id, +Stream) is det.
|
||||
%
|
||||
% Write log message that Request was started to Stream.
|
||||
%
|
||||
% @param Filled with sequence identifier for the request
|
||||
|
||||
log_started(Request, Id, Stream) :-
|
||||
get_time(Now),
|
||||
log_request(Request, LogRequest),
|
||||
format_time(string(HDate), '%+', Now),
|
||||
format(Stream,
|
||||
'/*~s*/ request(~q, ~3f, ~q).~n',
|
||||
[HDate, Id, Now, LogRequest]).
|
||||
|
||||
%% log_request(+Request, -Log)
|
||||
%
|
||||
% Remove passwords from the request to avoid sending them to the
|
||||
% logfiles.
|
||||
|
||||
log_request([], []).
|
||||
log_request([search(Search0)|T0], [search(Search)|T]) :- !,
|
||||
mask_passwords(Search0, Search),
|
||||
log_request(T0, T).
|
||||
log_request([H|T0], T) :-
|
||||
nolog(H), !,
|
||||
log_request(T0, T).
|
||||
log_request([H|T0], [H|T]) :-
|
||||
log_request(T0, T).
|
||||
|
||||
mask_passwords([], []).
|
||||
mask_passwords([Name=_|T0], [Name=xxx|T]) :-
|
||||
password_field(Name), !,
|
||||
mask_passwords(T0, T).
|
||||
mask_passwords([H|T0], [H|T]) :-
|
||||
mask_passwords(T0, T).
|
||||
|
||||
%% password_field(+Field) is semidet.
|
||||
%
|
||||
% Multifile predicate that can be defined to hide passwords from
|
||||
% the logfile.
|
||||
|
||||
password_field(password).
|
||||
password_field(pwd0).
|
||||
password_field(pwd1).
|
||||
password_field(pwd2).
|
||||
|
||||
|
||||
%% nolog(+HTTPField)
|
||||
%
|
||||
% Multifile predicate that can be defined to hide request
|
||||
% parameters from the request logfile.
|
||||
|
||||
nolog(input(_)).
|
||||
nolog(accept(_)).
|
||||
nolog(accept_language(_)).
|
||||
nolog(accept_encoding(_)).
|
||||
nolog(accept_charset(_)).
|
||||
nolog(pool(_)).
|
||||
nolog(protocol(_)).
|
||||
nolog(referer(R)) :-
|
||||
sub_atom(R, _, _, _, password), !.
|
||||
|
||||
%% log_completed(+Code, +Status, +Bytes, +Id, +CPU, +Stream) is det.
|
||||
%
|
||||
% Write log message to Stream from a call_cleanup/3 call.
|
||||
%
|
||||
% @param Status 2nd argument of call_cleanup/3
|
||||
% @param Id Term identifying the completed request
|
||||
% @param CPU0 CPU time at time of entrance
|
||||
% @param Stream Stream to write to (normally from http_log_stream/1).
|
||||
|
||||
log_completed(Code, Status, Bytes, Id, CPU, Stream) :-
|
||||
is_stream(Stream),
|
||||
log_check_deleted(Stream), !,
|
||||
log(Code, Status, Bytes, Id, CPU, Stream).
|
||||
log_completed(Code, Status, Bytes, Id, CPU0, _) :-
|
||||
http_log_stream(Stream), !, % Logfile has changed!
|
||||
log_completed(Code, Status, Bytes, Id, CPU0, Stream).
|
||||
log_completed(_,_,_,_,_,_).
|
||||
|
||||
|
||||
%% log_check_deleted(+Stream) is semidet.
|
||||
%
|
||||
% If the link-count of the stream has dropped to zero, the file
|
||||
% has been deleted/moved. In this case the log file is closed and
|
||||
% log_check_deleted/6 will open a new one. This provides some
|
||||
% support for cleaning up the logfile without shutting down the
|
||||
% server.
|
||||
%
|
||||
% @see logrotate(1) to manage logfiles on Unix systems.
|
||||
|
||||
log_check_deleted(Stream) :-
|
||||
stream_property(Stream, nlink(Links)),
|
||||
Links == 0, !,
|
||||
http_log_close(log_file_deleted),
|
||||
fail.
|
||||
log_check_deleted(_).
|
||||
|
||||
|
||||
log(Code, ok, Bytes, Id, CPU, Stream) :- !,
|
||||
format(Stream, 'completed(~q, ~2f, ~q, ~q, ok).~n',
|
||||
[ Id, CPU, Bytes, Code ]).
|
||||
log(Code, Status, Bytes, Id, CPU, Stream) :-
|
||||
( map_exception(Status, Term)
|
||||
-> true
|
||||
; message_to_string(Status, String),
|
||||
Term = error(String)
|
||||
),
|
||||
format(Stream, 'completed(~q, ~2f, ~q, ~q, ~q).~n',
|
||||
[ Id, CPU, Bytes, Code, Term ]).
|
||||
|
||||
map_exception(http_reply(Reply), Reply).
|
||||
map_exception(error(existence_error(http_location, Location), _Stack),
|
||||
error(404, Location)).
|
||||
79
packages/http/http_mime_plugin.pl
Normal file
79
packages/http/http_mime_plugin.pl
Normal file
@ -0,0 +1,79 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2002, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_mime_plugin, []).
|
||||
:- use_module(http_client).
|
||||
:- use_module(library(memfile)).
|
||||
:- use_module(library(mime)).
|
||||
|
||||
/** <module> MIME client plugin
|
||||
|
||||
This plugin for library(http_client) automatically translates messages
|
||||
with content-type =|multipart/form-data|= into a list of Name = Value
|
||||
pairs, greatly simplifying the processing of forms with this type. It
|
||||
relies on library(mime), which in turn relies on a foreign
|
||||
implementation of the rfc2045 (mime) specifications.
|
||||
*/
|
||||
|
||||
:- multifile
|
||||
http_client:http_convert_data/4,
|
||||
http_parameters:form_data_content_type/1.
|
||||
|
||||
http_client:http_convert_data(In, Fields, Data, Options) :-
|
||||
memberchk(content_type(Type), Fields),
|
||||
( memberchk(mime_version(MimeVersion), Fields)
|
||||
; sub_atom(Type, 0, _, _, 'multipart/form-data'),
|
||||
MimeVersion = '1.0'
|
||||
), !,
|
||||
new_memory_file(MemFile),
|
||||
open_memory_file(MemFile, write, Tmp),
|
||||
format(Tmp, 'Mime-Version: ~w\n', [MimeVersion]),
|
||||
format(Tmp, 'Content-Type: ~w\n\n', [Type]),
|
||||
http_read_data(Fields, _, [in(In), to(stream(Tmp))|Options]),
|
||||
close(Tmp),
|
||||
open_memory_file(MemFile, read, MimeIn),
|
||||
mime_parse(stream(MimeIn), Data0),
|
||||
close(MimeIn),
|
||||
free_memory_file(MemFile),
|
||||
mime_to_form(Data0, Data).
|
||||
|
||||
mime_to_form(mime(A,'',Parts), Form) :-
|
||||
memberchk(type('multipart/form-data'), A),
|
||||
mime_form_fields(Parts, Form), !.
|
||||
mime_to_form(Mime, Mime).
|
||||
|
||||
mime_form_fields([], []).
|
||||
mime_form_fields([mime(A, V, [])|T0], [Name=V|T]) :-
|
||||
memberchk(name(Name), A),
|
||||
mime_form_fields(T0, T).
|
||||
|
||||
http_parameters:form_data_content_type(ContentType) :-
|
||||
sub_atom(ContentType, 0, _, _, 'multipart/form-data').
|
||||
644
packages/http/http_open.pl
Normal file
644
packages/http/http_open.pl
Normal file
@ -0,0 +1,644 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2008, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
|
||||
:- module(http_open,
|
||||
[ http_open/3, % +URL, -Stream, +Options
|
||||
http_set_authorization/2 % +URL, +Authorization
|
||||
]).
|
||||
|
||||
:- use_module(library(url)).
|
||||
:- use_module(library(readutil)).
|
||||
:- use_module(library(socket)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(base64)).
|
||||
:- use_module(library(debug)).
|
||||
|
||||
:- expects_dialect(swi).
|
||||
:- assert(system:swi_io).
|
||||
|
||||
user_agent('SWI-Prolog <http://www.swi-prolog.org>').
|
||||
|
||||
/** <module> Simple HTTP client
|
||||
|
||||
This library provides a light-weight HTTP client library to get the data
|
||||
from a URL. The functionality of the library can be extended by loading
|
||||
two additional modules that acts as plugins:
|
||||
|
||||
* library(http/http_chunked)
|
||||
Loading this library causes http_open/3 to support chunked
|
||||
transfer encoding.
|
||||
|
||||
* library(http/http_header)
|
||||
Loading this library causes http_open/3 to support the =POST= method
|
||||
in addition to =GET= and =HEAD=.
|
||||
|
||||
Here is a simple example to fetch a web-page:
|
||||
|
||||
==
|
||||
?- http_open('http://www.google.com/search?q=prolog', In, []),
|
||||
copy_stream_data(In, user_output),
|
||||
close(In).
|
||||
<!doctype html><head><title>prolog - Google Search</title><script>
|
||||
...
|
||||
==
|
||||
|
||||
The example below fetches the modification time of a web-page. Note that
|
||||
Modified is '' if the web-server does not provide a time-stamp for the
|
||||
resource. See also parse_time/2.
|
||||
|
||||
==
|
||||
modified(URL, Stamp) :-
|
||||
http_open(URL, In,
|
||||
[ method(head),
|
||||
header(last_modified, Modified)
|
||||
]),
|
||||
close(In),
|
||||
Modified \== '',
|
||||
parse_time(Modified, Stamp).
|
||||
close(In).
|
||||
==
|
||||
|
||||
@see xpath/3
|
||||
@see http_get/3
|
||||
@see http_post/4
|
||||
*/
|
||||
|
||||
:- multifile
|
||||
http:encoding_filter/3, % +Encoding, +In0, -In
|
||||
http:current_transfer_encoding/1, % ?Encoding
|
||||
http:http_protocol_hook/7. % +Protocol, +Parts, +In, +Out,
|
||||
% -NewIn, -NewOut, +Options
|
||||
|
||||
|
||||
%% http_open(+URL, -Stream, +Options) is det.
|
||||
%
|
||||
% Open the data at the HTTP server as a Prolog stream. URL is
|
||||
% either an atom specifying a URL or a list representing a
|
||||
% broken-down URL compatible to parse_url/2. After this predicate
|
||||
% succeeds the data can be read from Stream. After completion this
|
||||
% stream must be closed using the built-in Prolog predicate
|
||||
% close/1. Options provides additional options:
|
||||
%
|
||||
% * authorization(+Term)
|
||||
% Send authorization. Currently only supports basic(User,Password).
|
||||
% See also http_set_authorization/2.
|
||||
%
|
||||
% * final_url(-FinalURL)
|
||||
% Unify FinalURL} with the final destination. This differs from
|
||||
% the original URL if the returned head of the original
|
||||
% indicates an HTTP redirect (codes 301, 302 or 303). Without a
|
||||
% redirect, FinalURL is unified with the canonical version of
|
||||
% URL using:
|
||||
%
|
||||
% ==
|
||||
% parse_url(URL, Parts),
|
||||
% parse_url(FinalURL, Parts)
|
||||
% ==
|
||||
%
|
||||
% * header(Name, -AtomValue)
|
||||
% If provided, AtomValue is unified with the value of the
|
||||
% indicated field in the reply header. Name is matched
|
||||
% case-insensitive and the underscore (_) matches the hyphen
|
||||
% (-). Multiple of these options may be provided to extract
|
||||
% multiple header fields. If the header is not available
|
||||
% AtomValue is unified to the empty atom ('').
|
||||
%
|
||||
% * method(+Method)
|
||||
% One of =get= (default) or =head=. The =head= message can be
|
||||
% used in combination with the header(Name, Value) option to
|
||||
% access information on the resource without actually fetching
|
||||
% the resource itself. The returned stream must be closed
|
||||
% immediately. If library(http/http_header) is loaded,
|
||||
% http_open/3 also supports =post=. See the post(Data) option.
|
||||
%
|
||||
% * size(-Size)
|
||||
% Size is unified with the integer value of =|Content-Length|=
|
||||
% in the reply header.
|
||||
%
|
||||
% * timeout(+Timeout)
|
||||
% If provided, set a timeout on the stream using set_stream/2.
|
||||
% With this option if no new data arrives within Timeout seconds
|
||||
% the stream raises an exception. Default is to wait forever
|
||||
% (=infinite=).
|
||||
%
|
||||
% * post(+Data)
|
||||
% Provided if library(http/http_header) is also loaded. Data is
|
||||
% handed to http_post_data/3.
|
||||
%
|
||||
% * proxy(+Host, +Port)
|
||||
% Use an HTTP proxy to connect to the outside world.
|
||||
%
|
||||
% * proxy_authorization(+Authorization)
|
||||
% Send authorization to the proxy. Otherwise the same as the
|
||||
% =authorization= option.
|
||||
%
|
||||
% * request_header(Name = Value)
|
||||
% Additional name-value parts are added in the order of
|
||||
% appearance to the HTTP request header. No interpretation is
|
||||
% done.
|
||||
%
|
||||
% * user_agent(+Agent)
|
||||
% Defines the value of the =|User-Agent|= field of the HTTP
|
||||
% header. Default is =|SWI-Prolog (http://www.swi-prolog.org)|=.
|
||||
%
|
||||
% @error existence_error(url, Id)
|
||||
|
||||
http_open(URL, Stream, Options) :-
|
||||
atom(URL), !,
|
||||
parse_url_ex(URL, Parts),
|
||||
add_authorization(URL, Options, Options1),
|
||||
http_open(Parts, Stream, Options1).
|
||||
http_open(Parts, Stream, Options0) :-
|
||||
memberchk(proxy(Host, ProxyPort), Options0), !,
|
||||
parse_url_ex(Location, Parts),
|
||||
Options = [visited(Parts)|Options0],
|
||||
open_socket(Host:ProxyPort, In, Out, Options),
|
||||
option(protocol(Protocol), Parts, http),
|
||||
default_port(Protocol, DefPort),
|
||||
option(port(Port), Parts, DefPort),
|
||||
host_and_port(Host, DefPort, Port, HostPort),
|
||||
add_authorization(Parts, Options, Options1),
|
||||
send_rec_header(Out, In, Stream, HostPort, Location, Parts, Options1),
|
||||
return_final_url(Options).
|
||||
http_open(Parts, Stream, Options0) :-
|
||||
memberchk(host(Host), Parts),
|
||||
option(protocol(Protocol), Parts, http),
|
||||
default_port(Protocol, DefPort),
|
||||
option(port(Port), Parts, DefPort),
|
||||
http_location(Parts, Location),
|
||||
Options = [visited(Parts)|Options0],
|
||||
open_socket(Host:Port, SocketIn, SocketOut, Options),
|
||||
( http:http_protocol_hook(Protocol, Parts,
|
||||
SocketIn, SocketOut,
|
||||
In, Out, Options)
|
||||
-> true
|
||||
; In = SocketIn,
|
||||
Out = SocketOut
|
||||
),
|
||||
host_and_port(Host, DefPort, Port, HostPort),
|
||||
add_authorization(Parts, Options, Options1),
|
||||
send_rec_header(Out, In, Stream, HostPort, Location, Parts, Options1),
|
||||
return_final_url(Options).
|
||||
|
||||
http:http_protocol_hook(http, _, In, Out, In, Out, _).
|
||||
|
||||
default_port(https, 443) :- !.
|
||||
default_port(_, 80).
|
||||
|
||||
host_and_port(Host, DefPort, DefPort, Host) :- !.
|
||||
host_and_port(Host, _, Port, Host:Port).
|
||||
|
||||
%% send_rec_header(+Out, +In, -InStream,
|
||||
%% +Host, +Location, +Parts, +Options) is det.
|
||||
%
|
||||
% Send header to Out and process reply. If there is an error or
|
||||
% failure, close In and Out and return the error or failure.
|
||||
|
||||
send_rec_header(Out, In, Stream, Host, Location, Parts, Options) :-
|
||||
( catch(guarded_send_rec_header(Out, In, Stream,
|
||||
Host, Location, Parts, Options),
|
||||
E, true)
|
||||
-> ( var(E)
|
||||
-> close(Out)
|
||||
; force_close(In, Out),
|
||||
throw(E)
|
||||
)
|
||||
; force_close(In, Out),
|
||||
fail
|
||||
).
|
||||
|
||||
guarded_send_rec_header(Out, In, Stream, Host, Location, Parts, Options) :-
|
||||
user_agent(Agent, Options),
|
||||
method(Options, MNAME),
|
||||
http_version(Version),
|
||||
format(Out,
|
||||
'~w ~w HTTP/~w\r\n\
|
||||
Host: ~w\r\n\
|
||||
User-Agent: ~w\r\n\
|
||||
Connection: close\r\n',
|
||||
[MNAME, Location, Version, Host, Agent]),
|
||||
x_headers(Options, Out),
|
||||
( option(post(PostData), Options)
|
||||
-> http_header:http_post_data(PostData, Out, [])
|
||||
; format(Out, '\r\n', [])
|
||||
),
|
||||
flush_output(Out),
|
||||
% read the reply header
|
||||
read_header(In, Code, Comment, Lines),
|
||||
do_open(Code, Comment, Lines, Options, Parts, In, Stream).
|
||||
|
||||
|
||||
%% http_version(-Version:atom) is det.
|
||||
%
|
||||
% HTTP version we publish. We can only use 1.1 if we support
|
||||
% chunked encoding, which means http_chunked.pl must be loaded.
|
||||
|
||||
http_version('1.1') :-
|
||||
http:current_transfer_encoding(chunked), !.
|
||||
http_version('1.0').
|
||||
|
||||
force_close(S1, S2) :-
|
||||
close(S1, [force(true)]),
|
||||
close(S2, [force(true)]).
|
||||
|
||||
method(Options, MNAME) :-
|
||||
option(post(_), Options), !,
|
||||
option(method(M), Options, post),
|
||||
( map_method(M, MNAME0)
|
||||
-> MNAME = MNAME0
|
||||
; domain_error(method, M)
|
||||
).
|
||||
method(Options, MNAME) :-
|
||||
option(method(M), Options, get),
|
||||
( map_method(M, MNAME0)
|
||||
-> MNAME = MNAME0
|
||||
; domain_error(method, M)
|
||||
).
|
||||
|
||||
map_method(get, 'GET').
|
||||
map_method(head, 'HEAD').
|
||||
map_method(post, 'POST') :-
|
||||
current_predicate(http_header:http_post_data/3).
|
||||
|
||||
|
||||
%% x_headers(+Options, +Out) is det.
|
||||
%
|
||||
% Emit extra headers from request_header(Name=Value) options in
|
||||
% Options.
|
||||
|
||||
x_headers([], _).
|
||||
x_headers([H|T], Out) :- !,
|
||||
x_header(H, Out),
|
||||
x_headers(T, Out).
|
||||
|
||||
x_header(request_header(Name=Value), Out) :- !,
|
||||
format(Out, '~w: ~w\r\n', [Name, Value]).
|
||||
x_header(proxy_authorization(ProxyAuthorization), Out) :- !,
|
||||
auth_header(ProxyAuthorization, 'Proxy-Authorization', Out).
|
||||
x_header(authorization(Authorization), Out) :- !,
|
||||
auth_header(Authorization, 'Authorization', Out).
|
||||
x_header(_, _).
|
||||
|
||||
auth_header(basic(User, Password), Header, Out) :- !,
|
||||
format(codes(Codes), '~w:~w', [User, Password]),
|
||||
phrase(base64(Codes), Base64Codes),
|
||||
format(Out, '~w: basic ~s\r\n', [Header, Base64Codes]).
|
||||
auth_header(Auth, _, _) :-
|
||||
domain_error(authorization, Auth).
|
||||
|
||||
user_agent(Agent, Options) :-
|
||||
( option(user_agent(Agent), Options)
|
||||
-> true
|
||||
; user_agent(Agent)
|
||||
).
|
||||
|
||||
%% do_open(+HTTPStatusCode, +HTTPStatusComment, +Header,
|
||||
%% +Options, +Parts, +In, -FinalIn) is det.
|
||||
%
|
||||
% Handle the HTTP status. If 200, we are ok. If a redirect, redo
|
||||
% the open, returning a new stream. Else issue an error.
|
||||
%
|
||||
% @error existence_error(url, URL)
|
||||
|
||||
do_open(200, _, Lines, Options, Parts, In0, In) :- !,
|
||||
return_size(Options, Lines),
|
||||
return_fields(Options, Lines),
|
||||
transfer_encoding_filter(Lines, In0, In),
|
||||
% properly re-initialise the stream
|
||||
parse_url_ex(Id, Parts),
|
||||
set_stream(In, file_name(Id)),
|
||||
set_stream(In, record_position(true)).
|
||||
% Handle redirections
|
||||
do_open(Code, _, Lines, Options, Parts, In, Stream) :-
|
||||
redirect_code(Code),
|
||||
location(Lines, Location), !,
|
||||
debug(http(redirect), 'http_open: redirecting to ~w', [Location]),
|
||||
parse_url_ex(Location, Parts, Redirected),
|
||||
close(In),
|
||||
http_open(Redirected, Stream, [visited(Redirected)|Options]).
|
||||
% report anything else as error
|
||||
do_open(Code, Comment, _, _, Parts, _, _) :-
|
||||
parse_url_ex(Id, Parts),
|
||||
( map_error_code(Code, Error)
|
||||
-> Formal =.. [Error, url, Id]
|
||||
; Formal = existence_error(url, Id)
|
||||
),
|
||||
throw(error(Formal, context(_, status(Code, Comment)))).
|
||||
|
||||
%% map_error_code(+HTTPCode, -PrologError) is semidet.
|
||||
%
|
||||
% Map HTTP error codes to Prolog errors.
|
||||
%
|
||||
% @tbd Many more maps. Unfortunately many have no sensible Prolog
|
||||
% counterpart.
|
||||
|
||||
map_error_code(401, permission_error).
|
||||
map_error_code(403, permission_error).
|
||||
map_error_code(404, existence_error).
|
||||
map_error_code(405, permission_error).
|
||||
map_error_code(407, permission_error).
|
||||
map_error_code(410, existence_error).
|
||||
|
||||
redirect_code(301). % moved permanently
|
||||
redirect_code(302). % moved temporary
|
||||
redirect_code(303). % see also
|
||||
|
||||
%% open_socket(+Address, -In, -Out, +Options) is det.
|
||||
%
|
||||
% Create and connect a client socket to Address. Options
|
||||
%
|
||||
% * timeout(+Timeout)
|
||||
% Sets timeout on the stream, *after* connecting the
|
||||
% socket.
|
||||
%
|
||||
% @tbd Make timeout also work on tcp_connect/4.
|
||||
% @tbd This is the same as do_connect/4 in http_client.pl
|
||||
|
||||
open_socket(Address, In, Out, Options) :-
|
||||
debug(http(open), 'http_open: Connecting to ~p ...', [Address]),
|
||||
tcp_socket(Socket),
|
||||
catch(tcp_connect(Socket, Address, In, Out),
|
||||
E,
|
||||
( tcp_close_socket(Socket),
|
||||
throw(E)
|
||||
)),
|
||||
debug(http(open), '\tok ~p --> ~p', [In, Out]),
|
||||
set_stream(In, record_position(false)),
|
||||
( memberchk(Options, timeout(Timeout))
|
||||
-> set_stream(In, timeout(Timeout))
|
||||
; true
|
||||
).
|
||||
|
||||
|
||||
return_size(Options, Lines) :-
|
||||
memberchk(size(Size), Options), !,
|
||||
content_length(Lines, Size).
|
||||
return_size(_, _).
|
||||
|
||||
return_fields([], _).
|
||||
return_fields([header(Name, Value)|T], Lines) :- !,
|
||||
atom_codes(Name, Codes),
|
||||
( member(Line, Lines),
|
||||
phrase(atom_field(Codes, Value), Line)
|
||||
-> true
|
||||
; Value = ''
|
||||
),
|
||||
return_fields(T, Lines).
|
||||
return_fields([_|T], Lines) :-
|
||||
return_fields(T, Lines).
|
||||
|
||||
|
||||
%% return_final_url(+Options) is semidet.
|
||||
%
|
||||
% If Options contains final_url(URL), unify URL with the final
|
||||
% URL after redirections.
|
||||
|
||||
return_final_url(Options) :-
|
||||
memberchk(final_url(URL), Options),
|
||||
var(URL), !,
|
||||
memberchk(visited(Parts), Options),
|
||||
parse_url_ex(URL, Parts).
|
||||
return_final_url(_).
|
||||
|
||||
|
||||
%% transfer_encoding_filter(+Lines, +In0, -In) is det.
|
||||
%
|
||||
% Install filters depending on the encoding.
|
||||
|
||||
transfer_encoding_filter(Lines, In0, In) :-
|
||||
transfer_encoding(Lines, Encoding), !,
|
||||
( http:encoding_filter(Encoding, In0, In)
|
||||
-> true
|
||||
; domain_error(http_encoding, Encoding)
|
||||
).
|
||||
transfer_encoding_filter(_, In, In).
|
||||
|
||||
|
||||
%% transfer_encoding(+Lines, -Encoding) is semidet.
|
||||
%
|
||||
% True if Encoding is the value of the =|Transfer-encoding|=
|
||||
% header.
|
||||
|
||||
transfer_encoding(Lines, Encoding) :-
|
||||
member(Line, Lines),
|
||||
phrase(transfer_encoding(Encoding0), Line), !,
|
||||
debug(http(transfer_encoding), 'Transfer-encoding: ~w', [Encoding0]),
|
||||
Encoding = Encoding0.
|
||||
|
||||
transfer_encoding(Encoding) -->
|
||||
field("transfer-encoding"),
|
||||
rest(Encoding).
|
||||
|
||||
%% read_header(+In:stream, -Code:int, -Comment:atom, -Lines:list)
|
||||
%
|
||||
% Read the HTTP reply-header.
|
||||
%
|
||||
% @param Code Numeric HTTP reply-code
|
||||
% @param Comment Comment of reply-code as atom
|
||||
% @param Lines Remaining header lines as code-lists.
|
||||
|
||||
read_header(In, Code, Comment, Lines) :-
|
||||
read_line_to_codes(In, Line),
|
||||
phrase(first_line(Code, Comment), Line),
|
||||
read_line_to_codes(In, Line2),
|
||||
rest_header(Line2, In, Lines).
|
||||
|
||||
rest_header("", _, []) :- !. % blank line: end of header
|
||||
rest_header(L0, In, [L0|L]) :-
|
||||
read_line_to_codes(In, L1),
|
||||
rest_header(L1, In, L).
|
||||
|
||||
%% content_length(+Header, -Length:int) is semidet.
|
||||
%
|
||||
% Find the Content-Length in an HTTP reply-header.
|
||||
|
||||
content_length(Lines, Length) :-
|
||||
member(Line, Lines),
|
||||
phrase(content_length(Length0), Line), !,
|
||||
Length = Length0.
|
||||
|
||||
location(Lines, Location) :-
|
||||
member(Line, Lines),
|
||||
phrase(atom_field("location", Location), Line), !.
|
||||
|
||||
first_line(Code, Comment) -->
|
||||
"HTTP/", [_], ".", [_],
|
||||
skip_blanks,
|
||||
integer(Code),
|
||||
skip_blanks,
|
||||
rest(Comment).
|
||||
|
||||
atom_field(Name, Value) -->
|
||||
field(Name),
|
||||
rest(Value).
|
||||
|
||||
content_length(Len) -->
|
||||
field("content-length"),
|
||||
integer(Len).
|
||||
|
||||
field([]) -->
|
||||
":",
|
||||
skip_blanks.
|
||||
field([H|T]) -->
|
||||
[C],
|
||||
{ match_header_char(H, C)
|
||||
},
|
||||
field(T).
|
||||
|
||||
match_header_char(C, C) :- !.
|
||||
match_header_char(C, U) :-
|
||||
code_type(C, to_lower(U)), !.
|
||||
match_header_char(0'_, 0'-).
|
||||
|
||||
|
||||
skip_blanks -->
|
||||
[C],
|
||||
{ code_type(C, white)
|
||||
}, !,
|
||||
skip_blanks.
|
||||
skip_blanks -->
|
||||
[].
|
||||
|
||||
%% integer(-Int)//
|
||||
%
|
||||
% Read 1 or more digits and return as integer.
|
||||
|
||||
integer(Code) -->
|
||||
digit(D0),
|
||||
digits(D),
|
||||
{ number_codes(Code, [D0|D])
|
||||
}.
|
||||
|
||||
digit(C) -->
|
||||
[C],
|
||||
{ code_type(C, digit)
|
||||
}.
|
||||
|
||||
digits([D0|D]) -->
|
||||
digit(D0), !,
|
||||
digits(D).
|
||||
digits([]) -->
|
||||
[].
|
||||
|
||||
%% rest(-Atom:atom)//
|
||||
%
|
||||
% Get rest of input as an atom.
|
||||
|
||||
rest(A,L,[]) :-
|
||||
atom_codes(A, L).
|
||||
|
||||
|
||||
/*******************************
|
||||
* AUTHORIZATION MANAGEMENT *
|
||||
*******************************/
|
||||
|
||||
%% http_set_authorization(+URL, +Authorization) is det.
|
||||
%
|
||||
% Set user/password to supply with URLs that have URL as prefix.
|
||||
% If Authorization is the atom =|-|=, possibly defined
|
||||
% authorization is cleared. For example:
|
||||
%
|
||||
% ==
|
||||
% ?- http_set_authorization('http://www.example.com/private/',
|
||||
% basic('John', 'Secret'))
|
||||
% ==
|
||||
%
|
||||
% @tbd Move to a separate module, so http_get/3, etc. can use this
|
||||
% too.
|
||||
|
||||
:- dynamic
|
||||
stored_authorization/2,
|
||||
cached_authorization/2.
|
||||
|
||||
http_set_authorization(URL, Authorization) :-
|
||||
must_be(atom, URL),
|
||||
retractall(stored_authorization(URL, _)),
|
||||
( Authorization = (-)
|
||||
-> true
|
||||
; check_authorization(Authorization),
|
||||
assert(stored_authorization(URL, Authorization))
|
||||
),
|
||||
retractall(cached_authorization(_,_)).
|
||||
|
||||
check_authorization(Var) :-
|
||||
var(Var), !,
|
||||
instantiation_error(Var).
|
||||
check_authorization(basic(User, Password)) :-
|
||||
must_be(atom, User),
|
||||
must_be(atom, Password).
|
||||
|
||||
%% authorization(+URL, -Authorization) is semdet.
|
||||
%
|
||||
% True if Authorization must be supplied for URL.
|
||||
%
|
||||
% @tbd Cleanup cache if it gets too big.
|
||||
|
||||
authorization(_, _) :-
|
||||
\+ stored_authorization(_, _), !,
|
||||
fail.
|
||||
authorization(URL, Authorization) :-
|
||||
cached_authorization(URL, Authorization), !,
|
||||
Authorization \== (-).
|
||||
authorization(URL, Authorization) :-
|
||||
( stored_authorization(Prefix, Authorization),
|
||||
sub_atom(URL, 0, _, _, Prefix)
|
||||
-> assert(cached_authorization(URL, Authorization))
|
||||
; assert(cached_authorization(URL, -)),
|
||||
fail
|
||||
).
|
||||
|
||||
add_authorization(_, Options, Options) :-
|
||||
option(authorization(_), Options), !.
|
||||
add_authorization(For, Options0, Options) :-
|
||||
stored_authorization(_, _) -> % quick test to avoid work
|
||||
( atom(For)
|
||||
-> URL = For
|
||||
; parse_url_ex(URL, For)
|
||||
),
|
||||
authorization(URL, Auth), !,
|
||||
Options = [authorization(Auth)|Options0].
|
||||
add_authorization(_, Options, Options).
|
||||
|
||||
|
||||
parse_url_ex(URL, Parts) :-
|
||||
parse_url(URL, Parts), !.
|
||||
parse_url_ex(URL, _) :-
|
||||
domain_error(url, URL). % Syntax error?
|
||||
|
||||
parse_url_ex(URL, RelativeTo, Parts) :-
|
||||
parse_url(URL, RelativeTo, Parts), !.
|
||||
parse_url_ex(URL, _, _) :-
|
||||
domain_error(url, URL). % Syntax error?
|
||||
|
||||
:- retract(system:swi_io).
|
||||
1125
packages/http/http_openid.pl
Normal file
1125
packages/http/http_openid.pl
Normal file
File diff suppressed because it is too large
Load Diff
283
packages/http/http_parameters.pl
Normal file
283
packages/http/http_parameters.pl
Normal file
@ -0,0 +1,283 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2004-2009, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
|
||||
:- module(http_parameters,
|
||||
[ http_parameters/2, % +Request, -Params
|
||||
http_parameters/3 % +Request, -Params, +TypeG
|
||||
]).
|
||||
:- use_module(http_client).
|
||||
:- use_module(http_mime_plugin).
|
||||
:- use_module(http_hook).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(error)).
|
||||
|
||||
:- meta_predicate
|
||||
http_parameters(+, ?, :).
|
||||
|
||||
%% http_parameters(+Request, ?Parms) is det.
|
||||
%% http_parameters(+Request, ?Parms, :Options) is det.
|
||||
%
|
||||
% Get HTTP GET or POST form-data, applying type validation,
|
||||
% default values, etc. Provided options are:
|
||||
%
|
||||
% * attribute_declarations(:Goal)
|
||||
% Causes the declarations for an attributed named A to be
|
||||
% fetched using call(Goal, A, Declarations).
|
||||
%
|
||||
% * form_data(-Data)
|
||||
% Return the data read from the GET por POST request as a
|
||||
% list Name = Value. All data, including name/value pairs
|
||||
% used for Parms, is unified with Data.
|
||||
|
||||
http_parameters(Request, Params) :-
|
||||
http_parameters(Request, Params, []).
|
||||
|
||||
http_parameters(Request, Params, Options) :-
|
||||
must_be(list, Params),
|
||||
meta_options(is_meta, Options, QOptions),
|
||||
option(attribute_declarations(DeclGoal), QOptions, -),
|
||||
http_parms(Request, Params, DeclGoal, Form),
|
||||
( memberchk(form_data(RForm), QOptions)
|
||||
-> RForm = Form
|
||||
; true
|
||||
).
|
||||
|
||||
is_meta(attribute_declarations).
|
||||
|
||||
|
||||
http_parms(Request, Params, DeclGoal, Data) :-
|
||||
memberchk(method(post), Request),
|
||||
memberchk(content_type(Content), Request),
|
||||
form_data_content_type(Content), !,
|
||||
debug(post_request, 'POST Request: ~p', [Request]),
|
||||
http_read_data(Request, Data, []),
|
||||
debug(post, 'POST Data: ~p', [Data]),
|
||||
fill_parameters(Params, Data, DeclGoal).
|
||||
http_parms(Request, Params, DeclGoal, Search) :-
|
||||
( memberchk(search(Search), Request)
|
||||
-> true
|
||||
; Search = []
|
||||
),
|
||||
fill_parameters(Params, Search, DeclGoal).
|
||||
|
||||
:- multifile
|
||||
form_data_content_type/1.
|
||||
|
||||
form_data_content_type('application/x-www-form-urlencoded').
|
||||
|
||||
%% fill_parameters(+ParamDecls, +FormData, +DeclGoal)
|
||||
%
|
||||
% Fill values from the parameter list
|
||||
|
||||
fill_parameters([], _, _).
|
||||
fill_parameters([H|T], FormData, DeclGoal) :-
|
||||
fill_parameter(H, FormData, DeclGoal),
|
||||
fill_parameters(T, FormData, DeclGoal).
|
||||
|
||||
fill_parameter(H, _, _) :-
|
||||
var(H), !,
|
||||
instantiation_error(H).
|
||||
fill_parameter(group(Members, _Options), FormData, DeclGoal) :- !,
|
||||
fill_parameters(Members, FormData, DeclGoal).
|
||||
fill_parameter(H, FormData, _) :-
|
||||
H =.. [Name,Value,Options], !,
|
||||
fill_param(Name, Value, Options, FormData).
|
||||
fill_parameter(H, FormData, DeclGoal) :-
|
||||
H =.. [Name,Value],
|
||||
( call(DeclGoal, Name, Options)
|
||||
-> true
|
||||
; throw(error(existence_error(attribute_declaration, Name), _))
|
||||
),
|
||||
fill_param(Name, Value, Options, FormData).
|
||||
|
||||
fill_param(Name, Values, Options, FormData) :-
|
||||
memberchk(zero_or_more, Options), !,
|
||||
fill_param_list(FormData, Name, Values, Options).
|
||||
fill_param(Name, Values, Options, FormData) :-
|
||||
memberchk(list(Type), Options), !,
|
||||
fill_param_list(FormData, Name, Values, [Type|Options]).
|
||||
fill_param(Name, Value, Options, FormData) :-
|
||||
( memberchk(Name=Value0, FormData),
|
||||
Value0 \== '' % Not sure
|
||||
-> check_type(Options, Name, Value0, Value)
|
||||
; memberchk(default(Value), Options)
|
||||
-> true
|
||||
; memberchk(optional(true), Options)
|
||||
-> true
|
||||
; throw(error(existence_error(form_data, Name), _))
|
||||
).
|
||||
|
||||
|
||||
fill_param_list([], _, [], _).
|
||||
fill_param_list([Name=Value0|Form], Name, [Value|VT], Options) :- !,
|
||||
check_type(Options, Name, Value0, Value),
|
||||
fill_param_list(Form, Name, VT, Options).
|
||||
fill_param_list([_|Form], Name, VT, Options) :-
|
||||
fill_param_list(Form, Name, VT, Options).
|
||||
|
||||
|
||||
%% check_type(+Options, +FieldName, +ValueIn, -ValueOut) is det.
|
||||
%
|
||||
% Conversion of an HTTP form value. First tries the multifile hook
|
||||
% http:convert_parameter/3 and next the built-in checks.
|
||||
%
|
||||
% @param Option List as provided with the parameter
|
||||
% @param FieldName Name of the HTTP field (for better message)
|
||||
% @param ValueIn Atom value as received from HTTP layer
|
||||
% @param ValueOut Possibly converted final value
|
||||
% @error type_error(Type, Value)
|
||||
|
||||
check_type([], _, Value, Value).
|
||||
check_type([H|T], Field, Value0, Value) :-
|
||||
( check_type_no_error(H, Value0, Value1)
|
||||
-> check_type(T, Field, Value1, Value)
|
||||
; format(string(Msg), 'HTTP parameter ~w', [Field]),
|
||||
throw(error(type_error(H, Value0),
|
||||
context(_, Msg)))
|
||||
).
|
||||
|
||||
check_type_no_error(Type, In, Out) :-
|
||||
http:convert_parameter(Type, In, Out), !.
|
||||
check_type_no_error(Type, In, Out) :-
|
||||
check_type3(Type, In, Out).
|
||||
|
||||
%% check_type3(+Type, +ValueIn, -ValueOut) is semidet.
|
||||
%
|
||||
% HTTP parameter type-check for types that need converting.
|
||||
|
||||
check_type3((T1;T2), In, Out) :- !,
|
||||
( check_type_no_error(T1, In, Out)
|
||||
-> true
|
||||
; check_type_no_error(T2, In, Out)
|
||||
).
|
||||
check_type3(number, Atom, Number) :- !,
|
||||
catch(atom_number(Atom, Number), _, fail).
|
||||
check_type3(integer, Atom, Integer) :- !,
|
||||
catch(atom_number(Atom, Integer), _, fail),
|
||||
integer(Integer).
|
||||
check_type3(nonneg, Atom, Integer) :- !,
|
||||
catch(atom_number(Atom, Integer), _, fail),
|
||||
integer(Integer),
|
||||
Integer >= 0.
|
||||
check_type3(float, Atom, Float) :- !,
|
||||
catch(atom_number(Atom, Number), _, fail),
|
||||
Float is float(Number).
|
||||
check_type3(between(Low, High), Atom, Value) :- !,
|
||||
atom_number(Atom, Number),
|
||||
( (float(Low) ; float(High))
|
||||
-> Value is float(Number)
|
||||
; Value = Number
|
||||
),
|
||||
must_be(between(Low, High), Value).
|
||||
check_type3(boolean, Atom, Bool) :- !,
|
||||
truth(Atom, Bool).
|
||||
check_type3(Type, Atom, Atom) :-
|
||||
check_type2(Type, Atom).
|
||||
|
||||
%% check_type2(+Type, +ValueIn) is semidet.
|
||||
%
|
||||
% HTTP parameter type-check for types that need no conversion.
|
||||
|
||||
check_type2(oneof(Set), Value) :- !,
|
||||
memberchk(Value, Set).
|
||||
check_type2(length > N, Value) :- !,
|
||||
atom_length(Value, Len),
|
||||
Len > N.
|
||||
check_type2(length >= N, Value) :- !,
|
||||
atom_length(Value, Len),
|
||||
Len >= N.
|
||||
check_type2(length < N, Value) :- !,
|
||||
atom_length(Value, Len),
|
||||
Len < N.
|
||||
check_type2(length =< N, Value) :- !,
|
||||
atom_length(Value, Len),
|
||||
Len =< N.
|
||||
check_type2(_, _).
|
||||
|
||||
%% truth(+In, -Boolean) is semidet.
|
||||
%
|
||||
% Translate some commonly used textual representations for true
|
||||
% and false into their canonical representation.
|
||||
|
||||
truth(true, true).
|
||||
truth(yes, true).
|
||||
truth(on, true).
|
||||
truth('1', true).
|
||||
|
||||
truth(false, false).
|
||||
truth(no, false).
|
||||
truth(off, false).
|
||||
truth('0', false).
|
||||
|
||||
|
||||
/*******************************
|
||||
* XREF SUPPORT *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:called_by/2,
|
||||
emacs_prolog_colours:goal_colours/2.
|
||||
|
||||
prolog:called_by(http_parameters(_,_,Options), [G+2]) :-
|
||||
option(attribute_declarations(G), Options, _),
|
||||
callable(G), !.
|
||||
|
||||
emacs_prolog_colours:goal_colours(http_parameters(_,_,Options),
|
||||
built_in-[classify, classify, Colours]) :-
|
||||
option_list_colours(Options, Colours).
|
||||
|
||||
option_list_colours(Var, error) :-
|
||||
var(Var), !.
|
||||
option_list_colours([], classify) :- !.
|
||||
option_list_colours(Term, list-Elements) :-
|
||||
Term = [_|_], !,
|
||||
option_list_colours_2(Term, Elements).
|
||||
option_list_colours(_, error).
|
||||
|
||||
option_list_colours_2(Var, classify) :-
|
||||
var(Var).
|
||||
option_list_colours_2([], []).
|
||||
option_list_colours_2([H0|T0], [H|T]) :-
|
||||
option_colours(H0, H),
|
||||
option_list_colours_2(T0, T).
|
||||
|
||||
option_colours(Var, classify) :-
|
||||
var(Var), !.
|
||||
option_colours(_=_, built_in-[classify,classify]) :- !.
|
||||
option_colours(attribute_declarations(_), % DCG = is a hack!
|
||||
option(attribute_declarations)-[dcg]) :- !.
|
||||
option_colours(Term, option(Name)-[classify]) :-
|
||||
compound(Term),
|
||||
Term =.. [Name,_Value], !.
|
||||
option_colours(_, error).
|
||||
287
packages/http/http_path.pl
Normal file
287
packages/http/http_path.pl
Normal file
@ -0,0 +1,287 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2008, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_path,
|
||||
[ http_absolute_location/3 % +Spec, -Path, +Options
|
||||
]).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(apply)).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(library(settings)).
|
||||
:- use_module(library(broadcast)).
|
||||
:- use_module(library(url)).
|
||||
|
||||
|
||||
/** <module> Abstract specification of HTTP server locations
|
||||
|
||||
This module provides an abstract specification of HTTP server locations
|
||||
that is inspired on absolute_file_name/3. The specification is done by
|
||||
adding rules to the dynamic multifile predicate http:location/3. The
|
||||
speficiation is very similar to user:file_search_path/2, but takes an
|
||||
additional argument with options. Currently only one option is defined:
|
||||
|
||||
* priority(+Integer)
|
||||
If two rules match, take the one with highest priority. Using
|
||||
priorities is needed because we want to be able to overrule
|
||||
paths, but we do not want to become dependent on clause ordering.
|
||||
|
||||
The default priority is 0. Note however that notably libraries may
|
||||
decide to provide a fall-back using a negative priority. We suggest
|
||||
-100 for such cases.
|
||||
|
||||
This library predefines three locations at priority -100: The =icons=
|
||||
and =css= aliases are intended for images and css files and are backed
|
||||
up by file a file-search-path that allows finding the icons and css
|
||||
files that belong to the server infrastructure (e.g., http_dirindex/2).
|
||||
|
||||
* root
|
||||
The root of the server. Default is /, but this may be overruled
|
||||
the the setting (see setting/2) =|http:prefix|=
|
||||
|
||||
Here is an example that binds =|/login|= to login/1. The user can reuse
|
||||
this application while moving all locations using a new rule for the
|
||||
admin location with the option =|[priority(10)]|=.
|
||||
|
||||
==
|
||||
:- multifile http:location/3.
|
||||
:- dynamic http:location/3.
|
||||
|
||||
http:location(admin, /, []).
|
||||
|
||||
:- http_handler(admin(login), login, []).
|
||||
|
||||
login(Request) :-
|
||||
...
|
||||
==
|
||||
|
||||
@tbd Make this module replace the http:prefix option.
|
||||
@tbd Remove hard-wired support for prefix().
|
||||
*/
|
||||
|
||||
:- multifile
|
||||
http:location/3. % Alias, Expansion, Options
|
||||
:- dynamic
|
||||
http:location/3. % Alias, Expansion, Options
|
||||
|
||||
http:location(root, Root, [priority(-100)]) :-
|
||||
( catch(setting(http:prefix, Prefix), _, fail),
|
||||
Prefix \== ''
|
||||
-> Root = Prefix
|
||||
; Root = (/)
|
||||
).
|
||||
|
||||
|
||||
%% http_absolute_location(+Spec, -Path, +Options) is det.
|
||||
%
|
||||
% Path is the HTTP location for the abstract specification Spec.
|
||||
% Options:
|
||||
%
|
||||
% * relative_to(Base)
|
||||
% Path is made relative to Base. Default is to generate
|
||||
% absolute URLs.
|
||||
|
||||
:- dynamic
|
||||
location_cache/3.
|
||||
|
||||
http_absolute_location(Spec, Path, Options) :-
|
||||
must_be(ground, Spec),
|
||||
option(relative_to(Base), Options, /),
|
||||
absolute_location(Spec, Base, Path, Options),
|
||||
debug(http_path, '~q (~q) --> ~q', [Spec, Base, Path]).
|
||||
|
||||
absolute_location(Spec, Base, Path, _Options) :-
|
||||
location_cache(Spec, Base, Cache), !,
|
||||
Path = Cache.
|
||||
absolute_location(Spec, Base, Path, Options) :-
|
||||
expand_location(Spec, Base, L, Options),
|
||||
assert(location_cache(Spec, Base, L)),
|
||||
Path = L.
|
||||
|
||||
expand_location(Spec, Base, Path, _Options) :-
|
||||
atomic(Spec), !,
|
||||
relative_to(Base, Spec, Path).
|
||||
expand_location(Spec, _Base, Path, Options) :-
|
||||
Spec =.. [Alias, Sub],
|
||||
http_location_path(Alias, Parent),
|
||||
absolute_location(Parent, /, ParentLocation, Options),
|
||||
phrase(path_list(Sub), List),
|
||||
atomic_list_concat(List, /, SubAtom),
|
||||
( ParentLocation == ''
|
||||
-> Path = SubAtom
|
||||
; sub_atom(ParentLocation, _, _, 0, /)
|
||||
-> atom_concat(ParentLocation, SubAtom, Path)
|
||||
; atomic_list_concat([ParentLocation, SubAtom], /, Path)
|
||||
).
|
||||
|
||||
|
||||
%% http_location_path(+Alias, -Expansion) is det.
|
||||
%
|
||||
% Expansion is the expanded HTTP location for Alias. As we have no
|
||||
% condition search, we demand a single expansion for an alias. An
|
||||
% ambiguous alias results in a printed warning. A lacking alias
|
||||
% results in an exception.
|
||||
%
|
||||
% @error existence_error(http_alias, Alias)
|
||||
|
||||
http_location_path(Alias, Path) :-
|
||||
findall(P-L, http_location_path(Alias, L, P), Pairs),
|
||||
keysort(Pairs, Sorted0),
|
||||
reverse(Sorted0, Result),
|
||||
( Result = [_-One]
|
||||
-> Path = One
|
||||
; Result == []
|
||||
-> existence_error(http_location, Spec)
|
||||
; Result = [P-Best,P2-_|_],
|
||||
P \== P2
|
||||
-> Path = Best
|
||||
; Result = [_-First|_],
|
||||
pairs_values(Result, Paths),
|
||||
print_message(warning, http(ambiguous_location(Spec, Paths))),
|
||||
Path = First
|
||||
).
|
||||
|
||||
|
||||
%% http_location_path(+Alias, -Path, -Priority) is nondet.
|
||||
%
|
||||
% @tbd prefix(Path) is discouraged; use root(Path)
|
||||
|
||||
http_location_path(Alias, Path, Priority) :-
|
||||
http:location(Alias, Path, Options),
|
||||
option(priority(Priority), Options, 0).
|
||||
http_location_path(prefix, Path, 0) :-
|
||||
( catch(setting(http:prefix, Prefix), _, fail),
|
||||
Prefix \== ''
|
||||
-> ( sub_atom(Prefix, 0, _, _, /)
|
||||
-> Path = Prefix
|
||||
; atom_concat(/, Prefix, Path)
|
||||
)
|
||||
; Path = /
|
||||
).
|
||||
|
||||
|
||||
%% relative_to(+Base, +Path, -AbsPath) is det.
|
||||
%
|
||||
% AbsPath is an absolute URL location created from Base and Path.
|
||||
% The result is cleaned
|
||||
|
||||
relative_to(/, Path, Path) :- !.
|
||||
relative_to(_Base, Path, Path) :-
|
||||
sub_atom(Path, 0, _, _, /), !.
|
||||
relative_to(Base, Local, Path) :-
|
||||
sub_atom(Base, 0, _, _, /), !, % file version
|
||||
path_segments(Base, BaseSegments),
|
||||
append(BaseDir, [_], BaseSegments) ->
|
||||
path_segments(Local, LocalSegments),
|
||||
append(BaseDir, LocalSegments, Segments0),
|
||||
clean_segments(Segments0, Segments),
|
||||
path_segments(Path, Segments).
|
||||
relative_to(Base, Local, Global) :-
|
||||
global_url(Local, Base, Global).
|
||||
|
||||
path_segments(Path, Segments) :-
|
||||
atomic_list_concat(Segments, /, Path).
|
||||
|
||||
%% clean_segments(+SegmentsIn, -SegmentsOut) is det.
|
||||
%
|
||||
% Clean a path represented as a segment list, removing empty
|
||||
% segments and resolving .. based on syntax.
|
||||
|
||||
clean_segments([''|T0], [''|T]) :- !,
|
||||
exclude(empty_segment, T0, T1),
|
||||
clean_parent_segments(T1, T).
|
||||
clean_segments(T0, T) :-
|
||||
exclude(empty_segment, T0, T1),
|
||||
clean_parent_segments(T1, T).
|
||||
|
||||
clean_parent_segments([], []).
|
||||
clean_parent_segments([..|T0], T) :- !,
|
||||
clean_parent_segments(T0, T).
|
||||
clean_parent_segments([_,..|T0], T) :- !,
|
||||
clean_parent_segments(T0, T).
|
||||
clean_parent_segments([H|T0], [H|T]) :-
|
||||
clean_parent_segments(T0, T).
|
||||
|
||||
empty_segment('').
|
||||
empty_segment('.').
|
||||
|
||||
|
||||
%% path_list(+Spec, -List) is det.
|
||||
%
|
||||
% Translate seg1/seg2/... into [seg1,seg2,...].
|
||||
%
|
||||
% @error instantiation_error
|
||||
% @error type_error(atomic, X)
|
||||
|
||||
path_list(Var) -->
|
||||
{ var(Var), !,
|
||||
instantiation_error(Var)
|
||||
}.
|
||||
path_list(A/B) --> !,
|
||||
path_list(A),
|
||||
path_list(B).
|
||||
path_list(.) --> !,
|
||||
[].
|
||||
path_list(A) -->
|
||||
{ must_be(atomic, A) },
|
||||
[A].
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(http(ambiguous_location(Spec, Paths))) -->
|
||||
[ 'http_absolute_location/2: ambiguous specification: ~q: ~p'-[Spec, Paths]
|
||||
].
|
||||
|
||||
|
||||
/*******************************
|
||||
* CACHE CLEANUP *
|
||||
*******************************/
|
||||
|
||||
clean_location_cache :-
|
||||
retractall(location_cache(_,_,_)).
|
||||
|
||||
:- listen(settings(changed(http:prefix, _, _)),
|
||||
clean_location_cache).
|
||||
|
||||
:- multifile
|
||||
user:message_hook/3.
|
||||
:- dynamic
|
||||
user:message_hook/3.
|
||||
|
||||
user:message_hook(make(done(Reload)), _Level, _Lines) :-
|
||||
Reload \== [],
|
||||
clean_location_cache,
|
||||
fail.
|
||||
271
packages/http/http_pwp.pl
Normal file
271
packages/http/http_pwp.pl
Normal file
@ -0,0 +1,271 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2009, VU University, Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_pwp,
|
||||
[ reply_pwp_page/3, % :File, +Options, +Request
|
||||
pwp_handler/2 % +Options, +Request
|
||||
]).
|
||||
:- use_module(library(http/http_dispatch)).
|
||||
:- use_module(library(sgml)).
|
||||
:- use_module(library(sgml_write)).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(pwp)).
|
||||
|
||||
/** <module> Serve PWP pages through the HTTP server
|
||||
|
||||
This module provides convience predicates to include PWP (Prolog
|
||||
Well-formed Pages) in a Prolog web-server. It provides the following
|
||||
predicates:
|
||||
|
||||
* pwp_handler/2
|
||||
This is a complete web-server aimed at serving static pages, some
|
||||
of which include PWP. This API is intended to allow for programming
|
||||
the web-server from a hierarchy of pwp files, prolog files and static
|
||||
web-pages.
|
||||
|
||||
* reply_pwp_page/3
|
||||
Return a single PWP page that is executed in the context of the calling
|
||||
module. This API is intended for individual pages that include so much
|
||||
text that generating from Prolog is undesirable.
|
||||
|
||||
@tbd Support elements in the HTML header that allow controlling the
|
||||
page, such as setting the CGI-header, authorization, etc.
|
||||
@tbd Allow external styling. Pass through reply_html_page/2? Allow
|
||||
filtering the DOM before/after PWP?
|
||||
*/
|
||||
|
||||
%% pwp_handler(+Options, +Request)
|
||||
%
|
||||
% Handle PWP files. This predicate is defined to create a simple
|
||||
% HTTP server from a hierarchy of PWP, HTML and other files. The
|
||||
% interface is kept compatible with the
|
||||
% library(http/http_dispatch). In the typical usage scenario, one
|
||||
% needs to define an http location and a file-search path that is
|
||||
% used as the root of the server. E.g., the following declarations
|
||||
% create a self-contained web-server for files in =|/web/pwp/|=.
|
||||
%
|
||||
% ==
|
||||
% user:file_search_path(pwp, '/web/pwp').
|
||||
%
|
||||
% :- http_handler(root(.), pwp_handler([path_alias(pwp)]), [prefix]).
|
||||
% ==
|
||||
%
|
||||
% Options include:
|
||||
%
|
||||
% * path_alias(+Alias)
|
||||
% Search for PWP files as Alias(Path). See absolute_file_name/3.
|
||||
% * index(+Index)
|
||||
% Name of the directory index (pwp) file. This option may
|
||||
% appear multiple times. If no such option is provided,
|
||||
% pwp_handler/2 looks for =|index.pwp|=.
|
||||
% * view(+Boolean)
|
||||
% If =true= (default is =false=), allow for ?view=source to serve
|
||||
% PWP file as source.
|
||||
% * index_hook(:Hook)
|
||||
% If a directory has no index-file, pwp_handler/2 calls
|
||||
% Hook(PhysicalDir, Options, Request). If this semidet
|
||||
% predicate succeeds, the request is considered handled.
|
||||
% * hide_extensions(+List)
|
||||
% Hide files of the given extensions. The default is to
|
||||
% hide .pl files.
|
||||
%
|
||||
% @see reply_pwp_page/3
|
||||
% @error permission_error(index, http_location, Location) is
|
||||
% raised if the handler resolves to a directory that has no
|
||||
% index.
|
||||
|
||||
:- meta_predicate
|
||||
pwp_handler(:, +).
|
||||
|
||||
pwp_handler(QOptions, Request) :-
|
||||
meta_options(is_meta, QOptions, Options),
|
||||
( memberchk(path_info(Spec), Request)
|
||||
-> true
|
||||
; Spec = '.'
|
||||
),
|
||||
( option(path_alias(Alias), Options)
|
||||
-> Term =.. [Alias,Spec]
|
||||
; Term = Spec
|
||||
),
|
||||
http_safe_file(Term, Options),
|
||||
absolute_file_name(Term, Path, [access(read)]),
|
||||
( exists_directory(Path)
|
||||
-> ensure_slash(Path, Dir),
|
||||
( ( member(index(Index), Options)
|
||||
*-> true
|
||||
; Index = 'index.pwp'
|
||||
),
|
||||
atom_concat(Dir, Index, File),
|
||||
access_file(File, read)
|
||||
-> true
|
||||
; option(index_hook(Hook), Options),
|
||||
call(Hook, Path, Options, Request)
|
||||
-> true
|
||||
; memberchk(path(Location), Request),
|
||||
permission_error(index, http_location, Location)
|
||||
)
|
||||
; File = Path
|
||||
),
|
||||
server_file(File, Request, Options).
|
||||
|
||||
is_meta(index_hook).
|
||||
|
||||
server_file(File, _, _) :- % index-hook did the work
|
||||
var(File), !.
|
||||
server_file(File, Request, Options) :-
|
||||
file_name_extension(_, pwp, File), !,
|
||||
( option(view(true), Options),
|
||||
memberchk(search(Query), Request),
|
||||
memberchk(view=source, Query)
|
||||
-> http_reply_file(File, [ mime_type(text/plain),
|
||||
unsafe(true)
|
||||
], Request)
|
||||
; merge_options(Options,
|
||||
[ pwp_module(true)
|
||||
], Opts),
|
||||
reply_pwp_page(File, [unsafe(true)|Opts], Request)
|
||||
).
|
||||
server_file(File, Request, Options) :-
|
||||
option(hide_extensions(Exts), Options, [pl]),
|
||||
file_name_extension(_, Ext, File),
|
||||
( memberchk(Ext, Exts)
|
||||
-> memberchk(path(Location), Request),
|
||||
permission_error(read, http_location, Location)
|
||||
; http_reply_file(File, [unsafe(true)|Options], Request)
|
||||
).
|
||||
|
||||
|
||||
ensure_slash(Path, Dir) :-
|
||||
( sub_atom(Path, _, _, 0, /)
|
||||
-> Dir = Path
|
||||
; atom_concat(Path, /, Dir)
|
||||
).
|
||||
|
||||
|
||||
%% reply_pwp_page(:File, +Options, +Request)
|
||||
%
|
||||
% Reply a PWP file. This interface is provided to server
|
||||
% individual locations from PWP files. Using a PWP file rather
|
||||
% than generating the page from Prolog may be desirable because
|
||||
% the page contains a lot of text (which is cumbersome to generate
|
||||
% from Prolog) or because the maintainer is not familiar with
|
||||
% Prolog.
|
||||
%
|
||||
% Options supported are:
|
||||
%
|
||||
% * mime_type(+Type)
|
||||
% Serve the file using the given mime-type. Default is
|
||||
% text/html.
|
||||
% * unsafe(+Boolean)
|
||||
% Passed to http_safe_file/2 to check for unsafe paths.
|
||||
% * pwp_module(+Boolean)
|
||||
% If =true=, (default =false=), process the PWP file in
|
||||
% a module constructed from its canonical absolute path.
|
||||
% Otherwise, the PWP file is processed in the calling
|
||||
% module.
|
||||
%
|
||||
% Initial context:
|
||||
%
|
||||
% * SCRIPT_NAME
|
||||
% Virtual path of the script.
|
||||
% * SCRIPT_DIRECTORY
|
||||
% Physical directory where the script lives
|
||||
% * QUERY
|
||||
% Var=Value list representing the query-parameters
|
||||
% * REMOTE_USER
|
||||
% If access has been authenticated, this is the authenticated
|
||||
% user.
|
||||
% * REQUEST_METHOD
|
||||
% One of =get=, =post=, =put= or =head=
|
||||
% * CONTENT_TYPE
|
||||
% Content-type provided with HTTP POST and PUT requests
|
||||
% * CONTENT_LENGTH
|
||||
% Content-length provided with HTTP POST and PUT requests
|
||||
%
|
||||
% While processing the script, the file-search-path pwp includes
|
||||
% the current location of the script. I.e., the following will
|
||||
% find myprolog in the same directory as where the PWP file
|
||||
% resides.
|
||||
%
|
||||
% ==
|
||||
% pwp:ask="ensure_loaded(pwp(myprolog))"
|
||||
% ==
|
||||
%
|
||||
% @tbd complete the initial context, as far as possible from CGI
|
||||
% variables. See http://hoohoo.ncsa.illinois.edu/docs/cgi/env.html
|
||||
% @see pwp_handler/2.
|
||||
|
||||
:- meta_predicate
|
||||
reply_pwp_page(:, +, +).
|
||||
|
||||
reply_pwp_page(M:File, Options, Request) :-
|
||||
http_safe_file(File, Options),
|
||||
absolute_file_name(File, Path,
|
||||
[ access(read)
|
||||
]),
|
||||
memberchk(method(Method), Request),
|
||||
file_directory_name(Path, Dir),
|
||||
load_xml_file(Path, Contents),
|
||||
findall(C, pwp_context(Request, C), Context),
|
||||
( option(pwp_module(true), Options)
|
||||
-> PWP_M = Path
|
||||
; PWP_M = M
|
||||
),
|
||||
setup_call_cleanup(asserta(script_dir(Dir), Ref),
|
||||
pwp_xml(PWP_M:Contents, Transformed,
|
||||
[ 'REQUEST_METHOD' = Method,
|
||||
'SCRIPT_DIRECTORY' = Dir
|
||||
| Context
|
||||
]),
|
||||
erase(Ref)),
|
||||
option(mime_type(Type), Options, text/html),
|
||||
format('Content-type: ~w~n~n', [Type]),
|
||||
xml_write(current_output, Transformed, []).
|
||||
|
||||
pwp_context(Request, 'REMOTE_USER' = User) :-
|
||||
memberchk(user(User), Request).
|
||||
pwp_context(Request, 'QUERY' = Query) :-
|
||||
memberchk(search(Query), Request).
|
||||
pwp_context(Request, 'SCRIPT_NAME' = Path) :-
|
||||
memberchk(path(Path), Request).
|
||||
pwp_context(Request, 'CONTENT_TYPE' = ContentType) :-
|
||||
memberchk(content_type(ContentType), Request).
|
||||
pwp_context(Request, 'CONTENT_LENGTH' = Length) :-
|
||||
memberchk(content_length(Length), Request).
|
||||
|
||||
:- multifile user:file_search_path/2.
|
||||
:- dynamic user:file_search_path/2.
|
||||
:- thread_local script_dir/1.
|
||||
|
||||
user:file_search_path(pwp, ScriptDir) :-
|
||||
script_dir(ScriptDir).
|
||||
|
||||
|
||||
90
packages/http/http_server_files.pl
Normal file
90
packages/http/http_server_files.pl
Normal file
@ -0,0 +1,90 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2009, VU University, Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_server_files,
|
||||
[ serve_files_in_directory/2 % +Alias, +HTTPRequest
|
||||
]).
|
||||
:- use_module(library(http/http_path)).
|
||||
:- use_module(library(http/http_dispatch)).
|
||||
|
||||
/** <module> Serve files needed by modules from the server
|
||||
|
||||
This module provides an infrastructure for serving resource-files such
|
||||
as icons, JavaScript, CSS files, etc. The default configuration serves
|
||||
the HTTP locations =icons=, =css= and =js= (see
|
||||
http_absolute_location/3)
|
||||
|
||||
The location for these services can be changed by adding rules for
|
||||
http:location/3. Directories providing additional or alternative
|
||||
resources can be achieved by adding rules for user:file_search_path/2.
|
||||
*/
|
||||
|
||||
:- multifile
|
||||
http:location/3. % Alias, Expansion, Options
|
||||
:- dynamic
|
||||
http:location/3. % Alias, Expansion, Options
|
||||
|
||||
http:location(icons, root(icons), [ priority(-100) ]).
|
||||
http:location(css, root(css), [ priority(-100) ]).
|
||||
http:location(js, root(js), [ priority(-100) ]).
|
||||
|
||||
:- multifile
|
||||
user:file_search_path/2.
|
||||
:- dynamic
|
||||
user:file_search_path/2.
|
||||
|
||||
user:file_search_path(icons, library('http/web/icons')).
|
||||
user:file_search_path(css, library('http/web/css')).
|
||||
user:file_search_path(js, library('http/web/js')).
|
||||
|
||||
:- http_handler(icons(.), serve_files_in_directory(icons), [prefix]).
|
||||
:- http_handler(css(.), serve_files_in_directory(css), [prefix]).
|
||||
:- http_handler(js(.), serve_files_in_directory(js), [prefix]).
|
||||
|
||||
%% serve_files_in_directory(+Alias, +Request)
|
||||
%
|
||||
% Serve files from the directory Alias from the path-info from
|
||||
% Request. This predicate is used together with
|
||||
% file_search_path/2. Note that multiple clauses for the same
|
||||
% file_search_path alias can be used to merge files from different
|
||||
% physical locations onto the same HTTP directory. Note that the
|
||||
% handler must be declared as =prefix=. Here is an example:
|
||||
%
|
||||
% ==
|
||||
% user:file_search_path(icons, library('http/web/icons')).
|
||||
%
|
||||
% :- http_handler(icons(.), serve_files_in_directory(icons), [prefix]).
|
||||
% ==
|
||||
%
|
||||
% @see http_reply_file/3
|
||||
|
||||
serve_files_in_directory(Alias, Request) :-
|
||||
memberchk(path_info(PathInfo), Request),
|
||||
Term =.. [Alias,PathInfo],
|
||||
http_reply_file(Term, [], Request).
|
||||
512
packages/http/http_session.pl
Normal file
512
packages/http/http_session.pl
Normal file
@ -0,0 +1,512 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2006, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
|
||||
:- module(http_session,
|
||||
[ http_set_session_options/1, % +Options
|
||||
|
||||
http_session_id/1, % -SessionId
|
||||
http_in_session/1, % -SessionId
|
||||
http_current_session/2, % ?SessionId, ?Data
|
||||
http_close_session/1, % +SessionId
|
||||
|
||||
http_session_asserta/1, % +Data
|
||||
http_session_assert/1, % +Data
|
||||
http_session_retract/1, % ?Data
|
||||
http_session_retractall/1, % +Data
|
||||
http_session_data/1 % ?Data
|
||||
]).
|
||||
:- use_module(http_wrapper).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(socket)).
|
||||
:- use_module(library(broadcast)).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
/** <module> HTTP Session management
|
||||
|
||||
This library defines session management based on HTTP cookies. Session
|
||||
management is enabled simply by loading this module. Details can be
|
||||
modified using http_set_session_options/1. If sessions are enabled,
|
||||
http_session_id/1 produces the current session and http_session_assert/1
|
||||
and friends maintain data about the session. If the session is
|
||||
reclaimed, all associated data is reclaimed too.
|
||||
|
||||
Begin and end of sessions can be monitored using library(broadcast). The
|
||||
broadcasted messages are:
|
||||
|
||||
* http_session(begin(SessionID, Peer))
|
||||
Broadcasted if a session is started
|
||||
* http_session(end(SessionId, Peer))
|
||||
Broadcasted if a session is ended. See http_close_session/1.
|
||||
|
||||
For example, the following calls end_session(SessionId) whenever a
|
||||
session terminates. Please note that sessions ends are not scheduled to
|
||||
happen at the actual timeout moment of the session. Instead, creating a
|
||||
new session scans the active list for timed-out sessions. This may
|
||||
change in future versions of this library.
|
||||
|
||||
==
|
||||
:- listen(http_session(end(SessionId, Peer)),
|
||||
end_session(SessionId)).
|
||||
==
|
||||
*/
|
||||
|
||||
:- dynamic
|
||||
session_setting/1, % Name(Value)
|
||||
current_session/2, % SessionId, Peer
|
||||
last_used/2, % SessionId, Time
|
||||
session_data/2. % SessionId, Data
|
||||
|
||||
session_setting(timeout(600)). % timeout in seconds
|
||||
session_setting(cookie('swipl_session')).
|
||||
session_setting(path(/)).
|
||||
session_setting(enabled(true)).
|
||||
|
||||
session_option(timeout, integer).
|
||||
session_option(cookie, atom).
|
||||
session_option(path, atom).
|
||||
session_option(route, atom).
|
||||
session_option(enabled, boolean).
|
||||
|
||||
%% http_set_session_options(+Options) is det.
|
||||
%
|
||||
% Set options for the session library. Provided options are:
|
||||
%
|
||||
% * timeout(+Seconds)
|
||||
% Session timeout in seconds. Default is 600 (10 min).
|
||||
%
|
||||
% * cookie(+Cookiekname)
|
||||
% Name to use for the cookie to identify the session.
|
||||
% Default =swipl_session=.
|
||||
%
|
||||
% * path(+Path)
|
||||
% Path to which the cookie is associated. Default is
|
||||
% =|/|=. Cookies are only sent if the HTTP request path
|
||||
% is a refinement of Path.
|
||||
%
|
||||
% * route(+Route)
|
||||
% Set the route name. Default is the unqualified
|
||||
% hostname. To cancel adding a route, use the empty
|
||||
% atom. See route/1.
|
||||
%
|
||||
% * enabled(+Boolean)
|
||||
% Enable/disable session management. Sesion management
|
||||
% is enabled by default after loading this file.
|
||||
|
||||
http_set_session_options([]).
|
||||
http_set_session_options([H|T]) :-
|
||||
http_session_option(H),
|
||||
http_set_session_options(T).
|
||||
|
||||
http_session_option(Option) :-
|
||||
functor(Option, Name, Arity),
|
||||
arg(1, Option, Value),
|
||||
( session_option(Name, Type)
|
||||
-> must_be(Type, Value)
|
||||
; domain_error(http_session_option, Option)
|
||||
),
|
||||
functor(Free, Name, Arity),
|
||||
retractall(session_setting(Free)),
|
||||
assert(session_setting(Option)).
|
||||
|
||||
%% http_session_id(-SessionId) is det.
|
||||
%
|
||||
% True if SessionId is an identifier for the current session.
|
||||
%
|
||||
% @param SessionId is an atom.
|
||||
% @error existence_error(http_session, _)
|
||||
% @see http_in_session/1 for a version that fails if there is
|
||||
% no session.
|
||||
|
||||
http_session_id(SessionID) :-
|
||||
( http_in_session(ID)
|
||||
-> SessionID = ID
|
||||
; throw(error(existence_error(http_session, _), _))
|
||||
).
|
||||
|
||||
%% http_in_session(-SessionId) is semidet.
|
||||
%
|
||||
% True if SessionId is an identifier for the current session. The
|
||||
% current session is extracted from session(ID) from the current
|
||||
% HTTP request (see http_current_request/1). The value is cached
|
||||
% in a backtrackable global variable =http_session_id=. Using a
|
||||
% backtrackable global variable is safe because continuous worker
|
||||
% threads use a failure driven look and spawned threads start
|
||||
% without any global variables. This variable can be set from the
|
||||
% commandline to fake running a goal from the commandline in the
|
||||
% context of a session.
|
||||
%
|
||||
% @see http_session_id/1
|
||||
|
||||
http_in_session(SessionID) :-
|
||||
( nb_current(http_session_id, ID),
|
||||
ID \== []
|
||||
-> true
|
||||
; http_current_request(Request),
|
||||
memberchk(session(ID), Request),
|
||||
b_setval(http_session_id, ID)
|
||||
; b_setval(http_session_id, no_session),
|
||||
fail
|
||||
),
|
||||
ID \== no_session,
|
||||
SessionID = ID.
|
||||
|
||||
%% http_session(+RequestIn, -RequestOut, -SessionID) is semidet.
|
||||
%
|
||||
% Maintain the notion of a session using a client-side cookie.
|
||||
% This must be called first when handling a request that wishes to
|
||||
% do session management, after which the possibly modified request
|
||||
% must be used for further processing.
|
||||
|
||||
http_session(Request, Request, SessionID) :-
|
||||
memberchk(session(SessionID0), Request), !,
|
||||
SessionID = SessionID0.
|
||||
http_session(Request0, Request, SessionID) :-
|
||||
memberchk(cookie(Cookies), Request0),
|
||||
session_setting(cookie(Cookie)),
|
||||
memberchk(Cookie=SessionID0, Cookies),
|
||||
peer(Request0, Peer),
|
||||
valid_session_id(SessionID0, Peer), !,
|
||||
SessionID = SessionID0,
|
||||
Request = [session(SessionID)|Request0],
|
||||
b_setval(http_session_id, SessionID).
|
||||
http_session(Request0, Request, SessionID) :-
|
||||
session_setting(path(Path)),
|
||||
memberchk(path(ReqPath), Request0),
|
||||
sub_atom(ReqPath, 0, _, _, Path), !,
|
||||
http_gc_sessions, % GC dead sessions
|
||||
gen_cookie(SessionID),
|
||||
session_setting(cookie(Cookie)),
|
||||
format('Set-Cookie: ~w=~w; path=~w~n', [Cookie, SessionID, Path]),
|
||||
Request = [session(SessionID)|Request0],
|
||||
peer(Request0, Peer),
|
||||
open_session(SessionID, Peer),
|
||||
b_setval(http_session_id, SessionID).
|
||||
|
||||
:- multifile
|
||||
http:request_expansion/2.
|
||||
|
||||
http:request_expansion(Request0, Request) :-
|
||||
session_setting(enabled(true)),
|
||||
http_session(Request0, Request, _SessionID).
|
||||
|
||||
%% peer(+Request, -Peer)
|
||||
%
|
||||
% Find peer for current request. If unknown we leave it unbound.
|
||||
% Alternatively we should treat this as an error.
|
||||
|
||||
peer(Request, Peer) :-
|
||||
( memberchk(peer(Peer), Request)
|
||||
-> true
|
||||
; true
|
||||
).
|
||||
|
||||
%% open_session(+SessionID, +Peer)
|
||||
%
|
||||
% Open a new session. Uses broadcast/1 with the term
|
||||
% http_session(begin(SessionID, Peer)).
|
||||
|
||||
open_session(SessionID, Peer) :-
|
||||
get_time(Now),
|
||||
assert(current_session(SessionID, Peer)),
|
||||
assert(last_used(SessionID, Now)),
|
||||
broadcast(http_session(begin(SessionID, Peer))).
|
||||
|
||||
|
||||
%% valid_session_id(+SessionID, +Peer)
|
||||
%
|
||||
% Check if this sessionID is known. If so, check the idle time and
|
||||
% update the last_used for this session.
|
||||
|
||||
valid_session_id(SessionID, Peer) :-
|
||||
current_session(SessionID, SessionPeer),
|
||||
get_time(Now),
|
||||
( session_setting(timeout(Timeout)),
|
||||
Timeout > 0
|
||||
-> get_last_used(SessionID, Last),
|
||||
Idle is Now - Last,
|
||||
( Idle =< Timeout
|
||||
-> true
|
||||
; http_close_session(SessionID),
|
||||
fail
|
||||
)
|
||||
; Peer \== SessionPeer
|
||||
-> http_close_session(SessionID),
|
||||
fail
|
||||
; true
|
||||
),
|
||||
set_last_used(SessionID, Now).
|
||||
|
||||
get_last_used(SessionID, Last) :-
|
||||
atom(SessionID), !,
|
||||
with_mutex(http_session, last_used(SessionID, Last)).
|
||||
get_last_used(SessionID, Last) :-
|
||||
with_mutex(http_session,
|
||||
findall(SessionID-Last,
|
||||
last_used(SessionID, Last),
|
||||
Pairs)),
|
||||
member(SessionID-Last, Pairs).
|
||||
|
||||
set_last_used(SessionID, Now) :-
|
||||
with_mutex(http_session,
|
||||
( retractall(last_used(SessionID, _)),
|
||||
assert(last_used(SessionID, Now)))).
|
||||
|
||||
|
||||
|
||||
/*******************************
|
||||
* SESSION DATA *
|
||||
*******************************/
|
||||
|
||||
%% http_session_asserta(+Data) is det.
|
||||
%% http_session_assert(+Data) is det.
|
||||
%% http_session_retract(?Data) is nondet.
|
||||
%% http_session_retractall(?Data) is det.
|
||||
%
|
||||
% Versions of assert/1, retract/1 and retractall/1 that associate
|
||||
% data with the current HTTP session.
|
||||
|
||||
http_session_asserta(Data) :-
|
||||
http_session_id(SessionId),
|
||||
asserta(session_data(SessionId, Data)).
|
||||
|
||||
http_session_assert(Data) :-
|
||||
http_session_id(SessionId),
|
||||
assert(session_data(SessionId, Data)).
|
||||
|
||||
http_session_retract(Data) :-
|
||||
http_session_id(SessionId),
|
||||
retract(session_data(SessionId, Data)).
|
||||
|
||||
http_session_retractall(Data) :-
|
||||
http_session_id(SessionId),
|
||||
retractall(session_data(SessionId, Data)).
|
||||
|
||||
% http_session_data(?Data) is nondet.
|
||||
%
|
||||
% True if Data is associated using http_session_assert/1 to the
|
||||
% current HTTP session.
|
||||
|
||||
http_session_data(Data) :-
|
||||
http_session_id(SessionId),
|
||||
session_data(SessionId, Data).
|
||||
|
||||
|
||||
/*******************************
|
||||
* ENUMERATE *
|
||||
*******************************/
|
||||
|
||||
%% http_current_session(?SessionID, ?Data) is nondet.
|
||||
%
|
||||
% Enumerate the current sessions and associated data. There are
|
||||
% two _Pseudo_ data elements:
|
||||
%
|
||||
% * idle(Seconds)
|
||||
% Session has been idle for Seconds.
|
||||
%
|
||||
% * peer(Peer)
|
||||
% Peer of the connection.
|
||||
|
||||
http_current_session(SessionID, Data) :-
|
||||
get_time(Now),
|
||||
get_last_used(SessionID, Last),
|
||||
Idle is Now - Last,
|
||||
( session_setting(timeout(Timeout)),
|
||||
Timeout > 0
|
||||
-> Idle =< Timeout
|
||||
; true
|
||||
),
|
||||
( Data = idle(Idle)
|
||||
; Data = peer(Peer),
|
||||
current_session(SessionID, Peer)
|
||||
; session_data(SessionID, Data)
|
||||
).
|
||||
|
||||
|
||||
/*******************************
|
||||
* GC SESSIONS *
|
||||
*******************************/
|
||||
|
||||
%% http_close_session(+SessionID) is det.
|
||||
%
|
||||
% Closes an HTTP session. This predicate can be called from any
|
||||
% thread to terminate a session. It uses the broadcast/1 service
|
||||
% with the message below.
|
||||
%
|
||||
% http_session(end(SessionId, Peer))
|
||||
%
|
||||
% The broadcast is done *before* the session data is destroyed and
|
||||
% the listen-handlers are executed in context of the session that
|
||||
% is being closed. Here is an example that destroys a Prolog
|
||||
% thread that is associated to a thread:
|
||||
%
|
||||
% ==
|
||||
% :- listen(http_session(end(SessionId, _Peer)),
|
||||
% kill_session_thread(SessionID)).
|
||||
%
|
||||
% kill_session_thread(SessionID) :-
|
||||
% http_session_data(thread(ThreadID)),
|
||||
% thread_signal(ThreadID, throw(session_closed)).
|
||||
% ==
|
||||
%
|
||||
% Succeed without any effect if SessionID does not refer to an
|
||||
% active session.
|
||||
%
|
||||
% @error type_error(atom, SessionID)
|
||||
% @see listen/2 for acting upon closed sessions
|
||||
|
||||
http_close_session(SessionId) :-
|
||||
must_be(atom, SessionId),
|
||||
( current_session(SessionId, Peer),
|
||||
( b_setval(http_session_id, SessionId),
|
||||
broadcast(http_session(end(SessionId, Peer))),
|
||||
fail
|
||||
; true
|
||||
),
|
||||
retractall(current_session(SessionId, _)),
|
||||
retractall(last_used(SessionId, _)),
|
||||
retractall(session_data(SessionId, _)),
|
||||
fail
|
||||
; true
|
||||
).
|
||||
|
||||
% http_gc_sessions/0
|
||||
%
|
||||
% Delete dead sessions. When should we be calling this? This
|
||||
% assumes that updated sessions are at the end of the clause list,
|
||||
% so we can break as soon as we encounter a no-yet-timedout
|
||||
% session.
|
||||
|
||||
http_gc_sessions :-
|
||||
session_setting(timeout(Timeout)),
|
||||
Timeout > 0, !,
|
||||
get_time(Now),
|
||||
( last_used(SessionID, Last),
|
||||
Idle is Now - Last,
|
||||
( Idle > Timeout
|
||||
-> http_close_session(SessionID),
|
||||
fail
|
||||
; !
|
||||
)
|
||||
; true
|
||||
).
|
||||
http_gc_sessions.
|
||||
|
||||
|
||||
/*******************************
|
||||
* UTIL *
|
||||
*******************************/
|
||||
|
||||
%% gen_cookie(-Cookie) is det.
|
||||
%
|
||||
% Generate a random cookie that can be used by a browser to
|
||||
% identify the current session. The cookie has the format
|
||||
% XXXX-XXXX-XXXX-XXXX[.<route>], where XXXX are random hexadecimal
|
||||
% numbers and [.<route>] is the optionally added routing
|
||||
% information.
|
||||
|
||||
gen_cookie(Cookie) :-
|
||||
route(Route), !,
|
||||
random_4(R1,R2,R3,R4),
|
||||
format(atom(Cookie),
|
||||
'~`0t~16r~4|-~`0t~16r~9|-~`0t~16r~14|-~`0t~16r~19|.~w',
|
||||
[R1,R2,R3,R4,Route]).
|
||||
gen_cookie(Cookie) :-
|
||||
random_4(R1,R2,R3,R4),
|
||||
format(atom(Cookie),
|
||||
'~`0t~16r~4|-~`0t~16r~9|-~`0t~16r~14|-~`0t~16r~19|',
|
||||
[R1,R2,R3,R4]).
|
||||
|
||||
:- thread_local
|
||||
route_cache/1.
|
||||
|
||||
%% route(-RouteID) is semidet.
|
||||
%
|
||||
% Fetch the route identifier. This value is added as .<route> to
|
||||
% the session cookie and used by -for example- the apache load
|
||||
% balanching module. The default route is the local name of the
|
||||
% host. Alternatives may be provided using
|
||||
% http_set_session_options/1.
|
||||
|
||||
route(Route) :-
|
||||
route_cache(Route), !,
|
||||
Route \== ''.
|
||||
route(Route) :-
|
||||
route_no_cache(Route),
|
||||
assert(route_cache(Route)),
|
||||
Route \== ''.
|
||||
|
||||
route_no_cache(Route) :-
|
||||
session_setting(route(Route)), !.
|
||||
route_no_cache(Route) :-
|
||||
gethostname(Host),
|
||||
( sub_atom(Host, Before, _, _, '.')
|
||||
-> sub_atom(Host, 0, Before, _, Route)
|
||||
; Route = Host
|
||||
).
|
||||
|
||||
|
||||
%% random_4(-R1,-R2,-R3,-R4) is det.
|
||||
%
|
||||
% Generate 4 2-byte random numbers. Uses =|/dev/urandom|= when
|
||||
% available to make prediction of the session IDs hard.
|
||||
|
||||
random_4(R1,R2,R3,R4) :-
|
||||
urandom(In), !,
|
||||
get_pair(In, R1),
|
||||
get_pair(In, R2),
|
||||
get_pair(In, R3),
|
||||
get_pair(In, R4).
|
||||
random_4(R1,R2,R3,R4) :-
|
||||
R1 is random(65536),
|
||||
R2 is random(65536),
|
||||
R3 is random(65536),
|
||||
R4 is random(65536).
|
||||
|
||||
:- dynamic
|
||||
urandom_handle/1.
|
||||
|
||||
urandom(Handle) :-
|
||||
urandom_handle(Handle), !,
|
||||
Handle \== [].
|
||||
urandom(Handle) :-
|
||||
catch(open('/dev/urandom', read, In, [type(binary)]), _, fail), !,
|
||||
assert(urandom_handle(In)),
|
||||
Handle = In.
|
||||
urandom(_) :-
|
||||
assert(urandom_handle([])),
|
||||
fail.
|
||||
|
||||
get_pair(In, Value) :-
|
||||
get_byte(In, B1),
|
||||
get_byte(In, B2),
|
||||
Value is B1<<8+B2.
|
||||
128
packages/http/http_sgml_plugin.pl
Normal file
128
packages/http/http_sgml_plugin.pl
Normal file
@ -0,0 +1,128 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2010, University of Amsterdam, VU University Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_sgml_plugin, []).
|
||||
:- use_module(http_client).
|
||||
:- use_module(library(memfile)).
|
||||
:- use_module(library(sgml)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(debug)).
|
||||
|
||||
:- multifile
|
||||
http_client:http_convert_data/4.
|
||||
|
||||
:- multifile
|
||||
markup_type/2. % +MimeType, -ParseOptions
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
This module provides a plugin for the HTTP client to handle xml, html
|
||||
and sgml files using the SWI-Prolog sgml-parser from library(sgml).
|
||||
Using this library avoids unnecessary copying of data as the sgml-parser
|
||||
reads directly from the stream that established the HTTP connection.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
http_client:http_convert_data(In, Fields, Data, Options) :-
|
||||
memberchk(content_type(Type), Fields),
|
||||
debug(sgml_plugin, 'Content type: ~w', [Type]),
|
||||
( markup_type(Type, ParseOptions)
|
||||
-> true
|
||||
; type_major_props(Type, Major, Props),
|
||||
default_markup_type(Major, ParseOptions0),
|
||||
type_props(Props, ParseOptions0, ParseOptions)
|
||||
),
|
||||
merge_options([ max_errors(-1),
|
||||
syntax_errors(quiet)
|
||||
| ParseOptions
|
||||
], Options, Merged),
|
||||
markup_options(Fields, Merged, MarkupOptions),
|
||||
debug(sgml_plugin, 'Markup options: ~p', [MarkupOptions]),
|
||||
load_structure(stream(In), Data, MarkupOptions).
|
||||
|
||||
|
||||
type_major_props(Type0, Type, Props) :-
|
||||
sub_atom(Type0, B, _, A, ;), !,
|
||||
sub_atom(Type0, 0, B, _, Major),
|
||||
sub_atom(Type0, _, A, 0, Props),
|
||||
normalize_space(atom(Type), Major).
|
||||
type_major_props(Type, Type, '').
|
||||
|
||||
type_props('', L, L).
|
||||
type_props(Props, L0, L) :-
|
||||
sub_atom(Props, _, _, A, 'charset='),
|
||||
sub_atom(Props, _, A, 0, CharSet0),
|
||||
downcase_atom(CharSet0, CharSet),
|
||||
known_charset(CharSet),
|
||||
L = [encoding(CharSet)|L0].
|
||||
type_props(_, L, L).
|
||||
|
||||
known_charset('iso-8859-1').
|
||||
known_charset('us-ascii').
|
||||
known_charset('utf-8').
|
||||
|
||||
|
||||
%% default_markup_type(+MimeType, -ParseOptions)
|
||||
%
|
||||
% State that the HTTP contents should be parsed with
|
||||
% load_structure/3 using the returned options. This predicate may
|
||||
% be hooked using the multifile predicate markup_type/2.
|
||||
|
||||
default_markup_type('text/xml',
|
||||
[ dialect(xmlns)
|
||||
]).
|
||||
default_markup_type('text/html',
|
||||
[ dtd(DTD),
|
||||
dialect(sgml),
|
||||
shorttag(false)
|
||||
]) :-
|
||||
dtd(html, DTD).
|
||||
default_markup_type('text/x-sgml',
|
||||
[ dialect(sgml)
|
||||
]).
|
||||
|
||||
markup_options(Fields, Opt0, Options) :-
|
||||
( memberchk(content_length(Bytes), Fields)
|
||||
-> Options = [content_length(Bytes)|Opt0]
|
||||
; Options = Opt0
|
||||
).
|
||||
|
||||
%% merge_options(+Defaults, +GivenOptions, -Options)
|
||||
%
|
||||
% If an option is not in GivenOptions, use the one from
|
||||
% Defaults.
|
||||
|
||||
merge_options([], Options, Options).
|
||||
merge_options([H|T], Options0, Options) :-
|
||||
functor(H, Name, Arity),
|
||||
functor(H0, Name, Arity),
|
||||
memberchk(H0, Options0), !,
|
||||
merge_options(T, Options0, Options).
|
||||
merge_options([H|T], Options0, Options) :-
|
||||
merge_options(T, [H|Options0], Options).
|
||||
36
packages/http/http_stream.c
Normal file
36
packages/http/http_stream.c
Normal file
@ -0,0 +1,36 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2007, University of Amsterdam
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
This library is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
*/
|
||||
|
||||
#include "http_error.c"
|
||||
#include "http_chunked.c"
|
||||
#include "cgi_stream.c"
|
||||
#include "stream_range.c"
|
||||
|
||||
install_t
|
||||
install_http_stream()
|
||||
{ init_errors();
|
||||
install_http_chunked();
|
||||
install_cgi_stream();
|
||||
install_stream_range();
|
||||
}
|
||||
250
packages/http/http_stream.pl
Normal file
250
packages/http/http_stream.pl
Normal file
@ -0,0 +1,250 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2007, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_stream,
|
||||
[ http_chunked_open/3, % +Stream, -DataStream, +Options
|
||||
stream_range_open/3, % +Stream, -DataStream, +Options
|
||||
% CGI Stream interaction
|
||||
cgi_open/4, % +Stream, -DataStream, :Hook, +Options
|
||||
cgi_property/2, % +Stream, -Property
|
||||
cgi_set/2, % +Stream, -Property
|
||||
cgi_discard/1, % +Stream
|
||||
is_cgi_stream/1 % +Stream
|
||||
]).
|
||||
|
||||
:- expects_dialect(swi).
|
||||
:- assert(system:swi_io).
|
||||
|
||||
:- use_module(library(shlib)).
|
||||
|
||||
:- use_foreign_library(foreign(http_stream)).
|
||||
|
||||
/** <module> HTTP Streams
|
||||
|
||||
This module realises encoding and decoding filters, implemented as
|
||||
Prolog streams that read/write to an underlying stream. This allows for
|
||||
sequences of streams acting as an in-process pipeline.
|
||||
|
||||
The predicate http_chunked_open/3 realises encoding and decoding of the
|
||||
HTTP _Chunked_ encoding. This encoding is an obligatory part of the HTTP
|
||||
1.1 specification. Messages are split into chunks, each preceeded by the
|
||||
length of the chunk. Chunked encoding allows sending messages over a
|
||||
serial link (typically a TCP/IP stream) for which the reader knows when
|
||||
the message is ended. Unlike standard HTTP though, the sender does not
|
||||
need to know the message length in advance. The protocol allows for
|
||||
sending short chunks. This is supported totally transparent using a
|
||||
flush on the output stream.
|
||||
|
||||
The predicate stream_range_open/3 handles the Content-length on an input
|
||||
stream for handlers that are designed to process an entire file. The
|
||||
filtering stream claims end-of-file after reading a specified number of
|
||||
bytes, dispite the fact that the underlying stream may be longer.
|
||||
|
||||
@see The HTTP 1.1 protocol http://www.w3.org/Protocols/rfc2616/rfc2616.html
|
||||
@author Jan Wielemaker
|
||||
*/
|
||||
|
||||
%% http_chunked_open(+RawStream, -DataStream, +Options) is det.
|
||||
%
|
||||
% Create a stream to realise HTTP chunked encoding or decoding.
|
||||
% The technique is similar to library(zlib), using a Prolog stream
|
||||
% as a filter on another stream. Options:
|
||||
%
|
||||
% * close_parent(+Bool)
|
||||
% If =true= (default =false=), the parent stream is closed
|
||||
% if DataStream is closed.
|
||||
%
|
||||
% * max_chunk_size(+PosInt)
|
||||
% Define the maximum size of a chunk. Default is the
|
||||
% default buffer size of fully buffered streams (4096).
|
||||
% Larger values may improve throughput. It is also
|
||||
% allowed to use =|set_stream(DataStream, buffer(line))|=
|
||||
% on the data stream to get line-buffered output. See
|
||||
% set_stream/2 for details. Switching buffering to =false=
|
||||
% is supported.
|
||||
%
|
||||
% Here is example code to write a chunked data to a stream
|
||||
%
|
||||
% ==
|
||||
% http_chunked_open(Out, S, []),
|
||||
% format(S, 'Hello world~n', []),
|
||||
% close(S).
|
||||
% ==
|
||||
%
|
||||
% If a stream is known to contain chunked data, we can extract
|
||||
% this data using
|
||||
%
|
||||
% ==
|
||||
% http_chunked_open(In, S, []),
|
||||
% read_stream_to_codes(S, Codes),
|
||||
% close(S).
|
||||
% ==
|
||||
%
|
||||
% The current implementation does not generate chunked extensions
|
||||
% or an HTTP trailer. If such extensions appear on the input they
|
||||
% are silently ignored. This is compatible with the HTTP 1.1
|
||||
% specifications. Although a filtering stream is an excellent
|
||||
% mechanism for encoding and decoding the core chunked protocol,
|
||||
% it does not well support out-of-band data.
|
||||
%
|
||||
% After http_chunked_open/3, the encoding of DataStream is the
|
||||
% same as the encoding of RawStream, while the encoding of
|
||||
% RawStream is =octet=, the only value allowed for HTTP chunked
|
||||
% streams. Closing the DataStream restores the old encoding on
|
||||
% RawStream.
|
||||
%
|
||||
% @error io_error(read, Stream) where the message context provides
|
||||
% an indication of the problem. This error is raised if
|
||||
% the input is not valid HTTP chunked data.
|
||||
|
||||
%% stream_range_open(+RawStream, -DataStream, +Options) is det.
|
||||
%
|
||||
% DataStream is a stream whose size is defined by the option
|
||||
% size(ContentLength). Closing DataStream does not close
|
||||
% RawStream.
|
||||
|
||||
%% cgi_open(+OutStream, -CGIStream, :Hook, +Options) is det.
|
||||
%
|
||||
% Process CGI output. OutStream is normally the socket returning
|
||||
% data to the HTTP client. CGIStream is the stream the (Prolog)
|
||||
% code writes to. The CGIStream provides the following functions:
|
||||
%
|
||||
% * At the end of the header, it calls Hook using
|
||||
% call(Hook, header, Stream), where Stream is a stream holding
|
||||
% the buffered header.
|
||||
%
|
||||
% * If the stream is closed, it calls Hook using
|
||||
% call(Hook, data, Stream), where Stream holds the buffered
|
||||
% data.
|
||||
%
|
||||
% The stream calls Hook, adding the event and CGIStream to the
|
||||
% closure. Defined events are:
|
||||
%
|
||||
% * header
|
||||
% Called if the header is complete. Typically it uses
|
||||
% cgi_property/2 to extract the collected header and combines
|
||||
% these with the request and policies to decide on encoding,
|
||||
% transfer-encoding, connection parameters and the complete
|
||||
% header (as a Prolog term). Typically it uses cgi_set/2 to
|
||||
% associate these with the stream.
|
||||
%
|
||||
% * send_header
|
||||
% Called if the HTTP header must be sent. This is immediately
|
||||
% after setting the transfer encoding to =chunked= or when the
|
||||
% CGI stream is closed. Typically it requests the current
|
||||
% header, optionally the content-length and sends the header
|
||||
% to the original (client) stream.
|
||||
%
|
||||
% * close
|
||||
% Called from close/1 on the CGI stream after everything is
|
||||
% complete.
|
||||
%
|
||||
% The predicates cgi_property/2 and cgi_set/2 can be used to
|
||||
% control the stream and store status info. Terms are stored as
|
||||
% Prolog records and can thus be transferred between threads.
|
||||
|
||||
%% cgi_property(+CGIStream, ?Property) is det.
|
||||
%
|
||||
% Inquire the status of the CGI stream. Defined properties are:
|
||||
%
|
||||
% * request(-Term)
|
||||
% The original request
|
||||
% * header(-Term)
|
||||
% Term is the header term as registered using cgi_set/2
|
||||
% * client(-Stream)
|
||||
% Stream is the original output stream used to create
|
||||
% this stream.
|
||||
% * thread(-ThreadID)
|
||||
% ThreadID is the identifier of the `owning thread'
|
||||
% * transfer_encoding(-Tranfer)
|
||||
% One of =chunked= or =none=.
|
||||
% * connection(-Connection)
|
||||
% One of =Keep-Alife= or =close=
|
||||
% * content_length(-ContentLength)
|
||||
% Total byte-size of the content. Available in the close
|
||||
% handler if the transfer_encoding is =none=.
|
||||
% * header_codes(-Codes)
|
||||
% Codes represents the header collected. Available in the
|
||||
% header handler.
|
||||
% * state(-State)
|
||||
% One of =header=, =data= or =discarded=
|
||||
|
||||
%% cgi_set(+CGIStream, ?Property) is det.
|
||||
%
|
||||
% Change one of the properies. Supported properties are:
|
||||
%
|
||||
% * request(+Term)
|
||||
% Associate a request to the stream.
|
||||
% * header(+Term)
|
||||
% Register a reply header. This header is normally retrieved
|
||||
% from the =send_header= hook to send the reply header to the
|
||||
% client.
|
||||
% * connection(-Connection)
|
||||
% One of =Keep-Alife= or =close=.
|
||||
% * transfer_encoding(-Tranfer)
|
||||
% One of =chunked= or =none=. Initially set to =none=. When
|
||||
% switching to =chunked= from the =header= hook, it calls the
|
||||
% =send_header= hook and if there is data queed this is send
|
||||
% as first chunk. Each subsequent write to the CGI stream
|
||||
% emits a chunk.
|
||||
|
||||
%% cgi_discard(+CGIStream) is det.
|
||||
%
|
||||
% Discard content produced sofar. It sets the state property to
|
||||
% =discarded=, causing close to omit the writing the data. This
|
||||
% must be to use an alternate output (e.g. an error page) if the
|
||||
% page generator fails.
|
||||
|
||||
%% is_cgi_stream(+Stream) is semidet.
|
||||
%
|
||||
% True if Stream is a CGI stream created using cgi_open/4.
|
||||
|
||||
:- multifile
|
||||
http:encoding_filter/3. % +Encoding, +In0, -In
|
||||
:- multifile
|
||||
http:current_transfer_encoding/1. % ?Encoding
|
||||
|
||||
% http:encoding_filter(+Encoding, +In0, -In) is semidet.
|
||||
%
|
||||
% Install a filter to deal with =chunked= encoded messages.
|
||||
|
||||
http:encoding_filter(chunked, In0, In) :-
|
||||
http_chunked_open(In0, In,
|
||||
[ close_parent(true)
|
||||
]).
|
||||
|
||||
% http:current_transfer_encoding(?Encoding) is semidet.
|
||||
%
|
||||
% True if Encoding is supported
|
||||
|
||||
http:current_transfer_encoding(chunked).
|
||||
|
||||
:- retract(system:swi_io).
|
||||
405
packages/http/http_wrapper.pl
Normal file
405
packages/http/http_wrapper.pl
Normal file
@ -0,0 +1,405 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2009, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(httpd_wrapper,
|
||||
[ http_wrapper/5, % :Goal, +In, +Out, -Conn, +Options
|
||||
http_current_request/1, % -Request
|
||||
http_send_header/1, % +Term
|
||||
http_relative_path/2, % +AbsPath, -RelPath
|
||||
% Internal API
|
||||
http_wrap_spawned/3, % :Goal, -Request, -Connection
|
||||
http_spawned/1 % +ThreadId
|
||||
]).
|
||||
:- use_module(http_header).
|
||||
:- use_module(http_stream).
|
||||
:- use_module(http_exception).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(broadcast)).
|
||||
|
||||
:- meta_predicate
|
||||
http_wrapper(0, +, +, -, +).
|
||||
:- multifile
|
||||
http:request_expansion/2.
|
||||
|
||||
%% http_wrapper(:Goal, +In, +Out, -Close, +Options) is det.
|
||||
%
|
||||
% Simple wrapper to read and decode an HTTP header from `In', call
|
||||
% :Goal while watching for exceptions and send the result to the
|
||||
% stream `Out'.
|
||||
%
|
||||
% The goal is assumed to write the reply to =current_output=
|
||||
% preceeded by an HTTP header, closed by a blank line. The header
|
||||
% *must* contain a Content-type: <type> line. It may optionally
|
||||
% contain a line =|Transfer-encoding: chunked|= to request chunked
|
||||
% encoding.
|
||||
%
|
||||
% Options:
|
||||
%
|
||||
% * request(-Request)
|
||||
% Return the full request to the caller
|
||||
% * peer(+Peer)
|
||||
% IP address of client
|
||||
%
|
||||
% @param Close Unified to one of =close=, =|Keep-Alife|= or
|
||||
% spawned(ThreadId).
|
||||
|
||||
http_wrapper(Goal, In, Out, Close, Options) :-
|
||||
status(Id, State0),
|
||||
catch(http_read_request(In, Request0), ReqError, true),
|
||||
( Request0 == end_of_file
|
||||
-> Close = close,
|
||||
extend_request(Options, [], _) % return request
|
||||
; var(ReqError)
|
||||
-> extend_request(Options, Request0, Request1),
|
||||
memberchk(method(Method), Request1),
|
||||
memberchk(path(Location), Request1),
|
||||
cgi_open(Out, CGI, cgi_hook, [request(Request1)]),
|
||||
cgi_property(CGI, id(Id)),
|
||||
debug(http(request), '[~D] ~w ~w ...', [Id, Method, Location]),
|
||||
handler_with_output_to(Goal, Id, Request1, CGI, Error),
|
||||
cgi_close(CGI, State0, Error, Close)
|
||||
; Id = 0,
|
||||
send_error(Out, State0, ReqError, Close),
|
||||
extend_request(Options, [], _)
|
||||
).
|
||||
|
||||
status(Id, state0(Thread, CPU, Id)) :-
|
||||
thread_self(Thread),
|
||||
thread_cputime(CPU).
|
||||
|
||||
|
||||
%% http_wrap_spawned(:Goal, -Request, -Close) is det.
|
||||
%
|
||||
% Internal use only. Helper for wrapping the handler for
|
||||
% http_spawn/2.
|
||||
%
|
||||
% @see http_spawned/1, http_spawn/2.
|
||||
|
||||
http_wrap_spawned(Goal, Request, Close) :-
|
||||
current_output(CGI),
|
||||
cgi_property(CGI, id(Id)),
|
||||
handler_with_output_to(Goal, Id, -, current_output, Error),
|
||||
( retract(spawned(ThreadId))
|
||||
-> Close = spawned(ThreadId),
|
||||
Request = []
|
||||
; cgi_property(CGI, request(Request)),
|
||||
status(Id, State0),
|
||||
catch(cgi_close(CGI, State0, Error, Close),
|
||||
_,
|
||||
Close = close)
|
||||
).
|
||||
|
||||
|
||||
:- thread_local
|
||||
spawned/1.
|
||||
|
||||
%% http_spawned(+ThreadId)
|
||||
%
|
||||
% Internal use only. Indicate that the request is handed to thread
|
||||
% ThreadId.
|
||||
|
||||
http_spawned(ThreadId) :-
|
||||
assert(spawned(ThreadId)).
|
||||
|
||||
|
||||
%% cgi_close(+CGI, +State0, +Error, -Close) is det.
|
||||
%
|
||||
% The wrapper has completed. Finish the CGI output. We have three
|
||||
% cases:
|
||||
%
|
||||
% * The wrapper delegated the request to a new thread
|
||||
% * The wrapper succeeded
|
||||
% * The wrapper threw an error, non-200 status reply
|
||||
% (e.g., =not_modified=, =moved=) or a request to reply with
|
||||
% the content of a file.
|
||||
%
|
||||
% @error socket I/O errors.
|
||||
|
||||
cgi_close(_, _, _, Close) :-
|
||||
retract(spawned(ThreadId)), !,
|
||||
Close = spawned(ThreadId).
|
||||
cgi_close(CGI, State0, ok, Close) :- !,
|
||||
catch(cgi_finish(CGI, Close, Bytes), E, true),
|
||||
( var(E)
|
||||
-> http_done(200, ok, Bytes, State0)
|
||||
; http_done(500, E, 0, State0), % TBD: amount written?
|
||||
throw(E)
|
||||
).
|
||||
cgi_close(CGI, Id, Error, Close) :-
|
||||
cgi_property(CGI, client(Out)),
|
||||
cgi_discard(CGI),
|
||||
close(CGI),
|
||||
send_error(Out, Id, Error, Close).
|
||||
|
||||
cgi_finish(CGI, Close, Bytes) :-
|
||||
flush_output, % update the content-length
|
||||
cgi_property(CGI, connection(Close)),
|
||||
cgi_property(CGI, content_length(Bytes)),
|
||||
close(CGI).
|
||||
|
||||
%% send_error(+Out, +State0, +Error, -Close)
|
||||
%
|
||||
% Send status replies and reply files. The =current_output= no
|
||||
% longer points to the CGI stream, but simply to the socket that
|
||||
% connects us to the client.
|
||||
%
|
||||
% @param State0 is start-status as returned by status/1. Used to
|
||||
% find CPU usage, etc.
|
||||
|
||||
send_error(Out, State0, Error, Close) :-
|
||||
map_exception_to_http_status(Error, Reply, HdrExtra),
|
||||
catch(http_reply(Reply, Out,
|
||||
[ content_length(CLen)
|
||||
| HdrExtra
|
||||
],
|
||||
Code),
|
||||
E, true),
|
||||
( var(E)
|
||||
-> http_done(Code, Error, CLen, State0)
|
||||
; http_done(500, E, 0, State0),
|
||||
throw(E) % is that wise?
|
||||
),
|
||||
( memberchk(connection(Close), HdrExtra)
|
||||
-> true
|
||||
; Close = close
|
||||
).
|
||||
|
||||
|
||||
%% http_done(+Code, +Status, +BytesSent, +State0) is det.
|
||||
%
|
||||
% Provide feedback for logging and debugging on how the request
|
||||
% has been completed.
|
||||
|
||||
http_done(Code, Status, Bytes, state0(_Thread, CPU0, Id)) :-
|
||||
thread_cputime(CPU1),
|
||||
CPU is CPU1 - CPU0,
|
||||
( debugging(http(request))
|
||||
-> debug_request(Code, Status, Id, CPU, Bytes)
|
||||
; true
|
||||
),
|
||||
broadcast(http(request_finished(Id, Code, Status, CPU, Bytes))).
|
||||
|
||||
|
||||
%% handler_with_output_to(:Goal, +Id, +Request, +Output, -Status) is det.
|
||||
%
|
||||
% Run Goal with output redirected to Output. Unifies Status with
|
||||
% =ok=, the error from catch/3 or a term error(goal_failed(Goal),
|
||||
% _).
|
||||
%
|
||||
% @param Request The HTTP request read or '-' for a continuation
|
||||
% using http_spawn/2.
|
||||
|
||||
handler_with_output_to(Goal, Id, Request, current_output, Status) :- !,
|
||||
( catch(call_handler(Goal, Id, Request), Status, true)
|
||||
-> ( var(Status)
|
||||
-> Status = ok
|
||||
; true
|
||||
)
|
||||
; Status = error(goal_failed(Goal),_)
|
||||
).
|
||||
handler_with_output_to(Goal, Id, Request, Output, Error) :-
|
||||
current_output(OldOut),
|
||||
set_output(Output),
|
||||
handler_with_output_to(Goal, Id, Request, current_output, Error),
|
||||
set_output(OldOut).
|
||||
|
||||
call_handler(Goal, _, -) :- !, % continuation through http_spawn/2
|
||||
call(Goal).
|
||||
call_handler(Goal, Id, Request0) :-
|
||||
expand_request(Request0, Request),
|
||||
current_output(CGI),
|
||||
cgi_set(CGI, request(Request)),
|
||||
broadcast(http(request_start(Id, Request))),
|
||||
call(Goal, Request).
|
||||
|
||||
%% thread_cputime(-CPU) is det.
|
||||
%
|
||||
% CPU is the CPU time used by the calling thread.
|
||||
%
|
||||
% @tbd This does not work on MacOS X!
|
||||
|
||||
:- if(current_prolog_flag(threads, true)).
|
||||
thread_cputime(CPU) :-
|
||||
thread_self(Me),
|
||||
thread_statistics(Me, cputime, CPU).
|
||||
:- else.
|
||||
thread_cputime(CPU) :-
|
||||
statistics(cputime, CPU).
|
||||
:- endif.
|
||||
|
||||
|
||||
%% cgi_hook(+Event, +CGI) is det.
|
||||
%
|
||||
% Hook called from the CGI processing stream. See http_stream.pl
|
||||
% for details.
|
||||
|
||||
cgi_hook(What, _CGI) :-
|
||||
debug(http(hook), 'Running hook: ~q', [What]),
|
||||
fail.
|
||||
cgi_hook(header, CGI) :-
|
||||
cgi_property(CGI, header_codes(HeadText)),
|
||||
cgi_property(CGI, header(Header0)), % see http_send_header/1
|
||||
http_parse_header(HeadText, CgiHeader0),
|
||||
append(Header0, CgiHeader0, CgiHeader),
|
||||
cgi_property(CGI, request(Request)),
|
||||
http_update_connection(CgiHeader, Request, Connection, Header1),
|
||||
http_update_transfer(Request, Header1, Transfer, Header2),
|
||||
http_update_encoding(Header2, Encoding, Header),
|
||||
set_stream(CGI, encoding(Encoding)),
|
||||
cgi_set(CGI, connection(Connection)),
|
||||
cgi_set(CGI, header(Header)),
|
||||
debug(http(transfer_encoding), 'Transfer-encoding: ~w', [Transfer]),
|
||||
cgi_set(CGI, transfer_encoding(Transfer)). % must be LAST
|
||||
cgi_hook(send_header, CGI) :-
|
||||
cgi_property(CGI, header(Header)),
|
||||
cgi_property(CGI, client(Out)),
|
||||
( cgi_property(CGI, transfer_encoding(chunked))
|
||||
-> http_reply_header(Out, chunked_data, Header)
|
||||
; cgi_property(CGI, content_length(Len))
|
||||
-> http_reply_header(Out, cgi_data(Len), Header)
|
||||
).
|
||||
cgi_hook(close, _).
|
||||
|
||||
|
||||
%% http_send_header(+Header)
|
||||
%
|
||||
% This API provides an alternative for writing the header field as
|
||||
% a CGI header. Header has the format Name(Value), as produced by
|
||||
% http_read_header/2.
|
||||
%
|
||||
% @deprecated Use CGI lines instead
|
||||
|
||||
http_send_header(Header) :-
|
||||
current_output(CGI),
|
||||
cgi_property(CGI, header(Header0)),
|
||||
cgi_set(CGI, header([Header|Header0])).
|
||||
|
||||
|
||||
%% expand_request(+Request0, -Request)
|
||||
%
|
||||
% Allow for general rewrites of a request by calling
|
||||
% http:request_expansion/2.
|
||||
|
||||
expand_request(R0, R) :-
|
||||
http:request_expansion(R0, R1), % Hook
|
||||
R1 \== R0, !,
|
||||
expand_request(R1, R).
|
||||
expand_request(R, R).
|
||||
|
||||
|
||||
%% extend_request(+Options, +RequestIn, -Request)
|
||||
%
|
||||
% Merge options in the request.
|
||||
|
||||
extend_request([], R, R).
|
||||
extend_request([request(R)|T], R0, R) :- !,
|
||||
extend_request(T, R0, R).
|
||||
extend_request([H|T], R0, R) :-
|
||||
request_option(H), !,
|
||||
extend_request(T, [H|R0], R).
|
||||
extend_request([_|T], R0, R) :-
|
||||
extend_request(T, R0, R).
|
||||
|
||||
request_option(peer(_)).
|
||||
request_option(protocol(_)).
|
||||
request_option(pool(_)).
|
||||
|
||||
|
||||
%% http_current_request(-Request) is semidet.
|
||||
%
|
||||
% Returns the HTTP request currently being processed. Fails
|
||||
% silently if there is no current request. This typically happens
|
||||
% if a goal is run outside the HTTP server context.
|
||||
|
||||
http_current_request(Request) :-
|
||||
current_output(CGI),
|
||||
is_cgi_stream(CGI),
|
||||
cgi_property(CGI, request(Request)).
|
||||
|
||||
|
||||
%% http_relative_path(+AbsPath, -RelPath) is det.
|
||||
%
|
||||
% Convert an absolute path (without host, fragment or search) into
|
||||
% a path relative to the current page. This call is intended to
|
||||
% create reusable components returning relative paths for easier
|
||||
% support of reverse proxies.
|
||||
|
||||
http_relative_path(Path, RelPath) :-
|
||||
http_current_request(Request),
|
||||
memberchk(path(RelTo), Request),
|
||||
http_relative_path(Path, RelTo, RelPath), !.
|
||||
http_relative_path(Path, Path).
|
||||
|
||||
http_relative_path(Path, RelTo, RelPath) :-
|
||||
atomic_list_concat(PL, /, Path),
|
||||
atomic_list_concat(RL, /, RelTo),
|
||||
delete_common_prefix(PL, RL, PL1, PL2),
|
||||
to_dot_dot(PL2, DotDot, PL1),
|
||||
atomic_list_concat(DotDot, /, RelPath).
|
||||
|
||||
delete_common_prefix([H|T01], [H|T02], T1, T2) :- !,
|
||||
delete_common_prefix(T01, T02, T1, T2).
|
||||
delete_common_prefix(T1, T2, T1, T2).
|
||||
|
||||
to_dot_dot([], Tail, Tail).
|
||||
to_dot_dot([_], Tail, Tail) :- !.
|
||||
to_dot_dot([_|T0], ['..'|T], Tail) :-
|
||||
to_dot_dot(T0, T, Tail).
|
||||
|
||||
|
||||
/*******************************
|
||||
* DEBUG SUPPORT *
|
||||
*******************************/
|
||||
|
||||
%% debug_request(+Code, +Status, +Id, +CPU0, Bytes)
|
||||
%
|
||||
% Emit debugging info after a request completed with Status.
|
||||
|
||||
debug_request(Code, ok, Id, CPU, Bytes) :- !,
|
||||
debug(http(request), '[~D] ~w OK (~3f seconds; ~D bytes)',
|
||||
[Id, Code, CPU, Bytes]).
|
||||
debug_request(Code, Status, Id, _, Bytes) :-
|
||||
map_exception(Status, Reply), !,
|
||||
debug(http(request), '[~D] ~w ~w; ~D bytes',
|
||||
[Id, Code, Reply, Bytes]).
|
||||
debug_request(Code, Except, Id, _, _) :- !,
|
||||
Except = error(_,_), !,
|
||||
message_to_string(Except, Message),
|
||||
debug(http(request), '[~D] ~w ERROR: ~w',
|
||||
[Id, Code, Message]).
|
||||
debug_request(Code, Status, Id, _, Bytes) :-
|
||||
debug(http(request), '[~D] ~w ~w; ~D bytes',
|
||||
[Id, Code, Status, Bytes]).
|
||||
|
||||
map_exception(http_reply(Reply), Reply).
|
||||
map_exception(error(existence_error(http_location, Location), _Stack),
|
||||
error(404, Location)).
|
||||
0
packages/http/httpserver.gif
Normal file
0
packages/http/httpserver.gif
Normal file
65
packages/http/inetd_httpd.pl
Normal file
65
packages/http/inetd_httpd.pl
Normal file
@ -0,0 +1,65 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2002, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(http_test,
|
||||
[ http_server/2 % :Goal, +Options
|
||||
]).
|
||||
:- use_module(http_wrapper).
|
||||
|
||||
:- meta_predicate
|
||||
http_server(:, +),
|
||||
server_loop(:, +).
|
||||
|
||||
%% http_server(:Goal, +Options)
|
||||
%
|
||||
% Start the server from inetd. This is really easy as user_input
|
||||
% is connected to the HTTP input and user_output is the place to
|
||||
% write our reply to.
|
||||
|
||||
http_server(Goal, Options) :-
|
||||
prompt(_, ''),
|
||||
set_stream(user_output, buffer(full)),
|
||||
set_stream(user_output, encoding(octet)),
|
||||
set_stream(user_input, buffer(full)),
|
||||
set_stream(user_input, encoding(octet)),
|
||||
server_loop(Goal, Options).
|
||||
|
||||
server_loop(_, _) :-
|
||||
at_end_of_stream(user_input), !,
|
||||
halt.
|
||||
server_loop(Goal, Options) :-
|
||||
http_wrapper(Goal, user_input, user_output, Connection, []),
|
||||
( downcase_atom(Connection, 'keep-alive')
|
||||
-> server_loop(Goal, Options)
|
||||
; halt
|
||||
).
|
||||
server_loop(_, _) :- % wrapper failed
|
||||
halt.
|
||||
238
packages/http/install-sh
Executable file
238
packages/http/install-sh
Executable file
@ -0,0 +1,238 @@
|
||||
#!/bin/sh
|
||||
#
|
||||
# install - install a program, script, or datafile
|
||||
# This comes from X11R5.
|
||||
#
|
||||
# Calling this script install-sh is preferred over install.sh, to prevent
|
||||
# `make' implicit rules from creating a file called install from it
|
||||
# when there is no Makefile.
|
||||
#
|
||||
# This script is compatible with the BSD install script, but was written
|
||||
# from scratch.
|
||||
#
|
||||
|
||||
|
||||
# set DOITPROG to echo to test this script
|
||||
|
||||
# Don't use :- since 4.3BSD and earlier shells don't like it.
|
||||
doit="${DOITPROG-}"
|
||||
|
||||
|
||||
# put in absolute paths if you don't have them in your path; or use env. vars.
|
||||
|
||||
mvprog="${MVPROG-mv}"
|
||||
cpprog="${CPPROG-cp}"
|
||||
chmodprog="${CHMODPROG-chmod}"
|
||||
chownprog="${CHOWNPROG-chown}"
|
||||
chgrpprog="${CHGRPPROG-chgrp}"
|
||||
stripprog="${STRIPPROG-strip}"
|
||||
rmprog="${RMPROG-rm}"
|
||||
mkdirprog="${MKDIRPROG-mkdir}"
|
||||
|
||||
tranformbasename=""
|
||||
transform_arg=""
|
||||
instcmd="$mvprog"
|
||||
chmodcmd="$chmodprog 0755"
|
||||
chowncmd=""
|
||||
chgrpcmd=""
|
||||
stripcmd=""
|
||||
rmcmd="$rmprog -f"
|
||||
mvcmd="$mvprog"
|
||||
src=""
|
||||
dst=""
|
||||
dir_arg=""
|
||||
|
||||
while [ x"$1" != x ]; do
|
||||
case $1 in
|
||||
-c) instcmd="$cpprog"
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-d) dir_arg=true
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-m) chmodcmd="$chmodprog $2"
|
||||
shift
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-o) chowncmd="$chownprog $2"
|
||||
shift
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-g) chgrpcmd="$chgrpprog $2"
|
||||
shift
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-s) stripcmd="$stripprog"
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-t=*) transformarg=`echo $1 | sed 's/-t=//'`
|
||||
shift
|
||||
continue;;
|
||||
|
||||
-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
|
||||
shift
|
||||
continue;;
|
||||
|
||||
*) if [ x"$src" = x ]
|
||||
then
|
||||
src=$1
|
||||
else
|
||||
# this colon is to work around a 386BSD /bin/sh bug
|
||||
:
|
||||
dst=$1
|
||||
fi
|
||||
shift
|
||||
continue;;
|
||||
esac
|
||||
done
|
||||
|
||||
if [ x"$src" = x ]
|
||||
then
|
||||
echo "install: no input file specified"
|
||||
exit 1
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
if [ x"$dir_arg" != x ]; then
|
||||
dst=$src
|
||||
src=""
|
||||
|
||||
if [ -d $dst ]; then
|
||||
instcmd=:
|
||||
else
|
||||
instcmd=mkdir
|
||||
fi
|
||||
else
|
||||
|
||||
# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
|
||||
# might cause directories to be created, which would be especially bad
|
||||
# if $src (and thus $dsttmp) contains '*'.
|
||||
|
||||
if [ -f $src -o -d $src ]
|
||||
then
|
||||
true
|
||||
else
|
||||
echo "install: $src does not exist"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
if [ x"$dst" = x ]
|
||||
then
|
||||
echo "install: no destination specified"
|
||||
exit 1
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
# If destination is a directory, append the input filename; if your system
|
||||
# does not like double slashes in filenames, you may need to add some logic
|
||||
|
||||
if [ -d $dst ]
|
||||
then
|
||||
dst="$dst"/`basename $src`
|
||||
else
|
||||
true
|
||||
fi
|
||||
fi
|
||||
|
||||
## this sed command emulates the dirname command
|
||||
dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
|
||||
|
||||
# Make sure that the destination directory exists.
|
||||
# this part is taken from Noah Friedman's mkinstalldirs script
|
||||
|
||||
# Skip lots of stat calls in the usual case.
|
||||
if [ ! -d "$dstdir" ]; then
|
||||
defaultIFS='
|
||||
'
|
||||
IFS="${IFS-${defaultIFS}}"
|
||||
|
||||
oIFS="${IFS}"
|
||||
# Some sh's can't handle IFS=/ for some reason.
|
||||
IFS='%'
|
||||
set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
|
||||
IFS="${oIFS}"
|
||||
|
||||
pathcomp=''
|
||||
|
||||
while [ $# -ne 0 ] ; do
|
||||
pathcomp="${pathcomp}${1}"
|
||||
shift
|
||||
|
||||
if [ ! -d "${pathcomp}" ] ;
|
||||
then
|
||||
$mkdirprog "${pathcomp}"
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
pathcomp="${pathcomp}/"
|
||||
done
|
||||
fi
|
||||
|
||||
if [ x"$dir_arg" != x ]
|
||||
then
|
||||
$doit $instcmd $dst &&
|
||||
|
||||
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
|
||||
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
|
||||
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
|
||||
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
|
||||
else
|
||||
|
||||
# If we're going to rename the final executable, determine the name now.
|
||||
|
||||
if [ x"$transformarg" = x ]
|
||||
then
|
||||
dstfile=`basename $dst`
|
||||
else
|
||||
dstfile=`basename $dst $transformbasename |
|
||||
sed $transformarg`$transformbasename
|
||||
fi
|
||||
|
||||
# don't allow the sed command to completely eliminate the filename
|
||||
|
||||
if [ x"$dstfile" = x ]
|
||||
then
|
||||
dstfile=`basename $dst`
|
||||
else
|
||||
true
|
||||
fi
|
||||
|
||||
# Make a temp file name in the proper directory.
|
||||
|
||||
dsttmp=$dstdir/#inst.$$#
|
||||
|
||||
# Move or copy the file name to the temp name
|
||||
|
||||
$doit $instcmd $src $dsttmp &&
|
||||
|
||||
trap "rm -f ${dsttmp}" 0 &&
|
||||
|
||||
# and set any options; do chmod last to preserve setuid bits
|
||||
|
||||
# If any of these fail, we abort the whole thing. If we want to
|
||||
# ignore errors from any of these, just make sure not to ignore
|
||||
# errors from the above "$doit $instcmd $src $dsttmp" command.
|
||||
|
||||
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
|
||||
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
|
||||
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
|
||||
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
|
||||
|
||||
# Now rename the file to the real destination.
|
||||
|
||||
$doit $rmcmd -f $dstdir/$dstfile &&
|
||||
$doit $mvcmd $dsttmp $dstdir/$dstfile
|
||||
|
||||
fi &&
|
||||
|
||||
|
||||
exit 0
|
||||
231
packages/http/js_write.pl
Normal file
231
packages/http/js_write.pl
Normal file
@ -0,0 +1,231 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker, Michiel Hildebrand
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2007-2010, University of Amsterdam
|
||||
VU University Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(javascript,
|
||||
[ js_call//1, % +Function(Arg..)
|
||||
js_new//2, % +Id, +Function(+Args)
|
||||
js_args//1 % +Args
|
||||
]).
|
||||
|
||||
:- use_module(library(http/html_write)).
|
||||
:- use_module(library(http/json_convert)).
|
||||
:- use_module(library(http/json)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(debug)).
|
||||
|
||||
/** <module> Utilities for including javascript
|
||||
|
||||
This library is a supplement to library(http/html_write) for producing
|
||||
JavaScript fragments. Its main role is to be able to call JavaScript
|
||||
functions with valid arguments constructed from Prolog data. E.g.
|
||||
suppose you want to call a JavaScript functions to process a list of
|
||||
names represented as Prolog atoms. This can be done using the call
|
||||
below, while without this library you would have to be careful to
|
||||
properly escape special characters.
|
||||
|
||||
==
|
||||
numbers_script(Names) -->
|
||||
html(script(type('text/javascript'),
|
||||
[ \js_call('ProcessNumbers'(Names)
|
||||
]),
|
||||
==
|
||||
|
||||
The accepted arguments are described with js_args//1.
|
||||
*/
|
||||
|
||||
%% js_call(+Term)// is det.
|
||||
%
|
||||
% Emit a call to a Javascript function. The Prolog functor is the
|
||||
% name of the function. The arguments are converted from Prolog to
|
||||
% JavaScript using js_args//1. Please not that Prolog functors can
|
||||
% be quoted atom and thus the following is legal:
|
||||
%
|
||||
% ==
|
||||
% ...
|
||||
% html(script(type('text/javascript'),
|
||||
% [ \js_call('x.y.z'(hello, 42)
|
||||
% ]),
|
||||
% ==
|
||||
|
||||
js_call(Term) -->
|
||||
{ Term =.. [Function|Args] },
|
||||
html([Function, '(']),
|
||||
js_args(Args),
|
||||
html(');\n').
|
||||
|
||||
|
||||
%% js_new(+Id, +Term)// is det.
|
||||
%
|
||||
% Emit a call to a Javascript object declaration. This is the same
|
||||
% as:
|
||||
%
|
||||
% ==
|
||||
% ['var ', Id, ' = new ', \js_call(Term)]
|
||||
% ==
|
||||
|
||||
|
||||
js_new(Id, Term) -->
|
||||
{ Term =.. [Function|Args] },
|
||||
html(['var ', Id, ' = new ', Function, '(']),
|
||||
js_args(Args),
|
||||
html(');\n').
|
||||
|
||||
%% js_args(+Args:list)// is det.
|
||||
%
|
||||
% Write javascript function arguments. Each argument is separated
|
||||
% by a comma. Elements of the list may contain the following
|
||||
% terms:
|
||||
%
|
||||
% $ Variable :
|
||||
% Emitted as Javascript =null=
|
||||
% $ List :
|
||||
% Produces a Javascript list, where each element is processed
|
||||
% by this library.
|
||||
% $ object(Attributes) :
|
||||
% Where Attributes is a Key-Value list where each pair can be
|
||||
% written as Key-Value, Key=Value or Key(Value), accomodating
|
||||
% all common constructs for this used in Prolog.
|
||||
% $ json(Term) :
|
||||
% Emits a term using json_write/3.
|
||||
% $ @(true), @(false), @(null) :
|
||||
% Emits these constants without quotes.
|
||||
% $ Number :
|
||||
% Emited literally
|
||||
% $ symbol(Atom) :
|
||||
% Emitted without quotes. Can be used for JavaScript symbols
|
||||
% (e.i., function and variable-names)
|
||||
% $ Atom or String :
|
||||
% Emitted as quoted JavaScript string.
|
||||
|
||||
js_args([]) -->
|
||||
[].
|
||||
js_args([H|T]) -->
|
||||
( js_arg(H)
|
||||
-> ( { T == [] }
|
||||
-> []
|
||||
; html(', '),
|
||||
js_args(T)
|
||||
)
|
||||
; { type_error(javascript_argument, H) }
|
||||
).
|
||||
|
||||
js_arg(H) -->
|
||||
{ var(H) }, !,
|
||||
[null].
|
||||
js_arg(object(H)) -->
|
||||
{ is_list(H) }, !,
|
||||
html([ '{', \js_kv_list(H), '}' ]).
|
||||
js_arg(@(true)) --> [true].
|
||||
js_arg(@(false)) --> [false].
|
||||
js_arg(@(null)) --> [null].
|
||||
js_arg(symbol(H)) -->
|
||||
[H].
|
||||
js_arg(json(Term)) -->
|
||||
{ json_to_string(json(Term), String),
|
||||
debug(json_arg, '~w~n', String)
|
||||
},
|
||||
[ String ].
|
||||
js_arg(H) -->
|
||||
{ is_list(H) }, !,
|
||||
html([ '[', \js_args(H), ']' ]).
|
||||
js_arg(H) -->
|
||||
{ number(H) }, !,
|
||||
[H].
|
||||
js_arg(H) -->
|
||||
{ atomic(H), !,
|
||||
js_quoted_string(H, Q)
|
||||
},
|
||||
[ '\'', Q, '\''
|
||||
].
|
||||
|
||||
js_kv_list([]) --> [].
|
||||
js_kv_list([H|T]) -->
|
||||
( js_kv(H)
|
||||
-> ( { T == [] }
|
||||
-> []
|
||||
; html(', '),
|
||||
js_kv_list(T)
|
||||
)
|
||||
; { type_error(javascript_key_value, H) }
|
||||
).
|
||||
|
||||
js_kv(Key-Value) -->
|
||||
html(['\'',Key,'\':',\js_arg(Value)]).
|
||||
js_kv(Key=Value) -->
|
||||
html(['\'',Key,'\':',\js_arg(Value)]).
|
||||
js_kv(Term) -->
|
||||
{ compound(Term),
|
||||
Term =.. [Key,Value]
|
||||
}, !,
|
||||
html(['\'',Key,'\':',\js_arg(Value)]).
|
||||
|
||||
%% js_quoted_string(+Raw, -Quoted)
|
||||
%
|
||||
% Quote text for use in JavaScript. Quoted does _not_ include the
|
||||
% leading and trailing quotes.
|
||||
%
|
||||
% @tbd Join with json stuff.
|
||||
|
||||
js_quoted_string(Raw, Quoted) :-
|
||||
atom_codes(Raw, Codes),
|
||||
phrase(js_quote_codes(Codes), QuotedCodes),
|
||||
atom_codes(Quoted, QuotedCodes).
|
||||
|
||||
js_quote_codes([]) -->
|
||||
[].
|
||||
js_quote_codes([0'\r,0'\n|T]) --> !,
|
||||
"\\n",
|
||||
js_quote_codes(T).
|
||||
js_quote_codes([H|T]) -->
|
||||
js_quote_code(H),
|
||||
js_quote_codes(T).
|
||||
|
||||
js_quote_code(0'') --> !,
|
||||
"\\'".
|
||||
js_quote_code(34) --> !,
|
||||
[92,34].
|
||||
js_quote_code(0'\\) --> !,
|
||||
"\\\\".
|
||||
js_quote_code(0'\n) --> !,
|
||||
"\\n".
|
||||
js_quote_code(0'\r) --> !,
|
||||
"\\r".
|
||||
js_quote_code(0'\t) --> !,
|
||||
"\\t".
|
||||
js_quote_code(C) -->
|
||||
[C].
|
||||
|
||||
%% json_to_string(+JSONTerm, -String)
|
||||
%
|
||||
% Write JSONTerm to String.
|
||||
|
||||
json_to_string(JSON, String) :-
|
||||
with_output_to(string(String),
|
||||
json_write(current_output,JSON,[width(0)])).
|
||||
152
packages/http/json.c
Normal file
152
packages/http/json.c
Normal file
@ -0,0 +1,152 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2007, University of Amsterdam
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
This library is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
*/
|
||||
|
||||
#include <SWI-Stream.h>
|
||||
#include <SWI-Prolog.h>
|
||||
#include <string.h>
|
||||
|
||||
#define TRYPUTC(c, s) if ( Sputcode(c, s) < 0 ) { return -1; }
|
||||
|
||||
static int
|
||||
json_put_code(IOSTREAM *out, int c)
|
||||
{ static char escape[128];
|
||||
static int escape_initialized = FALSE;
|
||||
|
||||
if ( !escape_initialized )
|
||||
{ memset(escape, 0, sizeof(escape));
|
||||
|
||||
escape['"'] = '"';
|
||||
escape['\\'] = '\\';
|
||||
escape['\b'] = 'b';
|
||||
escape['\f'] = 'f';
|
||||
escape['\n'] = 'n';
|
||||
escape['\r'] = 'r';
|
||||
escape['\t'] = 't';
|
||||
|
||||
escape_initialized = TRUE;
|
||||
}
|
||||
|
||||
if ( c < 128 )
|
||||
{ if ( escape[c] )
|
||||
{ TRYPUTC('\\', out);
|
||||
TRYPUTC(escape[c], out);
|
||||
} else if ( c < ' ' ) /* control characters *must* be escaped */
|
||||
{ TRYPUTC('\\', out);
|
||||
if ( Sfprintf(out, "u%04x", c) < 0 )
|
||||
return -1;
|
||||
} else
|
||||
{ TRYPUTC(c, out);
|
||||
}
|
||||
} else
|
||||
{ TRYPUTC(c, out);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
#undef TRYPUTC
|
||||
#define TRYPUTC(c, s) if ( Sputcode(c, s) < 0 ) { rc = FALSE; goto out; }
|
||||
|
||||
static foreign_t
|
||||
json_write_string(term_t stream, term_t text)
|
||||
{ IOSTREAM *out;
|
||||
char *a;
|
||||
pl_wchar_t *w;
|
||||
size_t len;
|
||||
int rc = TRUE;
|
||||
|
||||
if ( !PL_get_stream_handle(stream, &out) )
|
||||
return FALSE;
|
||||
|
||||
if ( PL_get_nchars(text, &len, &a, CVT_ATOM|CVT_STRING|CVT_LIST) )
|
||||
{ const char *ap;
|
||||
size_t todo;
|
||||
|
||||
TRYPUTC('"', out);
|
||||
for(todo=len, ap=a; todo-- > 0; ap++)
|
||||
{ int c = *ap&0xff;
|
||||
|
||||
if ( json_put_code(out, c) < 0 )
|
||||
{ rc = FALSE; goto out;
|
||||
}
|
||||
}
|
||||
TRYPUTC('"', out);
|
||||
} else if ( PL_get_wchars(text, &len, &w, CVT_ATOM|CVT_STRING|CVT_LIST|CVT_EXCEPTION) )
|
||||
{ const pl_wchar_t *wp;
|
||||
size_t todo;
|
||||
|
||||
TRYPUTC('"', out);
|
||||
for(todo=len, wp=w; todo-- > 0; wp++)
|
||||
{ int c = *wp;
|
||||
|
||||
if ( json_put_code(out, c) < 0 )
|
||||
{ rc = FALSE; goto out;
|
||||
}
|
||||
}
|
||||
TRYPUTC('"', out);
|
||||
} else
|
||||
{ rc = FALSE;
|
||||
}
|
||||
|
||||
out:
|
||||
PL_release_stream(out);
|
||||
|
||||
return rc;
|
||||
}
|
||||
|
||||
|
||||
static foreign_t
|
||||
json_write_indent(term_t stream, term_t indent, term_t tab)
|
||||
{ int i, t, n;
|
||||
IOSTREAM *out;
|
||||
|
||||
if ( !PL_get_integer(indent, &i) ||
|
||||
!PL_get_integer(tab, &t) )
|
||||
return FALSE;
|
||||
|
||||
if ( PL_get_stream_handle(stream, &out) )
|
||||
{ int rc = TRUE;
|
||||
|
||||
if ( !out->position || out->position->linepos > 0 )
|
||||
{ TRYPUTC('\n', out);
|
||||
}
|
||||
for(n=0; n<i/t; n++)
|
||||
TRYPUTC('\t', out);
|
||||
for(n=0; n<i%t; n++)
|
||||
TRYPUTC(' ', out);
|
||||
out:
|
||||
PL_release_stream(out);
|
||||
return rc;
|
||||
}
|
||||
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
|
||||
install_t
|
||||
install_json()
|
||||
{ PL_register_foreign("json_write_string", 2, json_write_string, 0);
|
||||
PL_register_foreign("json_write_indent", 3, json_write_indent, 0);
|
||||
}
|
||||
654
packages/http/json.pl
Normal file
654
packages/http/json.pl
Normal file
@ -0,0 +1,654 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2009, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(json,
|
||||
[ json_read/2, % +Stream, -JSONTerm
|
||||
json_read/3, % +Stream, -JSONTerm, +Options
|
||||
atom_json_term/3, % ?Atom, ?JSONTerm, +Options
|
||||
json_write/2, % +Stream, +Term
|
||||
json_write/3, % +Stream, +Term, +Options
|
||||
is_json_term/1, % @Term
|
||||
is_json_term/2 % @Term, +Options
|
||||
]).
|
||||
:- use_module(library(record)).
|
||||
:- use_module(library(memfile)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(option)).
|
||||
|
||||
:- use_foreign_library(foreign(json)).
|
||||
|
||||
/** <module> Reading and writing JSON serialization
|
||||
|
||||
This module supports reading and writing JSON objects. The canonical
|
||||
Prolog representation for a JSON value is defined as:
|
||||
|
||||
* A JSON object is mapped to a term json(NameValueList), where
|
||||
NameValueList is a list of Name=Value. Name is an atom created from
|
||||
the JSON string.
|
||||
|
||||
* A JSON array is mapped to a Prolog list of JSON values.
|
||||
|
||||
* A JSON string is mapped to a Prolog atom
|
||||
|
||||
* A JSON number is mapped to a Prolog number
|
||||
|
||||
* The JSON constants =true= and =false= are mapped -like JPL- to
|
||||
@(true) and @(false).
|
||||
|
||||
* The JSON constant =null= is mapped to the Prolog term @(null)
|
||||
|
||||
Here is a complete example in JSON and its corresponding Prolog term.
|
||||
|
||||
==
|
||||
{ "name":"Demo term",
|
||||
"created": {
|
||||
"day":null,
|
||||
"month":"December",
|
||||
"year":2007
|
||||
},
|
||||
"confirmed":true,
|
||||
"members":[1,2,3]
|
||||
}
|
||||
==
|
||||
|
||||
==
|
||||
json([ name='Demo term',
|
||||
created=json([day= @null, month='December', year=2007]),
|
||||
confirmed= @true,
|
||||
members=[1, 2, 3]
|
||||
])
|
||||
==
|
||||
|
||||
@author Jan Wielemaker
|
||||
@see http_json.pl links JSON to the HTTP client and server modules.
|
||||
@see json_convert.pl converts JSON Prolog terms to more comfortable
|
||||
terms.
|
||||
*/
|
||||
|
||||
:- record json_options(null:ground = @(null),
|
||||
true:ground = @(true),
|
||||
false:ground = @(false),
|
||||
value_string_as:oneof([atom,string]) = atom).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MAP *
|
||||
*******************************/
|
||||
|
||||
%% atom_json_term(+Atom, -JSONTerm, +Options) is det.
|
||||
%% atom_json_term(-Text, +JSONTerm, +Options) is det.
|
||||
%
|
||||
% Convert between textual representation and a JSON term. In
|
||||
% _write_ mode, the option as(Type) defines the output type, which
|
||||
% is one of =atom=, =string= or =codes=.
|
||||
|
||||
atom_json_term(Atom, Term, Options) :-
|
||||
ground(Atom), !,
|
||||
atom_to_memory_file(Atom, MF),
|
||||
open_memory_file(MF, read, In),
|
||||
call_cleanup(json_read(In, Term, Options),
|
||||
( close(In),
|
||||
free_memory_file(MF))).
|
||||
atom_json_term(Result, Term, Options) :-
|
||||
select_option(as(Type), Options, Options1),
|
||||
( type_term(Type, Result, Out)
|
||||
-> true
|
||||
; must_be(oneof([atom,string,codes]), Type)
|
||||
),
|
||||
with_output_to(Out,
|
||||
json_write(current_output, Term, Options1)).
|
||||
|
||||
type_term(atom, Result, atom(Result)).
|
||||
type_term(string, Result, string(Result)).
|
||||
type_term(codes, Result, codes(Result)).
|
||||
|
||||
|
||||
/*******************************
|
||||
* READING *
|
||||
*******************************/
|
||||
|
||||
%% json_read(+Stream, -Term) is det.
|
||||
%% json_read(+Stream, -Term, +Options) is det.
|
||||
%
|
||||
% Read next JSON value from Stream into a Prolog term. Options
|
||||
% are:
|
||||
%
|
||||
% * null(NullTerm)
|
||||
% Term used to represent JSON =null=. Default @(null)
|
||||
% * true(TrueTerm)
|
||||
% Term used to represent JSON =true=. Default @(true)
|
||||
% * false(FalsTerm)
|
||||
% Term used to represent JSON =false=. Default @(false)
|
||||
% * value_string_as(Type)
|
||||
% Prolog type used for strings used as value. Default
|
||||
% is =atom=. The alternative is =string=, producing a
|
||||
% packed string object. Please note that =codes= or
|
||||
% =chars= would produce ambiguous output and is therefore
|
||||
% not supported.
|
||||
|
||||
json_read(Stream, Term) :-
|
||||
default_json_options(Options),
|
||||
json_value(Stream, Term, _, Options).
|
||||
|
||||
json_read(Stream, Term, Options) :-
|
||||
make_json_options(Options, OptionTerm, _RestOptions),
|
||||
json_value(Stream, Term, _, OptionTerm).
|
||||
|
||||
|
||||
json_value(Stream, Term, Next, Options) :-
|
||||
get_code(Stream, C0),
|
||||
ws(C0, Stream, C1),
|
||||
json_term(C1, Stream, Term, Next, Options).
|
||||
|
||||
json_term(0'{, Stream, json(Pairs), Next, Options) :- !,
|
||||
ws(Stream, C),
|
||||
json_pairs(C, Stream, Pairs, Options),
|
||||
get_code(Stream, Next).
|
||||
json_term(0'[, Stream, Array, Next, Options) :- !,
|
||||
ws(Stream, C),
|
||||
json_array(C, Stream, Array, Options),
|
||||
get_code(Stream, Next).
|
||||
json_term(0'", Stream, String, Next, Options) :- !,
|
||||
get_code(Stream, C1),
|
||||
json_string_codes(C1, Stream, Codes),
|
||||
json_options_value_string_as(Options, Type),
|
||||
codes_to_type(Type, Codes, String),
|
||||
get_code(Stream, Next).
|
||||
json_term(0'-, Stream, Number, Next, _Options) :- !,
|
||||
json_number_codes(Stream, Codes, Next),
|
||||
number_codes(Number, [0'-|Codes]).
|
||||
json_term(D, Stream, Number, Next, _Options) :-
|
||||
between(0'0, 0'9, D), !,
|
||||
json_number_codes(Stream, Codes, Next),
|
||||
number_codes(Number, [D|Codes]).
|
||||
json_term(C, Stream, Constant, Next, Options) :-
|
||||
get_code(Stream, C1),
|
||||
json_identifier_codes(C1, Stream, Codes, Next),
|
||||
atom_codes(ID, [C|Codes]),
|
||||
json_constant(ID, Constant, Options).
|
||||
|
||||
json_pairs(0'}, _, [], _) :- !.
|
||||
json_pairs(C0, Stream, [Pair|Tail], Options) :-
|
||||
json_pair(C0, Stream, Pair, C, Options),
|
||||
ws(C, Stream, Next),
|
||||
( Next == 0',
|
||||
-> ws(Stream, C2),
|
||||
json_pairs(C2, Stream, Tail, Options)
|
||||
; Next == 0'}
|
||||
-> Tail = []
|
||||
; syntax_error(illegal_object, Stream)
|
||||
).
|
||||
|
||||
json_pair(C0, Stream, Name=Value, Next, Options) :-
|
||||
json_string_as_atom(C0, Stream, Name),
|
||||
ws(Stream, C),
|
||||
C == 0':,
|
||||
json_value(Stream, Value, Next, Options).
|
||||
|
||||
|
||||
json_array(0'], _, [], _) :- !.
|
||||
json_array(C0, Stream, [Value|Tail], Options) :-
|
||||
json_term(C0, Stream, Value, C, Options),
|
||||
ws(C, Stream, Next),
|
||||
( Next == 0',
|
||||
-> ws(Stream, C1),
|
||||
json_array(C1, Stream, Tail, Options)
|
||||
; Next == 0']
|
||||
-> Tail = []
|
||||
).
|
||||
|
||||
codes_to_type(atom, Codes, Atom) :-
|
||||
atom_codes(Atom, Codes).
|
||||
codes_to_type(string, Codes, Atom) :-
|
||||
string_to_list(Atom, Codes).
|
||||
codes_to_type(codes, Codes, Codes).
|
||||
|
||||
json_string_as_atom(0'", Stream, Atom) :-
|
||||
get_code(Stream, C1),
|
||||
json_string_codes(C1, Stream, Codes),
|
||||
atom_codes(Atom, Codes).
|
||||
|
||||
json_string_codes(0'", _, []) :- !.
|
||||
json_string_codes(0'\\, Stream, [H|T]) :- !,
|
||||
get_code(Stream, C0),
|
||||
( escape(C0, Stream, H)
|
||||
-> true
|
||||
; syntax_error(illegal_string_escape, Stream)
|
||||
),
|
||||
get_code(Stream, C1),
|
||||
json_string_codes(C1, Stream, T).
|
||||
json_string_codes(C, Stream, [C|T]) :-
|
||||
get_code(Stream, C1),
|
||||
json_string_codes(C1, Stream, T).
|
||||
|
||||
escape(0'", _, 0'") :- !.
|
||||
escape(0'\\, _, 0'\\) :- !.
|
||||
escape(0'/, _, 0'/) :- !.
|
||||
escape(0'b, _, 0'\b) :- !.
|
||||
escape(0'f, _, 0'\f) :- !.
|
||||
escape(0'n, _, 0'\n) :- !.
|
||||
escape(0'r, _, 0'\r) :- !.
|
||||
escape(0't, _, 0'\t) :- !.
|
||||
escape(0'u, Stream, C) :- !,
|
||||
get_code(Stream, C1),
|
||||
get_code(Stream, C2),
|
||||
get_code(Stream, C3),
|
||||
get_code(Stream, C4),
|
||||
code_type(C1, xdigit(D1)),
|
||||
code_type(C2, xdigit(D2)),
|
||||
code_type(C3, xdigit(D3)),
|
||||
code_type(C4, xdigit(D4)),
|
||||
C is D1<<12+D2<<8+D3<<4+D4.
|
||||
|
||||
json_number_codes(Stream, Codes, Next) :-
|
||||
get_code(Stream, C1),
|
||||
json_number_codes(C1, Stream, Codes, Next).
|
||||
|
||||
json_number_codes(C1, Stream, [C1|Codes], Next) :-
|
||||
number_code(C1), !,
|
||||
get_code(Stream, C2),
|
||||
json_number_codes(C2, Stream, Codes, Next).
|
||||
json_number_codes(C, _, [], C).
|
||||
|
||||
number_code(C) :-
|
||||
between(0'0, 0'9, C), !.
|
||||
number_code(0'.).
|
||||
number_code(0'-).
|
||||
number_code(0'e).
|
||||
number_code(0'E).
|
||||
|
||||
json_identifier_codes(C1, Stream, [C1|T], Next) :-
|
||||
between(0'a, 0'z, C1), !,
|
||||
get_code(Stream, C2),
|
||||
json_identifier_codes(C2, Stream, T, Next).
|
||||
json_identifier_codes(C, _, [], C).
|
||||
|
||||
|
||||
json_constant(true, Constant, Options) :- !,
|
||||
json_options_true(Options, Constant).
|
||||
json_constant(false, Constant, Options) :- !,
|
||||
json_options_false(Options, Constant).
|
||||
json_constant(null, Constant, Options) :- !,
|
||||
json_options_null(Options, Constant).
|
||||
|
||||
%% ws(+Stream, -Next) is det.
|
||||
%% ws(+C0, +Stream, -Next)
|
||||
%
|
||||
% Skip white space on the Stream, returning the first non-ws
|
||||
% character. Also skips =|//|= ... comments.
|
||||
|
||||
ws(Stream, Next) :-
|
||||
get_code(Stream, C0),
|
||||
ws(C0, Stream, Next).
|
||||
|
||||
ws(C0, Stream, C) :-
|
||||
ws(C0), !,
|
||||
get_code(Stream, C1),
|
||||
ws(C1, Stream, C).
|
||||
ws(0'/, Stream, C) :- !,
|
||||
get_code(Stream, Cmt1), !,
|
||||
expect(Cmt1, 0'/, Stream),
|
||||
skip(Stream, 0'\n),
|
||||
get_code(Stream, C).
|
||||
ws(C, _, C).
|
||||
|
||||
ws(0' ).
|
||||
ws(0'\t).
|
||||
ws(0'\n).
|
||||
ws(0'\r).
|
||||
|
||||
expect(C, C, _) :- !.
|
||||
expect(_, 0'/, Stream) :- !,
|
||||
syntax_error(illegal_comment, Stream).
|
||||
|
||||
syntax_error(Message, Stream) :-
|
||||
stream_error_context(Stream, Context),
|
||||
throw(error(syntax_error(json(Message)), Context)).
|
||||
|
||||
stream_error_context(Stream, stream(Stream, Line, LinePos, CharNo)) :-
|
||||
character_count(Stream, CharNo),
|
||||
line_position(Stream, LinePos),
|
||||
line_count(Stream, Line).
|
||||
|
||||
|
||||
/*******************************
|
||||
* JSON OUTPUT *
|
||||
*******************************/
|
||||
|
||||
%% json_write_string(+Stream, +Text) is det.
|
||||
%
|
||||
% Write a JSON string to Stream. Stream must be opened in a
|
||||
% Unicode capable encoding, typically UTF-8.
|
||||
|
||||
% foreign json_write_string/2.
|
||||
|
||||
%% json_write_indent(+Stream, +Indent, +TabDistance) is det.
|
||||
%
|
||||
% Newline and indent to Indent. A Newline is only written if
|
||||
% line_position(Stream, Pos) is not 0. Then it writes Indent //
|
||||
% TabDistance tab characters and Indent mode TabDistance spaces.
|
||||
|
||||
% foreign json_write_indent/3.
|
||||
|
||||
%% json_write(+Stream, +Term) is det.
|
||||
%% json_write(+Stream, +Term, +Options) is det.
|
||||
%
|
||||
% Write a JSON term to Stream. The JSON object is of the same
|
||||
% format as produced by json_read/2, though we allow for some more
|
||||
% flexibility with regard to pairs in objects. All of Name=Value,
|
||||
% Name-Value and Name(Value) produce the same output. In addition
|
||||
% to the options recognised by json_read/3, we process the
|
||||
% following options are recognised:
|
||||
%
|
||||
% * width(+Width)
|
||||
% Width in which we try to format the result. Too long lines
|
||||
% switch from _horizontal_ to _vertical_ layout for better
|
||||
% readability. If performance is critical and human
|
||||
% readability is not an issue use Width = 0, which causes a
|
||||
% single-line output.
|
||||
%
|
||||
% * step(+Step)
|
||||
% Indentation increnment for next level. Default is 2.
|
||||
%
|
||||
% * tab(+TabDistance)
|
||||
% Distance between tab-stops. If equal to Step, layout
|
||||
% is generated with one tab per level.
|
||||
|
||||
:- record json_write_state(indent:nonneg = 0,
|
||||
step:positive_integer = 2,
|
||||
tab:positive_integer = 8,
|
||||
width:nonneg = 72).
|
||||
|
||||
json_write(Stream, Term) :-
|
||||
json_write(Stream, Term, []).
|
||||
json_write(Stream, Term, Options) :-
|
||||
make_json_write_state(Options, State, Options1),
|
||||
make_json_options(Options1, OptionTerm, _RestOptions),
|
||||
json_write_term(Term, Stream, State, OptionTerm).
|
||||
|
||||
json_write_term(Var, _, _, _) :-
|
||||
var(Var), !,
|
||||
instantiation_error(Var).
|
||||
json_write_term(json(Pairs), Stream, State, Options) :- !,
|
||||
space_if_not_at_left_margin(Stream),
|
||||
write(Stream, '{'),
|
||||
( json_write_state_width(State, Width),
|
||||
( Width == 0
|
||||
-> true
|
||||
; json_write_state_indent(State, Indent),
|
||||
json_print_length(json(Pairs), Options, Width, Indent, _)
|
||||
)
|
||||
-> set_width_of_json_write_state(0, State, State2),
|
||||
write_pairs_hor(Pairs, Stream, State2, Options),
|
||||
write(Stream, '}')
|
||||
; step_indent(State, State2),
|
||||
write_pairs_ver(Pairs, Stream, State2, Options),
|
||||
indent(Stream, State),
|
||||
write(Stream, '}')
|
||||
).
|
||||
json_write_term(List, Stream, State, Options) :-
|
||||
is_list(List), !,
|
||||
space_if_not_at_left_margin(Stream),
|
||||
write(Stream, '['),
|
||||
( json_write_state_width(State, Width),
|
||||
( Width == 0
|
||||
-> true
|
||||
; json_write_state_indent(State, Indent),
|
||||
json_print_length(List, Options, Width, Indent, _)
|
||||
)
|
||||
-> set_width_of_json_write_state(0, State, State2),
|
||||
write_array_hor(List, Stream, State2, Options),
|
||||
write(Stream, ']')
|
||||
; step_indent(State, State2),
|
||||
write_array_ver(List, Stream, State2, Options),
|
||||
indent(Stream, State),
|
||||
write(Stream, ']')
|
||||
).
|
||||
json_write_term(Number, Stream, _State, _Options) :-
|
||||
number(Number), !,
|
||||
write(Stream, Number).
|
||||
json_write_term(True, Stream, _State, Options) :-
|
||||
json_options_true(Options, True), !,
|
||||
write(Stream, true).
|
||||
json_write_term(False, Stream, _State, Options) :-
|
||||
json_options_false(Options, False), !,
|
||||
write(Stream, false).
|
||||
json_write_term(Null, Stream, _State, Options) :-
|
||||
json_options_null(Options, Null), !,
|
||||
write(Stream, null).
|
||||
json_write_term(String, Stream, _State, _Options) :-
|
||||
json_write_string(Stream, String).
|
||||
|
||||
write_pairs_hor([], _, _, _).
|
||||
write_pairs_hor([H|T], Stream, State, Options) :-
|
||||
json_pair(H, Name, Value),
|
||||
json_write_string(Stream, Name),
|
||||
write(Stream, ':'),
|
||||
json_write_term(Value, Stream, State, Options),
|
||||
( T == []
|
||||
-> true
|
||||
; write(Stream, ', '),
|
||||
write_pairs_hor(T, Stream, State, Options)
|
||||
).
|
||||
|
||||
write_pairs_ver([], _, _, _).
|
||||
write_pairs_ver([H|T], Stream, State, Options) :-
|
||||
indent(Stream, State),
|
||||
json_pair(H, Name, Value),
|
||||
json_write_string(Stream, Name),
|
||||
write(Stream, ':'),
|
||||
json_write_term(Value, Stream, State, Options),
|
||||
( T == []
|
||||
-> true
|
||||
; write(Stream, ','),
|
||||
write_pairs_ver(T, Stream, State, Options)
|
||||
).
|
||||
|
||||
|
||||
json_pair(Var, _, _) :-
|
||||
var(Var), !,
|
||||
instantiation_error(Var).
|
||||
json_pair(Name=Value, Name, Value) :- !.
|
||||
json_pair(Name-Value, Name, Value) :- !.
|
||||
json_pair(NameValue, Name, Value) :-
|
||||
compound(NameValue),
|
||||
NameValue =.. [Name, Value], !.
|
||||
json_pair(Pair, _, _) :-
|
||||
type_error(json_pair, Pair).
|
||||
|
||||
|
||||
write_array_hor([], _, _, _).
|
||||
write_array_hor([H|T], Stream, State, Options) :-
|
||||
json_write_term(H, Stream, State, Options),
|
||||
( T == []
|
||||
-> true
|
||||
; write(Stream, ', '),
|
||||
write_array_hor(T, Stream, State, Options)
|
||||
).
|
||||
|
||||
write_array_ver([], _, _, _).
|
||||
write_array_ver([H|T], Stream, State, Options) :-
|
||||
indent(Stream, State),
|
||||
json_write_term(H, Stream, State, Options),
|
||||
( T == []
|
||||
-> true
|
||||
; write(Stream, ','),
|
||||
write_array_ver(T, Stream, State, Options)
|
||||
).
|
||||
|
||||
|
||||
indent(Stream, State) :-
|
||||
json_write_state_indent(State, Indent),
|
||||
json_write_state_tab(State, Tab),
|
||||
json_write_indent(Stream, Indent, Tab).
|
||||
|
||||
step_indent(State0, State) :-
|
||||
json_write_state_indent(State0, Indent),
|
||||
json_write_state_step(State0, Step),
|
||||
NewIndent is Indent+Step,
|
||||
set_indent_of_json_write_state(NewIndent, State0, State).
|
||||
|
||||
space_if_not_at_left_margin(Stream) :-
|
||||
line_position(Stream, 0), !.
|
||||
space_if_not_at_left_margin(Stream) :-
|
||||
put_char(Stream, ' ').
|
||||
|
||||
|
||||
%% json_print_length(+Value, +Options, +Max, +Len0, +Len) is semidet.
|
||||
%
|
||||
% True if Len-Len0 is the print-length of Value on a single line
|
||||
% and Len-Len0 =< Max.
|
||||
%
|
||||
% @tbd Escape sequences in strings are not considered.
|
||||
|
||||
json_print_length(json(Pairs), Options, Max, Len0, Len) :- !,
|
||||
Len1 is Len0 + 2,
|
||||
Len1 =< Max,
|
||||
pairs_print_length(Pairs, Options, Max, Len1, Len).
|
||||
json_print_length(Array, Options, Max, Len0, Len) :-
|
||||
is_list(Array), !,
|
||||
Len1 is Len0 + 2,
|
||||
Len1 =< Max,
|
||||
array_print_length(Array, Options, Max, Len1, Len).
|
||||
json_print_length(Null, Options, Max, Len0, Len) :-
|
||||
json_options_null(Options, Null), !,
|
||||
Len is Len0 + 4,
|
||||
Len =< Max.
|
||||
json_print_length(False, Options, Max, Len0, Len) :-
|
||||
json_options_false(Options, False), !,
|
||||
Len is Len0 + 5,
|
||||
Len =< Max.
|
||||
json_print_length(True, Options, Max, Len0, Len) :-
|
||||
json_options_true(Options, True), !,
|
||||
Len is Len0 + 4,
|
||||
Len =< Max.
|
||||
json_print_length(Number, _Options, Max, Len0, Len) :-
|
||||
number(Number), !,
|
||||
atom_length(Number, AL),
|
||||
Len is Len0 + AL,
|
||||
Len =< Max.
|
||||
json_print_length(@(Id), _Options, Max, Len0, Len) :- !,
|
||||
atom_length(Id, IdLen),
|
||||
Len is Len0+IdLen,
|
||||
Len =< Max.
|
||||
json_print_length(String, _Options, Max, Len0, Len) :-
|
||||
string_len(String, Len0, Len),
|
||||
Len =< Max.
|
||||
|
||||
pairs_print_length([], _, _, Len, Len).
|
||||
pairs_print_length([H|T], Options, Max, Len0, Len) :-
|
||||
pair_len(H, Options, Max, Len0, Len1),
|
||||
( T == []
|
||||
-> Len = Len1
|
||||
; Len2 is Len1 + 2,
|
||||
Len2 =< Max,
|
||||
pairs_print_length(T, Options, Max, Len2, Len)
|
||||
).
|
||||
|
||||
pair_len(Name=Value, Options, Max, Len0, Len) :-
|
||||
string_len(Name, Len0, Len1),
|
||||
Len2 is Len1+2,
|
||||
Len2 =< Max,
|
||||
json_print_length(Value, Options, Max, Len2, Len).
|
||||
|
||||
array_print_length([], _, _, Len, Len).
|
||||
array_print_length([H|T], Options, Max, Len0, Len) :-
|
||||
json_print_length(H, Options, Max, Len0, Len1),
|
||||
( T == []
|
||||
-> Len = Len1
|
||||
; Len2 is Len1+2,
|
||||
Len2 =< Max,
|
||||
array_print_length(T, Options, Max, Len2, Len)
|
||||
).
|
||||
|
||||
string_len(String, Len0, Len) :-
|
||||
atom_length(String, AL),
|
||||
Len is Len0 + AL + 2.
|
||||
|
||||
|
||||
/*******************************
|
||||
* TEST *
|
||||
*******************************/
|
||||
|
||||
%% is_json_term(@Term) is semidet.
|
||||
%% is_json_term(@Term, +Options) is semidet.
|
||||
%
|
||||
% True if Term is a json term. Options are the same as for
|
||||
% json_read/2, defining the Prolog representation for the JSON
|
||||
% =true=, =false= and =null= constants.
|
||||
|
||||
is_json_term(Term) :-
|
||||
default_json_options(Options),
|
||||
is_json_term2(Options, Term).
|
||||
|
||||
is_json_term(Term, Options) :-
|
||||
make_json_options(Options, OptionTerm, _RestOptions),
|
||||
is_json_term2(OptionTerm, Term).
|
||||
|
||||
is_json_term2(_, Var) :-
|
||||
var(Var), !, fail.
|
||||
is_json_term2(Options, json(Pairs)) :- !,
|
||||
is_list(Pairs),
|
||||
maplist(is_json_pair(Options), Pairs).
|
||||
is_json_term2(Options, List) :-
|
||||
is_list(List), !,
|
||||
maplist(is_json_term2(Options), List).
|
||||
is_json_term2(_, Primitive) :-
|
||||
atomic(Primitive), !. % atom, string or number
|
||||
is_json_term2(Options, True) :-
|
||||
json_options_true(Options, True).
|
||||
is_json_term2(Options, False) :-
|
||||
json_options_false(Options, False).
|
||||
is_json_term2(Options, Null) :-
|
||||
json_options_null(Options, Null).
|
||||
|
||||
is_json_pair(_, Var) :-
|
||||
var(Var), !, fail.
|
||||
is_json_pair(Options, Name=Value) :-
|
||||
atom(Name),
|
||||
is_json_term2(Options, Value).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:error_message/3.
|
||||
|
||||
prolog:error_message(syntax_error(json(Id))) -->
|
||||
[ 'JSON syntax error: ' ],
|
||||
json_syntax_error(Id).
|
||||
|
||||
json_syntax_error(illegal_comment) -->
|
||||
[ 'Illegal comment' ].
|
||||
json_syntax_error(illegal_string_escape) -->
|
||||
[ 'Illegal escape sequence in string' ].
|
||||
30
packages/http/json.txt
Normal file
30
packages/http/json.txt
Normal file
@ -0,0 +1,30 @@
|
||||
---+ [json] Supporting JSON
|
||||
|
||||
From http://json.org, "
|
||||
JSON (JavaScript Object Notation) is a lightweight data-interchange
|
||||
format. It is easy for humans to read and write. It is easy for machines
|
||||
to parse and generate. It is based on a subset of the JavaScript
|
||||
Programming Language, Standard ECMA-262 3rd Edition - December 1999.
|
||||
JSON is a text format that is completely language independent but uses
|
||||
conventions that are familiar to programmers of the C-family of
|
||||
languages, including C, C++, C#, Java, JavaScript, Perl, Python, and
|
||||
many others. These properties make JSON an ideal data-interchange
|
||||
language."
|
||||
|
||||
JSON is interesting to Prolog because using AJAX web technology we can
|
||||
easily created web-enabled user interfaces where we implement the server
|
||||
side using the SWI-Prolog HTTP services provided by this package.
|
||||
The interface consists of three libraries:
|
||||
|
||||
* library(http/json) provides support for the core JSON object
|
||||
serialization.
|
||||
* library(http/json_convert) converts between the primary
|
||||
representation of JSON terms in Prolog and more application
|
||||
oriented Prolog terms. E.g. point(X,Y) vs. object([x=X,y=Y]).
|
||||
* library(http/http_json) hooks the conversion libraries into
|
||||
the HTTP client and server libraries.
|
||||
|
||||
[[json.pl]]
|
||||
[[json_convert.pl]]
|
||||
[[http_json.pl]]
|
||||
|
||||
548
packages/http/json_convert.pl
Normal file
548
packages/http/json_convert.pl
Normal file
@ -0,0 +1,548 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2007, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(json_convert,
|
||||
[ prolog_to_json/2, % :Term, -JSON object
|
||||
json_to_prolog/2, % +JSON, :Term
|
||||
(json_object)/1, % +Definition
|
||||
op(1150, fx, (json_object))
|
||||
]).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(json).
|
||||
|
||||
:- meta_predicate
|
||||
prolog_to_json(:, -),
|
||||
json_to_prolog(+, :).
|
||||
|
||||
/** <module> Convert between JSON terms and Prolog application terms
|
||||
|
||||
The idea behind this module is to provide a flexible high-level mapping
|
||||
between Prolog terms as you would like to see them in your application
|
||||
and the standard representation of a JSON object as a Prolog term. For
|
||||
example, an X-Y point may be represented in JSON as =|{"x":25,
|
||||
"y":50}|=. Represented in Prolog this becomes json([x=25,y=50]), but
|
||||
this is a pretty non-natural representation from the Prolog point of
|
||||
view.
|
||||
|
||||
This module allows for defining records (just like library(record)) that
|
||||
provide transparent two-way transformation between the two
|
||||
representations.
|
||||
|
||||
==
|
||||
:- json_object
|
||||
point(x:integer, y:integer).
|
||||
==
|
||||
|
||||
This declaration causes prolog_to_json/2 to translate the native Prolog
|
||||
representation into a JSON Term:
|
||||
|
||||
==
|
||||
?- prolog_to_json(point(25,50), X).
|
||||
|
||||
X = json([x=25, y=50])
|
||||
==
|
||||
|
||||
A json_object/1 declaration can define multiple objects separated by a
|
||||
comma (,), similar to the dynamic/1 directive. Optionally, a declaration
|
||||
can be qualified using a module. The converstion predicates
|
||||
prolog_to_json/2 and json_to_prolog/2 first try a conversion associated
|
||||
with the calling module. If not successful, they try conversions
|
||||
associated with the module =user=.
|
||||
|
||||
JSON objects have no _type_. This can be solved by adding an extra field
|
||||
to the JSON object, e.g. =|{"type":"point", "x":25, "y":50}|=. As Prolog
|
||||
records are typed by their functor we need some notation to handle this
|
||||
gracefully. This is achieved by adding +Fields to the declaration. I.e.
|
||||
|
||||
==
|
||||
:- json_object
|
||||
point(x:integer, y:integer) + [type=point].
|
||||
==
|
||||
|
||||
Using this declaration, the conversion becomes:
|
||||
|
||||
==
|
||||
?- prolog_to_json(point(25,50), X).
|
||||
|
||||
X = json([x=25, y=50, type=point])
|
||||
==
|
||||
|
||||
The predicate json_to_prolog/2 is often used after http_read_json/2 and
|
||||
prolog_to_json/2 before reply_json/1. For now we consider them seperate
|
||||
predicates because the transformation may be too general, too slow or
|
||||
not needed for dedicated applications. Using a seperate step also
|
||||
simplifies debugging this rather complicated process.
|
||||
|
||||
@tbd Ignore extra fields. Using a partial list of _extra_?
|
||||
@tbd Consider a sensible default for handling JSON =null=. Conversion
|
||||
to Prolog could translate @null into a variable if the desired type
|
||||
is not =any=. Conversion to JSON could map variables to =null=,
|
||||
though this may be unsafe. If the Prolog term is known to be
|
||||
non-ground and JSON @null is a sensible mapping, we can also use
|
||||
this simple snipit to deal with that fact.
|
||||
|
||||
==
|
||||
term_variables(Term, Vars),
|
||||
maplist(=(@null), Vars).
|
||||
==
|
||||
*/
|
||||
|
||||
%% current_json_object(Term, Module, Fields)
|
||||
%
|
||||
% Multifile predicate computed from the json_object/1
|
||||
% declarations. Term is the most general Prolog term representing
|
||||
% the object. Module is the module in which the object is defined
|
||||
% and Fields is a list of f(Name, Type, Var), sorted by Name. Var
|
||||
% is the corresponding variable in Term.
|
||||
|
||||
:- multifile
|
||||
json_object_to_pairs/3, % Term, Module, Pairs
|
||||
current_json_object/3. % Term, Module, Fields
|
||||
|
||||
%% json_object(+Declaration)
|
||||
%
|
||||
% Declare a JSON object. The declaration takes the same format as
|
||||
% using in record/1 from library(record). E.g.
|
||||
%
|
||||
% ==
|
||||
% ?- json_object
|
||||
% point(x:int, y:int, z:int=0).
|
||||
% ==
|
||||
|
||||
json_object(Declaration) :-
|
||||
throw(error(context_error(nodirective, json_object(Declaration)), _)).
|
||||
|
||||
|
||||
%% compile_json_objects(+Spec, -Clauses) is det.
|
||||
%
|
||||
% Compiles a :- json_object directive into Clauses. Clauses are of
|
||||
% the form:
|
||||
%
|
||||
% ==
|
||||
% json_object_to_pairs(Term, Module, Pairs) :-
|
||||
% <type-checks on Term>,
|
||||
% <make Pairs from Term>.
|
||||
% ==
|
||||
|
||||
compile_json_objects(Spec, Clauses) :-
|
||||
phrase(compile_objects(Spec), Clauses).
|
||||
|
||||
compile_objects(A) -->
|
||||
{ var(A), !,
|
||||
instantiation_error(A)
|
||||
}.
|
||||
compile_objects((A,B)) --> !,
|
||||
compile_objects(A),
|
||||
compile_objects(B).
|
||||
compile_objects(Term) -->
|
||||
compile_object(Term).
|
||||
|
||||
compile_object(ObjectDef) -->
|
||||
{ prolog_load_context(module, CM),
|
||||
strip_module(CM:ObjectDef, M, Def),
|
||||
extra_defs(Def, Term, ExtraFields),
|
||||
Term =.. [Constructor|Args],
|
||||
defaults(Args, _Defs, TypedArgs),
|
||||
types(TypedArgs, Names, Types)
|
||||
},
|
||||
record_to_json_clause(Constructor, M, Types, Names, ExtraFields),
|
||||
current_clause(Constructor, M, Types, Names, ExtraFields),
|
||||
[ (:- json_convert:clear_cache) ].
|
||||
|
||||
extra_defs(Term+Extra0, Term, Extra) :- !,
|
||||
must_be(list, Extra0),
|
||||
maplist(canonical_pair, Extra0, Extra).
|
||||
extra_defs(Term, Term, []).
|
||||
|
||||
|
||||
canonical_pair(Var, _) :-
|
||||
var(Var), !,
|
||||
instantiation_error(Var).
|
||||
canonical_pair(Name=Value, Name=Value) :- !,
|
||||
must_be(atom, Name).
|
||||
canonical_pair(Name-Value, Name=Value) :- !,
|
||||
must_be(atom, Name).
|
||||
canonical_pair(NameValue, Name=Value) :-
|
||||
NameValue =.. [Name,Value], !.
|
||||
canonical_pair(Pair, _) :-
|
||||
type_error(pair, Pair).
|
||||
|
||||
|
||||
%% record_to_json_clause(+Constructor, +Module, +Type, +Names)
|
||||
%
|
||||
% Create a clause translating the record definition into a pairs
|
||||
% representation.
|
||||
|
||||
record_to_json_clause(Constructor, Module, Types, Names, Extra) -->
|
||||
{ type_checks(Types, VarsHead, VarsBody, Body0, Module),
|
||||
clean_body(Body0, Body),
|
||||
Term =.. [Constructor|VarsHead],
|
||||
make_pairs(Names, VarsBody, Pairs, Extra),
|
||||
Head =.. [json_object_to_pairs,Term,Module,json(Pairs)]
|
||||
},
|
||||
[ (json_convert:(Head :- Body)) ].
|
||||
|
||||
|
||||
%% type_checks(+Types, -VarsIn, -VarsOut, -Goal, +Module) is det.
|
||||
%
|
||||
% Goal is a body-term that validates Vars satisfy Types. In
|
||||
% addition to the types accepted by must_be/2, it accepts =any=
|
||||
% and Name/Arity. The latter demands a json_object term of the
|
||||
% given Name and Arity.
|
||||
%
|
||||
% @tbd Compile list(Type) specification. Currently Type is
|
||||
% handled like =any=
|
||||
|
||||
type_checks([], [], [], true, _).
|
||||
type_checks([Type|T], [IV|IVars], [OV|OVars], (Goal, Body), M) :- !,
|
||||
type_check(Type, IV, OV, M, Goal),
|
||||
type_checks(T, IVars, OVars, Body, M).
|
||||
|
||||
type_check(any, IV, OV, M, prolog_to_json(IV, OV, M)) :- !.
|
||||
type_check(Name/Arity, IV, OV, M, prolog_to_json(IV, OV, M)) :- !,
|
||||
functor(IV, Name, Arity).
|
||||
type_check(boolean, IV, OV, _, prolog_bool_to_json(IV, OV)) :- !.
|
||||
type_check(list, IV, OV, M, prolog_list_to_json(IV, OV, M)) :- !.
|
||||
type_check(list(any), IV, OV, M, prolog_list_to_json(IV, OV, M)) :- !.
|
||||
type_check(list(_Type), IV, OV, M, prolog_list_to_json(IV, OV, M)) :- !.
|
||||
type_check(Type, V, V, _, Goal) :-
|
||||
type_goal(Type, V, Goal).
|
||||
|
||||
|
||||
%% prolog_bool_to_json(+Prolog, -JSON) is semidet.
|
||||
%
|
||||
% JSON is the JSON boolean for Prolog. It is a flexible the Prolog
|
||||
% notation for thruth-value, accepting one of =true=, =on= or =1=
|
||||
% for @true and one of =false=, =fail=, =off= or =0= for @false.
|
||||
%
|
||||
% @error instantiation_error if Prolog is unbound.
|
||||
|
||||
prolog_bool_to_json(Var, _) :-
|
||||
var(Var),
|
||||
instantiation_error(Var).
|
||||
prolog_bool_to_json(true, @(true)).
|
||||
prolog_bool_to_json(false, @(false)).
|
||||
prolog_bool_to_json(fail, @(false)).
|
||||
prolog_bool_to_json(0, @(false)).
|
||||
prolog_bool_to_json(on, @(true)).
|
||||
prolog_bool_to_json(off, @(false)).
|
||||
prolog_bool_to_json(1, @(false)).
|
||||
prolog_bool_to_json(@(True), True) :-
|
||||
prolog_bool_to_json(True, True).
|
||||
|
||||
|
||||
%% type_goal(+Type, +Var, -BodyTerm) is det.
|
||||
%
|
||||
% Inline type checking calls.
|
||||
|
||||
type_goal(Type, Var, Body) :-
|
||||
clause(error:has_type(Type, Var), Body),
|
||||
primitive(Body), !.
|
||||
type_goal(Type, Var, is_of_type(Type, Var)).
|
||||
|
||||
primitive((A,B)) :- !,
|
||||
primitive(A),
|
||||
primitive(B).
|
||||
primitive((A;B)) :- !,
|
||||
primitive(A),
|
||||
primitive(B).
|
||||
primitive((A->B)) :- !,
|
||||
primitive(A),
|
||||
primitive(B).
|
||||
primitive(G) :-
|
||||
predicate_property(system:G, built_in).
|
||||
|
||||
|
||||
%% clean_body(+BodyIn, -BodyOut) is det.
|
||||
%
|
||||
% Cleanup a body goal. Eliminate redundant =true= statements and
|
||||
% perform partial evaluation on some commonly constructs that are
|
||||
% generated from the has_type/2 clauses in library(error).
|
||||
|
||||
clean_body(Var, Var) :-
|
||||
var(Var), !.
|
||||
clean_body((A0,B0), G) :- !,
|
||||
clean_body(A0, A),
|
||||
clean_body(B0, B),
|
||||
conj(A, B, G).
|
||||
clean_body(ground(X), true) :- % Generated from checking extra fields.
|
||||
ground(X), !.
|
||||
clean_body(memberchk(V, Values), true) :- % generated from oneof(List)
|
||||
ground(V), ground(Values),
|
||||
memberchk(V, Values), !.
|
||||
clean_body((integer(Low) -> If ; Then), Goal) :- % generated from between(Low,High)
|
||||
number(Low), !,
|
||||
( integer(Low)
|
||||
-> Goal = If
|
||||
; Goal = Then
|
||||
).
|
||||
clean_body(A, A).
|
||||
|
||||
conj(T, A, A) :- T == true, !.
|
||||
conj(A, T, A) :- T == true, !.
|
||||
conj(A, B, (A,B)).
|
||||
|
||||
make_pairs([], [], L, L).
|
||||
make_pairs([N|TN], [V|TV], [N=V|T], Tail) :-
|
||||
make_pairs(TN, TV, T, Tail).
|
||||
|
||||
%% current_clause(+Constructor, +Module, +Type, +Names)
|
||||
%
|
||||
% Create the clause current_json_object/3.
|
||||
|
||||
current_clause(Constructor, Module, Types, Names, Extra) -->
|
||||
{ length(Types, Arity),
|
||||
functor(Term, Constructor, Arity),
|
||||
extra_fields(Extra, EF),
|
||||
Term =.. [_|Vars],
|
||||
mk_fields(Names, Types, Vars, Fields0, EF),
|
||||
sort(Fields0, Fields),
|
||||
Head =.. [current_json_object, Term, Module, Fields]
|
||||
},
|
||||
[ json_convert:Head ].
|
||||
|
||||
extra_fields([], []).
|
||||
extra_fields([Name=Value|T0], [f(Name, oneof([Value]), Value)|T]) :-
|
||||
extra_fields(T0, T).
|
||||
|
||||
mk_fields([], [], [], Fields, Fields).
|
||||
mk_fields([Name|TN], [Type|TT], [Var|VT], [f(Name, Type, Var)|T], Tail) :-
|
||||
mk_fields(TN, TT, VT, T, Tail).
|
||||
|
||||
|
||||
/* The code below is copied from library(record) */
|
||||
|
||||
%% defaults(+ArgsSpecs, -Defaults, -Args)
|
||||
%
|
||||
% Strip the default specification from the argument specification.
|
||||
|
||||
defaults([], [], []).
|
||||
defaults([Arg=Default|T0], [Default|TD], [Arg|TA]) :- !,
|
||||
defaults(T0, TD, TA).
|
||||
defaults([Arg|T0], [_|TD], [Arg|TA]) :-
|
||||
defaults(T0, TD, TA).
|
||||
|
||||
|
||||
%% types(+ArgsSpecs, -Defaults, -Args)
|
||||
%
|
||||
% Strip the default specification from the argument specification.
|
||||
|
||||
types([], [], []).
|
||||
types([Name:Type|T0], [Name|TN], [Type|TT]) :- !,
|
||||
must_be(atom, Name),
|
||||
types(T0, TN, TT).
|
||||
types([Name|T0], [Name|TN], [any|TT]) :-
|
||||
must_be(atom, Name),
|
||||
types(T0, TN, TT).
|
||||
|
||||
|
||||
/*******************************
|
||||
* PROLOG --> JSON *
|
||||
*******************************/
|
||||
|
||||
%% prolog_to_json(:Term, -JSONObject) is det.
|
||||
%
|
||||
% Translate a Prolog application Term into a JSON object term.
|
||||
% This transformation is based on :- json_object/1 declarations.
|
||||
% If a json_object/1 declaration declares a field of type
|
||||
% =boolean=, commonly used thruth-values in Prolog are converted
|
||||
% to JSON booleans. Boolean translation accepts one of =true=,
|
||||
% =on=, =1=, @true, =false=, =fail=, =off= or =0=, @false.
|
||||
%
|
||||
% @error type_error(json_term, X)
|
||||
% @error instantiation_error
|
||||
|
||||
prolog_to_json(Module:Term, JSON) :-
|
||||
prolog_to_json(Term, JSON, Module).
|
||||
|
||||
prolog_to_json(Var, _, _) :-
|
||||
var(Var), !,
|
||||
instantiation_error(Var).
|
||||
prolog_to_json(Atomic, Atomic, _) :-
|
||||
atomic(Atomic), !.
|
||||
prolog_to_json(List, JSON, Module) :-
|
||||
is_list(List), !,
|
||||
prolog_list_to_json(List, JSON, Module).
|
||||
prolog_to_json(Record, JSON, Module) :-
|
||||
record_to_pairs(Record, JSON, Module), !.
|
||||
prolog_to_json(Term, Term, _) :-
|
||||
is_json_term(Term), !.
|
||||
prolog_to_json(Term, _, _) :-
|
||||
type_error(json_term, Term).
|
||||
|
||||
record_to_pairs(T, _, _) :-
|
||||
var(T), !,
|
||||
instantiation_error(T).
|
||||
record_to_pairs(T, JSON, M) :-
|
||||
object_module(M, Module),
|
||||
json_object_to_pairs(T, Module, JSON), !.
|
||||
|
||||
object_module(user, user) :- !.
|
||||
object_module(M, M).
|
||||
object_module(_, user).
|
||||
|
||||
prolog_list_to_json([], [], _).
|
||||
prolog_list_to_json([H0|T0], [H|T], M) :-
|
||||
prolog_to_json(H0, H, M),
|
||||
prolog_list_to_json(T0, T, M).
|
||||
|
||||
|
||||
/*******************************
|
||||
* JSON --> PROLOG *
|
||||
*******************************/
|
||||
|
||||
:- dynamic
|
||||
json_to_prolog_rule/3, % Module, Pairs, Term
|
||||
created_rules_for_pairs/2. % Module, Pairs
|
||||
|
||||
clear_cache :-
|
||||
retractall(json_to_prolog_rule(_,_,_)),
|
||||
retractall(created_rules_for_pairs(_,_)).
|
||||
|
||||
:- clear_cache.
|
||||
|
||||
%% json_to_prolog(+JSON, -Term) is det.
|
||||
%
|
||||
% Translate a JSON term into an application term. This
|
||||
% transformation is based on :- json_object/1 declarations. An
|
||||
% efficient transformation is non-trivial, but we rely on the
|
||||
% assumption that, although the order of fields in JSON terms is
|
||||
% irrelevant and can therefore vary a lot, practical applications
|
||||
% will normally generate the JSON objects in a consistent order.
|
||||
%
|
||||
% If a field in a json_object is declared of type =boolean=, @true
|
||||
% and @false are translated to =true= or =false=, the most
|
||||
% commonly used Prolog representation for truth-values.
|
||||
|
||||
json_to_prolog(JSON, Module:Term) :-
|
||||
json_to_prolog(JSON, Term, Module).
|
||||
|
||||
json_to_prolog(json(Pairs), Term, Module) :- !,
|
||||
( pairs_to_term(Pairs, Term, Module)
|
||||
-> true
|
||||
; json_pairs_to_prolog(Pairs, Prolog, Module),
|
||||
Term = json(Prolog)
|
||||
).
|
||||
json_to_prolog(List, Prolog, Module) :-
|
||||
is_list(List), !,
|
||||
json_list_to_prolog(List, Prolog, Module).
|
||||
json_to_prolog(@(Special), @(Special), _).
|
||||
json_to_prolog(Atomic, Atomic, _).
|
||||
|
||||
json_pairs_to_prolog([], [], _).
|
||||
json_pairs_to_prolog([Name=JSONValue|T0], [Name=PrologValue|T], Module) :-
|
||||
json_to_prolog(JSONValue, PrologValue, Module),
|
||||
json_pairs_to_prolog(T0, T, Module).
|
||||
|
||||
json_list_to_prolog([], [], _).
|
||||
json_list_to_prolog([JSONValue|T0], [PrologValue|T], Module) :-
|
||||
json_to_prolog(JSONValue, PrologValue, Module),
|
||||
json_list_to_prolog(T0, T, Module).
|
||||
|
||||
|
||||
%% json_object_to_prolog(+JSONObject, ?Term, +Module) is semidet.
|
||||
%
|
||||
% Translate a JSON json(Pairs) term into a Prolog application term.
|
||||
|
||||
json_object_to_prolog(json(Pairs), Term, Module) :-
|
||||
pairs_to_term(Pairs, Term, Module).
|
||||
|
||||
|
||||
%% pairs_to_term(+Pairs, ?Term, +Module) is semidet.
|
||||
%
|
||||
% Convert a Name=Value set into a Prolog application term based on
|
||||
% json_object/1 declarations.
|
||||
%
|
||||
% @tbd Ignore extra pairs if term is partially given?
|
||||
|
||||
pairs_to_term(Pairs, Term, Module) :-
|
||||
object_module(Module, M),
|
||||
( json_to_prolog_rule(M, Pairs, Term)
|
||||
-> !
|
||||
; created_rules_for_pairs(M, Pairs)
|
||||
-> !, fail
|
||||
; pairs_args(Pairs, PairArgs),
|
||||
sort(PairArgs, SortedPairArgs),
|
||||
forall(create_rule(SortedPairArgs, Module, M, Term0, Body),
|
||||
asserta((json_to_prolog_rule(M, PairArgs, Term0) :- Body))),
|
||||
asserta(created_rules_for_pairs(M, PairArgs)),
|
||||
json_to_prolog_rule(M, Pairs, Term), !
|
||||
).
|
||||
|
||||
pairs_args([], []).
|
||||
pairs_args([Name=_Value|T0], [Name=_|T]) :-
|
||||
pairs_args(T0, T).
|
||||
|
||||
%% create_rule(+PairArgs, +Vars, -Term, -Body) is det.
|
||||
%
|
||||
% Create a new rule for dealing with Pairs, a Name=Value list of a
|
||||
% particular order. Here is an example rule:
|
||||
%
|
||||
% ==
|
||||
% json_to_prolog_rule([x=X, y=Y], point(X,Y)) :-
|
||||
% integer(X),
|
||||
% integer(Y).
|
||||
% ==
|
||||
|
||||
create_rule(PairArgs, Module, M, Term, Body) :-
|
||||
current_json_object(Term, M, Fields),
|
||||
match_fields(PairArgs, Fields, Body0, Module),
|
||||
clean_body(Body0, Body).
|
||||
|
||||
match_fields([], [], true, _).
|
||||
match_fields([Name=JSON|TP], [f(Name, Type, Prolog)|TF], (Goal,Body), M) :- !,
|
||||
match_field(Type, JSON, Prolog, M, Goal),
|
||||
match_fields(TP, TF, Body, M).
|
||||
|
||||
match_field(any, JSON, Prolog, M, json_to_prolog(JSON,Prolog,M)) :- !.
|
||||
match_field(F/A, JSON, Prolog, M, json_to_prolog(JSON,Prolog,M)) :- !,
|
||||
functor(Prolog, F, A).
|
||||
match_field(boolean, JSON, Prolog, _, json_bool_to_prolog(JSON, Prolog)) :- !.
|
||||
match_field(list(Type), JSON, Prolog, M, json_list_to_prolog(JSON, Prolog, M)) :-
|
||||
current_json_object(Term, M, _Fields),
|
||||
functor(Term, Type, _), !.
|
||||
match_field(Type, Var, Var, _, Goal) :-
|
||||
type_goal(Type, Var, Goal).
|
||||
|
||||
json_bool_to_prolog(@(True), True).
|
||||
|
||||
|
||||
/*******************************
|
||||
* EXPANSION *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
system:term_expansion/2.
|
||||
:- dynamic
|
||||
system:term_expansion/2.
|
||||
|
||||
system:term_expansion((:- json_object(Spec)), Clauses) :-
|
||||
compile_json_objects(Spec, Clauses).
|
||||
146
packages/http/mimepack.pl
Normal file
146
packages/http/mimepack.pl
Normal file
@ -0,0 +1,146 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2002, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(mime_pack,
|
||||
[ mime_pack/3 % +Input, +Stream, ?Boundary
|
||||
]).
|
||||
:- use_module(mimetype).
|
||||
:- use_module(html_write).
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
Simple and partial implementation of MIME encoding. MIME is covered by
|
||||
RFC 2045 which I've read from
|
||||
|
||||
http://www.cis.ohio-state.edu/cgi-bin/rfc/rfc2045.html
|
||||
|
||||
MIME decoding is now arranged through library(mime) from the clib
|
||||
package, based on the external librfc2045 library. Most likely the
|
||||
functionality of this package will be moved to the same library someday.
|
||||
Packing however is a lot simpler then parsing.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
%% mime_pack(+Inputs, +Out:stream, ?Boundary) is det.
|
||||
%
|
||||
% Pack a number of inputs into a MIME package using a specified or
|
||||
% generated boundary. The generated boundary consists of the
|
||||
% current time in seconds since the epoch and 10 random
|
||||
% hexadecimal numbers.
|
||||
%
|
||||
% @bug Does not validate that the boundary is unique.
|
||||
|
||||
mime_pack(Inputs, OutputStream, Boundary) :-
|
||||
make_boundary(Inputs, Boundary),
|
||||
pack_list(Inputs, OutputStream, Boundary).
|
||||
|
||||
pack_list([], Out, Boundary) :-
|
||||
format(Out, '--~w--\r\n', [Boundary]).
|
||||
pack_list([H|T], Out, Boundary) :-
|
||||
format(Out, '--~w\r\n', [Boundary]),
|
||||
pack(H, Out),
|
||||
format(Out, '\r\n', []),
|
||||
pack_list(T, Out, Boundary).
|
||||
|
||||
pack(X, _Out) :-
|
||||
var(X), !,
|
||||
throw(error(instantiation_error, _)).
|
||||
pack(Name=Value, Out) :- !,
|
||||
( Value = file(FileName)
|
||||
-> format(Out, 'Content-Disposition: form-data; name="~w"; filename="~w"\r\n',
|
||||
[Name, FileName])
|
||||
; format(Out, 'Content-Disposition: form-data; name="~w"\r\n', [Name])
|
||||
),
|
||||
pack(Value, Out).
|
||||
pack(html(HTML), Out) :-
|
||||
format(Out, 'Content-Type: text/html\r\n\r\n', []),
|
||||
print_html(Out, HTML).
|
||||
pack(file(File), Out) :- !,
|
||||
( file_mime_type(File, Type)
|
||||
-> true
|
||||
; Type = text/plain
|
||||
),
|
||||
format(Out, 'Content-Type: ~w\r\n\r\n', [Type]),
|
||||
( Type = text/_
|
||||
-> OpenOptions = []
|
||||
; OpenOptions = [type(binary)]
|
||||
),
|
||||
open(File, read, In, OpenOptions),
|
||||
copy_stream_data(In, Out),
|
||||
close(In).
|
||||
pack(stream(In, Len), Out) :- !,
|
||||
copy_stream_data(In, Out, Len).
|
||||
pack(stream(In), Out) :- !,
|
||||
copy_stream_data(In, Out).
|
||||
pack(mime(Atts, Data, []), Out) :- !, % mime_parse compatibility
|
||||
write_mime_attributes(Atts, Out),
|
||||
write(Out, Data).
|
||||
pack(mime(_Atts, '', Parts), Out) :-
|
||||
make_boundary(Parts, Boundary),
|
||||
format('Content-type: multipart/mixed; boundary=~w\r\n\r\n',
|
||||
[Boundary]),
|
||||
mime_pack(Parts, Out, Boundary).
|
||||
pack(Atom, Out) :-
|
||||
atomic(Atom), !,
|
||||
format(Out, '\r\n', []),
|
||||
write(Out, Atom).
|
||||
pack(Value, _) :-
|
||||
throw(error(type_error(mime_part, Value), _)).
|
||||
|
||||
write_mime_attributes([], Out) :- !,
|
||||
format(Out, '\r\n', []).
|
||||
write_mime_attributes(Atts, Out) :-
|
||||
select(type(Type), Atts, A1), !,
|
||||
( select(character_set(CharSet), A1, A2)
|
||||
-> format(Out, 'Content-type: ~w; charset=~w\r\n', [Type, CharSet]),
|
||||
write_mime_attributes(A2, Out)
|
||||
; format(Out, 'Content-type: ~w\r\n', [Type]),
|
||||
write_mime_attributes(A1, Out)
|
||||
).
|
||||
write_mime_attributes([_|T], Out) :-
|
||||
write_mime_attributes(T, Out).
|
||||
|
||||
|
||||
%% make_boundary(+Inputs, ?Boundary) is det.
|
||||
%
|
||||
% Generate a boundary. This should check all input sources whether
|
||||
% the boundary is enclosed.
|
||||
|
||||
make_boundary(_, Boundary) :-
|
||||
atomic(Boundary), !.
|
||||
make_boundary(_, Boundary) :-
|
||||
get_time(Now),
|
||||
A is random(1<<16),
|
||||
B is random(1<<16),
|
||||
C is random(1<<16),
|
||||
D is random(1<<16),
|
||||
E is random(1<<16),
|
||||
sformat(Boundary, '------~0f~16r~16r~16r~16r~16r',
|
||||
[Now, A, B, C, D, E]).
|
||||
|
||||
111
packages/http/mimetype.pl
Normal file
111
packages/http/mimetype.pl
Normal file
@ -0,0 +1,111 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2009, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(mimetype,
|
||||
[ file_mime_type/2 % +Path, -Type
|
||||
]).
|
||||
|
||||
%% file_mime_type(+FileName, -MimeType) is semidet.
|
||||
%
|
||||
% Simple library to guess the mime-type from the extension of a
|
||||
% file. As various applications need to do this type of
|
||||
% inferencing it seems worthwhile to place this functionality in
|
||||
% an extensible library.
|
||||
%
|
||||
% Please add clauses to mime:mime_extension/2 to add your own types.
|
||||
|
||||
file_mime_type(File, MimeType) :-
|
||||
file_name_extension(_, Ext, File),
|
||||
( current_prolog_flag(windows, true)
|
||||
-> downcase_atom(Ext, Lower),
|
||||
mime_extension(Lower, MimeType)
|
||||
; mime_extension(Ext, M0)
|
||||
-> MimeType = M0
|
||||
; downcase_atom(Ext, Lower),
|
||||
mime_extension(Lower, MimeType)
|
||||
).
|
||||
|
||||
:- multifile
|
||||
mime:mime_extension/2.
|
||||
|
||||
mime_extension(Ext, Mime) :-
|
||||
mime:mime_extension(Ext, Mime), !.
|
||||
% plain text
|
||||
mime_extension(txt, text/plain).
|
||||
% markup
|
||||
mime_extension(htm, text/html).
|
||||
mime_extension(html, text/html).
|
||||
mime_extension(xhtml, application/'xhtml+xml').
|
||||
mime_extension(sgml, text/'x-sgml').
|
||||
mime_extension(sgm, text/'x-sgml').
|
||||
mime_extension(xml, text/xml).
|
||||
mime_extension(css, text/css).
|
||||
% semantic web stuff
|
||||
mime_extension(rdf, application/'rdf+xml').
|
||||
mime_extension(rdfs, application/'rdf+xml').
|
||||
mime_extension(owl, application/'rdf+xml').
|
||||
% Prolog source
|
||||
mime_extension(pl, text/plain).
|
||||
% Packaged formats
|
||||
mime_extension(gz, application/'x-gzip').
|
||||
mime_extension(zip, application/zip).
|
||||
mime_extension(tgz, application/'x-gtar').
|
||||
% Some document formats
|
||||
mime_extension(pdf, application/pdf).
|
||||
mime_extension(doc, application/msword).
|
||||
% Java classes
|
||||
mime_extension(class, application/'octet-stream').
|
||||
mime_extension(jar, application/'java-archive').
|
||||
mime_extension(js, text/javascript).
|
||||
% Visual Basic Script :-(
|
||||
mime_extension(vbs, text/vbscript).
|
||||
% Some image formats
|
||||
mime_extension(jpg, image/jpeg).
|
||||
mime_extension(jpeg, image/jpeg).
|
||||
mime_extension(gif, image/gif).
|
||||
mime_extension(png, image/png).
|
||||
mime_extension(tif, image/tiff).
|
||||
mime_extension(tiff, image/tiff).
|
||||
mime_extension(xpm, image/'x-xpixmap').
|
||||
mime_extension(ico, image/'x-ico').
|
||||
mime_extension(svg, image/'svg+xml').
|
||||
% Google earth
|
||||
mime_extension(kml, application/'vnd.google-earth.kml+xml').
|
||||
mime_extension(kmz, application/'vnd.google-earth.kmz').
|
||||
|
||||
% Flash
|
||||
mime_extension(swf, application/'x-shockwave-flash').
|
||||
mime_extension(flv, video/'x-flv').
|
||||
% MP3
|
||||
mime_extension(mp3, audio/mpeg).
|
||||
% Downloads
|
||||
mime_extension(rpm, application/'x-rpm').
|
||||
mime_extension(exe, application/'x-executable').
|
||||
60
packages/http/pltotex.pl
Normal file
60
packages/http/pltotex.pl
Normal file
@ -0,0 +1,60 @@
|
||||
:- module(pltotex,
|
||||
[ pltotex/2,
|
||||
pltotex/0
|
||||
]).
|
||||
:- use_module(library(doc_latex)).
|
||||
:- use_module(library(main)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(apply)).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
pltotex(Lib, Options) :-
|
||||
( file_name_extension(_, pl, Lib)
|
||||
-> Spec = Lib
|
||||
; atom_to_term(Lib, Spec, _)
|
||||
),
|
||||
absolute_file_name(Spec, File,
|
||||
[ access(read),
|
||||
file_type(prolog)
|
||||
]),
|
||||
tex_file(File, Out),
|
||||
user:use_module(File), % we want the operators in user
|
||||
doc_latex(File, Out,
|
||||
[ stand_alone(false)
|
||||
| Options
|
||||
]).
|
||||
|
||||
tex_file(File, TeXFile) :-
|
||||
file_base_name(File, Local),
|
||||
file_name_extension(Base0, _, Local),
|
||||
strip(Base0, 0'_, Base),
|
||||
file_name_extension(Base, tex, TeXFile).
|
||||
|
||||
strip(In, Code, Out) :-
|
||||
atom_codes(In, Codes0),
|
||||
delete(Codes0, Code, Codes),
|
||||
atom_codes(Out, Codes).
|
||||
|
||||
|
||||
%% pltotex
|
||||
%
|
||||
% Usage: pl -q -s pltotex.pl -g pltotex -- file ...
|
||||
|
||||
pltotex :-
|
||||
main.
|
||||
|
||||
main(Argv) :-
|
||||
partition(is_option, Argv, OptArgs, Files),
|
||||
maplist(to_option, OptArgs, Options),
|
||||
maplist(process_file(Options), Files).
|
||||
|
||||
is_option(Arg) :-
|
||||
sub_atom(Arg, 0, _, _, --).
|
||||
|
||||
to_option('--section', section_level(section)).
|
||||
to_option('--subsection', section_level(subsection)).
|
||||
to_option('--subsubsection', section_level(subsubsection)).
|
||||
|
||||
process_file(Options, File) :-
|
||||
pltotex(File, Options).
|
||||
|
||||
30
packages/http/post.txt
Normal file
30
packages/http/post.txt
Normal file
@ -0,0 +1,30 @@
|
||||
---+++ Repositioning HTML for CSS and javascript links
|
||||
|
||||
Modern HTML commonly uses CSS and Javascript. This requires <link>
|
||||
elements in the HTML <head> element or <script> elements in the <body>.
|
||||
Unfortunately this seriously harms re-using HTML DCG rules as components
|
||||
as each of these components may rely on their own style sheets or
|
||||
JavaScript code. We added a `mailing' system to reposition and collect
|
||||
fragments of HTML. This is implemented by html_post//2, html_receive//1
|
||||
and html_receive//2.
|
||||
|
||||
* [[html_post//2]]
|
||||
* [[html_receive//1]]
|
||||
* [[html_receive//2]]
|
||||
|
||||
The library predefines the receiver channel =head= at the end of the
|
||||
=head= element for all pages that write the html =head= through this
|
||||
library. The following code can be used anywhere inside an HTML
|
||||
generating rule to demand a javascript in the header:
|
||||
|
||||
==
|
||||
js_script(URL) -->
|
||||
html_post(head, script([ src(URL),
|
||||
type('text/javascript')
|
||||
], [])).
|
||||
==
|
||||
|
||||
This mechanism is also exploited to add XML namespace (=xmlns=)
|
||||
declarations to the (outer) =html= element using xhml_ns//2:
|
||||
|
||||
* [[xhtml_ns//2]]
|
||||
221
packages/http/stream_range.c
Normal file
221
packages/http/stream_range.c
Normal file
@ -0,0 +1,221 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2007, University of Amsterdam
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
This library is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
*/
|
||||
|
||||
#include <SWI-Stream.h>
|
||||
#include <SWI-Prolog.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <assert.h>
|
||||
#include <time.h>
|
||||
#include <errno.h>
|
||||
|
||||
static atom_t ATOM_size; /* size(Int) */
|
||||
|
||||
/*******************************
|
||||
* TYPES *
|
||||
*******************************/
|
||||
|
||||
#define BUFSIZE SIO_BUFSIZE /* raw I/O buffer */
|
||||
|
||||
typedef struct range_context
|
||||
{ IOSTREAM *stream; /* Original stream */
|
||||
IOSTREAM *range_stream; /* Stream I'm handle of */
|
||||
IOENC parent_encoding; /* Saved encoding of parent */
|
||||
size_t read; /* data already read */
|
||||
size_t size; /* #bytes of data available */
|
||||
} range_context;
|
||||
|
||||
|
||||
static range_context*
|
||||
alloc_range_context(IOSTREAM *s)
|
||||
{ range_context *ctx = PL_malloc(sizeof(*ctx));
|
||||
|
||||
memset(ctx, 0, sizeof(*ctx));
|
||||
ctx->stream = s;
|
||||
|
||||
return ctx;
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
free_range_context(range_context *ctx)
|
||||
{ if ( ctx->stream->upstream )
|
||||
Sset_filter(ctx->stream, NULL);
|
||||
else
|
||||
PL_release_stream(ctx->stream);
|
||||
|
||||
PL_free(ctx);
|
||||
}
|
||||
|
||||
|
||||
/*******************************
|
||||
* RANGE LIMITED INPUT *
|
||||
*******************************/
|
||||
|
||||
static ssize_t /* range-limited read */
|
||||
range_read(void *handle, char *buf, size_t size)
|
||||
{ range_context *ctx = handle;
|
||||
size_t max_rd;
|
||||
ssize_t rd;
|
||||
|
||||
if ( ctx->read == ctx->size )
|
||||
return 0;
|
||||
|
||||
if ( ctx->size - ctx->read < size )
|
||||
max_rd = ctx->size - ctx->read;
|
||||
else
|
||||
max_rd = size;
|
||||
|
||||
if ( (rd = Sfread(buf, sizeof(char), max_rd, ctx->stream)) >= 0 )
|
||||
{ ctx->read += rd;
|
||||
|
||||
return rd;
|
||||
}
|
||||
|
||||
return rd;
|
||||
}
|
||||
|
||||
|
||||
static ssize_t /* no writing! */
|
||||
range_write(void *handle, char *buf, size_t size)
|
||||
{ return -1;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
range_control(void *handle, int op, void *data)
|
||||
{ range_context *ctx = handle;
|
||||
|
||||
switch(op)
|
||||
{ case SIO_FLUSHOUTPUT:
|
||||
case SIO_SETENCODING:
|
||||
return 0; /* allow switching encoding */
|
||||
case SIO_GETSIZE:
|
||||
{ size_t *rval = data;
|
||||
*rval = ctx->size;
|
||||
return 0;
|
||||
}
|
||||
default:
|
||||
if ( ctx->stream->functions->control )
|
||||
return (*ctx->stream->functions->control)(ctx->stream->handle, op, data);
|
||||
return -1;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
range_close(void *handle)
|
||||
{ range_context *ctx = handle;
|
||||
|
||||
ctx->stream->encoding = ctx->parent_encoding;
|
||||
free_range_context(ctx);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
static IOFUNCTIONS range_functions =
|
||||
{ range_read,
|
||||
range_write,
|
||||
NULL, /* seek */
|
||||
range_close,
|
||||
range_control, /* zcontrol */
|
||||
NULL, /* seek64 */
|
||||
};
|
||||
|
||||
|
||||
/*******************************
|
||||
* PROLOG CONNECTION *
|
||||
*******************************/
|
||||
|
||||
#define COPY_FLAGS (SIO_INPUT|SIO_OUTPUT| \
|
||||
SIO_TEXT| \
|
||||
SIO_REPXML|SIO_REPPL|\
|
||||
SIO_RECORDPOS)
|
||||
|
||||
static foreign_t
|
||||
pl_stream_range_open(term_t org, term_t new, term_t options)
|
||||
{ term_t tail = PL_copy_term_ref(options);
|
||||
term_t head = PL_new_term_ref();
|
||||
range_context *ctx;
|
||||
IOSTREAM *s, *s2;
|
||||
int size = 0;
|
||||
|
||||
while(PL_get_list(tail, head, tail))
|
||||
{ atom_t name;
|
||||
int arity;
|
||||
term_t arg = PL_new_term_ref();
|
||||
|
||||
if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
|
||||
return type_error(head, "option");
|
||||
_PL_get_arg(1, head, arg);
|
||||
|
||||
if ( name == ATOM_size )
|
||||
{ if ( !get_int_ex(arg, &size) )
|
||||
return FALSE;
|
||||
if ( size <= 0 )
|
||||
return domain_error(arg, "nonneg");
|
||||
}
|
||||
}
|
||||
if ( !PL_get_nil(tail) )
|
||||
return type_error(tail, "list");
|
||||
|
||||
if ( !PL_get_stream_handle(org, &s) )
|
||||
return FALSE; /* Error */
|
||||
ctx = alloc_range_context(s);
|
||||
ctx->size = size;
|
||||
|
||||
if ( !(s2 = Snew(ctx,
|
||||
(s->flags©_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);
|
||||
}
|
||||
329
packages/http/test_cgi_stream.pl
Normal file
329
packages/http/test_cgi_stream.pl
Normal file
@ -0,0 +1,329 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2008, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(test_cgi_stream,
|
||||
[ test_cgi_stream/0
|
||||
, t/0, d/0, nd/0 % Handy things
|
||||
]).
|
||||
|
||||
:- use_module(library(plunit)).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(http/http_stream)).
|
||||
:- use_module(library(http/http_header)).
|
||||
:- use_module(library(http/http_client)).
|
||||
|
||||
:- expects_dialect(swi).
|
||||
:- assert(system:swi_io).
|
||||
|
||||
|
||||
/** <module> Test CGI stream object
|
||||
|
||||
This module defines a series of tests outside the context of the HTTP
|
||||
server to validate correct processing of the CGI header, handling
|
||||
different encodings and transfer encodings (chunked/traditional).
|
||||
Instead of using real sockets, we use temporary storage on a file.
|
||||
|
||||
@tbd Validate error processing
|
||||
*/
|
||||
|
||||
t :-
|
||||
test_cgi_stream.
|
||||
|
||||
d :-
|
||||
http_stream:http_stream_debug(1),
|
||||
debug(http(hook)),
|
||||
debug(http(header)).
|
||||
nd :-
|
||||
http_stream:http_stream_debug(0),
|
||||
nodebug(http(hook)),
|
||||
nodebug(http(header)).
|
||||
|
||||
test_cgi_stream :-
|
||||
run_tests([ cgi_stream,
|
||||
cgi_chunked,
|
||||
cgi_errors
|
||||
]).
|
||||
|
||||
/*******************************
|
||||
* DESTINATION *
|
||||
*******************************/
|
||||
|
||||
open_dest(TmpF, Out) :-
|
||||
tmp_file(http, TmpF),
|
||||
open(TmpF, write, Out, [type(binary)]).
|
||||
|
||||
free_dest(TmpF) :-
|
||||
delete_file(TmpF).
|
||||
|
||||
free_dest(TmpF, Out) :-
|
||||
close(Out),
|
||||
delete_file(TmpF).
|
||||
|
||||
http_read_mf(TmpF, Header, Data) :-
|
||||
open(TmpF, read, In, [type(binary)]),
|
||||
http_read_reply_header(In, Header),
|
||||
http_read_data(Header, Data, to(atom)),
|
||||
close(In).
|
||||
|
||||
|
||||
cat(TmpF) :-
|
||||
open(TmpF, read, In),
|
||||
call_cleanup(copy_stream_data(In, current_output),
|
||||
close(In)).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MAKE DATA *
|
||||
*******************************/
|
||||
|
||||
%% data_atom(+Length, +Min, +Max, -Atom) is det.
|
||||
%
|
||||
% Create an atom of Length codes. It contains repeating sequences
|
||||
% Min..Max.
|
||||
|
||||
data_atom(Length, Min, Max, Atom) :-
|
||||
data_list(Length, Min, Max, List),
|
||||
atom_codes(Atom, List).
|
||||
|
||||
data_list(Length, Min, Max, List) :-
|
||||
Span is Max - Min,
|
||||
data_list(Length, Min, 0, Span, List).
|
||||
|
||||
data_list(Len, Min, I, Span, [H|T]) :-
|
||||
Len > 0, !,
|
||||
H is Min + I mod Span,
|
||||
Len2 is Len - 1,
|
||||
I2 is I+1,
|
||||
data_list(Len2, Min, I2, Span, T).
|
||||
data_list(_, _, _, _, []).
|
||||
|
||||
%% data(+Name, -Data, -ContentType) is det.
|
||||
%
|
||||
% Create data-sets to be used with the PlUnit forall option.
|
||||
|
||||
data(short_ascii, Data, 'text/plain') :-
|
||||
data_atom(10, 97, 128, Data).
|
||||
data(ascii, Data, 'text/plain') :-
|
||||
data_atom(126, 1, 128, Data).
|
||||
data(unicode, Data, 'text/plain') :-
|
||||
data_atom(10, 1000, 1010, Data).
|
||||
data(long_unicode, Data, 'text/plain') :-
|
||||
data_atom(10000, 1, 1000, Data).
|
||||
data(long_binary, Data, 'text/plain') :-
|
||||
data_atom(10000, 0, 255, Data).
|
||||
|
||||
%% current_data(-Name) is nondet.
|
||||
%
|
||||
% Enumerate available datasets.
|
||||
|
||||
current_data(Name) :-
|
||||
clause(data(Name, _, _), _).
|
||||
|
||||
|
||||
/*******************************
|
||||
* TEST *
|
||||
*******************************/
|
||||
|
||||
assert_header(Header, Field) :-
|
||||
memberchk(Field, Header), !.
|
||||
assert_header(_Header, Field) :-
|
||||
format(user_error, 'ERROR: ~p expected in header~n', [Field]),
|
||||
fail.
|
||||
|
||||
|
||||
/*******************************
|
||||
* HOOK *
|
||||
*******************************/
|
||||
|
||||
cgi_hook(What, _CGI) :-
|
||||
debug(http(hook), 'Running hook: ~q', [What]),
|
||||
fail.
|
||||
cgi_hook(header, CGI) :-
|
||||
cgi_property(CGI, header_codes(HeadText)),
|
||||
http_parse_header(HeadText, CgiHeader),
|
||||
cgi_property(CGI, request(Request)),
|
||||
http_update_connection(CgiHeader, Request, Connection, Header1),
|
||||
http_update_transfer(Request, Header1, Transfer, Header2),
|
||||
http_update_encoding(Header2, Encoding, Header),
|
||||
set_stream(CGI, encoding(Encoding)),
|
||||
cgi_set(CGI, connection(Connection)),
|
||||
cgi_set(CGI, header(Header)),
|
||||
cgi_set(CGI, transfer_encoding(Transfer)). % must be LAST
|
||||
cgi_hook(send_header, CGI) :-
|
||||
cgi_property(CGI, header(Header)),
|
||||
cgi_property(CGI, client(Out)),
|
||||
( cgi_property(CGI, transfer_encoding(chunked))
|
||||
-> phrase(http_header:reply_header(chunked_data, Header, _), String)
|
||||
; cgi_property(CGI, content_length(Len))
|
||||
-> phrase(http_header:reply_header(cgi_data(Len), Header, _), String)
|
||||
),
|
||||
format(Out, '~s', [String]).
|
||||
cgi_hook(close, _).
|
||||
|
||||
|
||||
:- begin_tests(cgi_stream, [sto(rational_trees)]).
|
||||
|
||||
test(traditional,
|
||||
[ forall(current_data(Name)),
|
||||
Reply == Data,
|
||||
setup(open_dest(TmpF, Out)),
|
||||
cleanup(free_dest(TmpF))
|
||||
]) :-
|
||||
data(Name, Data, ContentType),
|
||||
cgi_open(Out, CGI, cgi_hook, []),
|
||||
start_low_level_trace,
|
||||
format(CGI, 'Content-type: ~w\n\n', [ContentType]),
|
||||
format(CGI, '~w', [Data]),
|
||||
close(CGI),
|
||||
close(Out),
|
||||
http_read_mf(TmpF, Header, Reply),
|
||||
assert_header(Header, status(ok, _)).
|
||||
|
||||
test(unicode,
|
||||
[ forall(Name=unicode),
|
||||
Reply == Data,
|
||||
setup(open_dest(TmpF, Out)),
|
||||
cleanup(free_dest(TmpF))
|
||||
]) :-
|
||||
data(Name, Data, ContentType),
|
||||
cgi_open(Out, CGI, cgi_hook, []),
|
||||
format(CGI, 'Content-type: ~w\n\n', [ContentType]),
|
||||
format(CGI, '~w', [Data]),
|
||||
close(CGI),
|
||||
close(Out),
|
||||
http_read_mf(TmpF, Header, Reply),
|
||||
assert_header(Header, status(ok, _)).
|
||||
|
||||
:- end_tests(cgi_stream).
|
||||
|
||||
:- begin_tests(cgi_chunked, [sto(rational_trees)]).
|
||||
|
||||
test(chunked,
|
||||
[ forall(current_data(Name)),
|
||||
Reply == Data,
|
||||
setup(open_dest(TmpF, Out)),
|
||||
cleanup(free_dest(TmpF))
|
||||
]) :-
|
||||
data(Name, Data, ContentType),
|
||||
cgi_open(Out, CGI, cgi_hook,
|
||||
[ request([http_version(1-1)])
|
||||
]),
|
||||
format(CGI, 'Transfer-encoding: chunked\n', []),
|
||||
format(CGI, 'Content-type: ~w\n\n', [ContentType]),
|
||||
format(CGI, '~w', [Data]),
|
||||
close(CGI),
|
||||
close(Out),
|
||||
http_read_mf(TmpF, Header, Reply),
|
||||
assert_header(Header, status(ok, _)),
|
||||
assert_header(Header, transfer_encoding(chunked)).
|
||||
|
||||
:- end_tests(cgi_chunked).
|
||||
|
||||
|
||||
/*******************************
|
||||
* ERROR HANDLING *
|
||||
*******************************/
|
||||
|
||||
%% collect_messages(:Goal, -Messages) is semidet.
|
||||
%
|
||||
% Run Goal as once/1, collecting possible messages in Messages.
|
||||
|
||||
:- meta_predicate
|
||||
collect_messages(0, -, -).
|
||||
|
||||
collect_messages(Goal, True, Messages) :-
|
||||
strip_module(Goal, M, G),
|
||||
collect_messages2(M:G, True, Messages).
|
||||
|
||||
:- multifile
|
||||
user:message_hook/3.
|
||||
:- dynamic
|
||||
msg_collecting/0,
|
||||
msg/2.
|
||||
|
||||
user:message_hook(Term, Kind, _Lines) :-
|
||||
msg_collecting, !,
|
||||
assert(msg(Term, Kind)).
|
||||
|
||||
collect_messages2(Goal, True, Messages) :-
|
||||
assert(msg_collecting, Ref),
|
||||
call_cleanup(call_result(Goal, True),
|
||||
( erase(Ref),
|
||||
findall(message(Term, Kind), retract(msg(Term, Kind)),
|
||||
Messages))).
|
||||
|
||||
call_result(Goal, true) :-
|
||||
Goal, !.
|
||||
call_result(_, false).
|
||||
|
||||
|
||||
:- begin_tests(cgi_errors, [sto(rational_trees)]).
|
||||
|
||||
cgi_fail_hook(Event, _) :-
|
||||
debug(http(hook), 'Failing hook for ~w', [Event]),
|
||||
fail.
|
||||
|
||||
cgi_error_hook(Event, _) :-
|
||||
debug(http(hook), 'Error hook for ~w', [Event]),
|
||||
throw(error(demo_error, _)).
|
||||
|
||||
test(hook_failed,
|
||||
[ setup(open_dest(TmpF, Out)),
|
||||
cleanup(free_dest(TmpF, Out)),
|
||||
error(io_error(_,_))
|
||||
]) :-
|
||||
cgi_open(Out, CGI, cgi_fail_hook, []),
|
||||
close(CGI).
|
||||
|
||||
test(hook_error,
|
||||
[ setup(open_dest(TmpF, Out)),
|
||||
cleanup(free_dest(TmpF, Out)),
|
||||
error(demo_error)
|
||||
]) :-
|
||||
cgi_open(Out, CGI, cgi_error_hook, []),
|
||||
close(CGI).
|
||||
|
||||
:- end_tests(cgi_errors).
|
||||
|
||||
|
||||
/*******************************
|
||||
* PORTRAY *
|
||||
*******************************/
|
||||
|
||||
user:portray(Atom) :-
|
||||
atom(Atom),
|
||||
atom_length(Atom, Len),
|
||||
Len > 100, !,
|
||||
sub_atom(Atom, 0, 35, _, Start),
|
||||
sub_atom(Atom, _, 35, 0, End),
|
||||
format('~q...[~D codes]...~q', [Start, Len, End]).
|
||||
|
||||
:- retract(system:swi_io).
|
||||
82
packages/http/test_http.pl
Normal file
82
packages/http/test_http.pl
Normal file
@ -0,0 +1,82 @@
|
||||
:- module(test_http,
|
||||
[ test_http/0
|
||||
]).
|
||||
:- asserta(user:file_search_path(foreign, '.')).
|
||||
:- asserta(user:file_search_path(foreign, '../clib')).
|
||||
:- asserta(user:file_search_path(foreign, '../sgml')).
|
||||
:- asserta(user:file_search_path(library, '..')).
|
||||
:- asserta(user:file_search_path(library, '../sgml')).
|
||||
:- asserta(user:file_search_path(library, '../plunit')).
|
||||
:- asserta(user:file_search_path(library, '../clib')).
|
||||
|
||||
:- use_module(library(http/http_open)).
|
||||
:- use_module(library(http/http_client)).
|
||||
:- use_module(library(http/http_stream)).
|
||||
:- use_module(library(plunit)).
|
||||
:- use_module(library(readutil)).
|
||||
:- use_module(library(socket)).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
test_http :-
|
||||
run_tests([ http_open,
|
||||
http_get
|
||||
]).
|
||||
|
||||
|
||||
:- begin_tests(http_open).
|
||||
|
||||
test(gollem, true) :-
|
||||
http_open('http://gollem.science.uva.nl/', In, []),
|
||||
read_stream_to_codes(In, Codes),
|
||||
close(In),
|
||||
appendchk(_, "http://www.swi-prolog.org/", _, Codes).
|
||||
test(gollem_redirect, true) :-
|
||||
http_open('http://gollem.science.uva.nl', In, []),
|
||||
read_stream_to_codes(In, Codes),
|
||||
close(In),
|
||||
appendchk(_, "http://www.swi-prolog.org/", _, Codes).
|
||||
test(gollem_chunked, true(Codes == Ref)) :-
|
||||
http_open('http://gollem.science.uva.nl/cgi-bin/chunked', In, []),
|
||||
read_stream_to_codes(In, Codes),
|
||||
close(In),
|
||||
chunked_data(Ref).
|
||||
|
||||
:- end_tests(http_open).
|
||||
|
||||
:- begin_tests(http_get).
|
||||
|
||||
test(gollem, true) :-
|
||||
http_get('http://gollem.science.uva.nl/', Data, [to(codes)]),
|
||||
appendchk(_, "http://www.swi-prolog.org/", _, Data).
|
||||
|
||||
test(gollem_chunked, true(Data == Ref)) :-
|
||||
http_get('http://gollem.science.uva.nl/cgi-bin/chunked',
|
||||
Data, [to(codes)]),
|
||||
chunked_data(Ref).
|
||||
|
||||
:- end_tests(http_get).
|
||||
|
||||
/*******************************
|
||||
* UTIL *
|
||||
*******************************/
|
||||
|
||||
read_file_to_codes(File, Codes) :-
|
||||
open(File, read, In),
|
||||
call_cleanup(read_stream_to_codes(In, Codes), close(In)).
|
||||
|
||||
appendchk(Pre, Middle, Post, List) :-
|
||||
append(Pre, Rest, List),
|
||||
append(Middle, Post, Rest), !.
|
||||
|
||||
%% chunked_data(-String) is det.
|
||||
%
|
||||
% Content of the chunked data that is sent by cgi-bin/chunked.
|
||||
|
||||
chunked_data(S) :-
|
||||
findall(C,
|
||||
( between(1, 1000, X),
|
||||
C is "a" + X mod 26
|
||||
), S).
|
||||
|
||||
|
||||
186
packages/http/test_json.pl
Normal file
186
packages/http/test_json.pl
Normal file
@ -0,0 +1,186 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2007, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(test_json,
|
||||
[ test_json/0
|
||||
]).
|
||||
:- asserta(user:file_search_path(foreign, '.')).
|
||||
:- asserta(user:file_search_path(foreign, '../clib')).
|
||||
:- asserta(user:file_search_path(foreign, '../sgml')).
|
||||
:- asserta(user:file_search_path(library, '../plunit')).
|
||||
:- asserta(user:file_search_path(library, '../clib')).
|
||||
:- asserta(user:file_search_path(library, '../sgml')).
|
||||
|
||||
:- use_module(library(plunit)).
|
||||
:- use_module(json).
|
||||
|
||||
test_json :-
|
||||
run_tests([ json_read,
|
||||
json_convert,
|
||||
json_http
|
||||
]).
|
||||
|
||||
:- begin_tests(json_read).
|
||||
|
||||
test(true, X == @(true)) :-
|
||||
atom_json_term(true, X, []).
|
||||
test(true, X == true) :-
|
||||
atom_json_term(true, X, [true(true)]).
|
||||
|
||||
test(string, X == hello) :-
|
||||
atom_json_term('"hello"', X, []).
|
||||
test(string, X == '\\\b\f\n\r\t') :-
|
||||
atom_json_term('"\\\\\\b\\f\\n\\r\\t"', X, []).
|
||||
test(string, X == '\u1234') :-
|
||||
atom_json_term('"\\u1234"', X, []).
|
||||
|
||||
test(int, X == 42) :-
|
||||
atom_json_term('42', X, []).
|
||||
test(int, X == -42) :-
|
||||
atom_json_term('-42', X, []).
|
||||
|
||||
test(float, X == 3.14) :-
|
||||
atom_json_term('3.14', X, []).
|
||||
test(float, X == -3.14) :-
|
||||
atom_json_term('-3.14', X, []).
|
||||
test(float, X == 1000.0) :-
|
||||
atom_json_term('1e3', X, []).
|
||||
test(float, X == 0.001) :-
|
||||
atom_json_term('1e-3', X, []).
|
||||
|
||||
test(empty, X == json([])) :-
|
||||
atom_json_term({}, X, []).
|
||||
test(empty, X == json([])) :-
|
||||
atom_json_term(' { } ', X, []).
|
||||
test(empty, X == json([])) :-
|
||||
atom_json_term(' {\n//comment\n} ', X, []).
|
||||
|
||||
|
||||
:- end_tests(json_read).
|
||||
|
||||
|
||||
/*******************************
|
||||
* CONVERT *
|
||||
*******************************/
|
||||
|
||||
:- begin_tests(json_convert).
|
||||
|
||||
:- use_module(json_convert).
|
||||
|
||||
:- json_object
|
||||
point(x:integer, y:integer),
|
||||
tpoint(x:integer, y:integer)+[type=point],
|
||||
fpoint(x:float, y:float).
|
||||
|
||||
test(pt2json, JSON == json([x=25,y=50])) :-
|
||||
prolog_to_json(point(25,50), JSON).
|
||||
test(pt2json, JSON == json([x=25,y=50,type=point])) :-
|
||||
prolog_to_json(tpoint(25,50), JSON).
|
||||
|
||||
test(json2pt, X == point(25,50)) :-
|
||||
json_to_prolog(json([x=25,y=50]), X).
|
||||
test(json2pt, X == point(25,50)) :-
|
||||
json_to_prolog(json([y=50,x=25]), X).
|
||||
test(json2pt, X == fpoint(25.1,50.0)) :-
|
||||
json_to_prolog(json([y=50.0,x=25.1]), X).
|
||||
test(json2pt, T == T2) :-
|
||||
T = json([y=50,x=25.1]),
|
||||
json_to_prolog(json([y=50,x=25.1]), T2).
|
||||
test(json2pt, X == tpoint(25,50)) :-
|
||||
json_to_prolog(json([x=25,y=50,type=point]), X).
|
||||
|
||||
:- end_tests(json_convert).
|
||||
|
||||
|
||||
/*******************************
|
||||
* HTTP *
|
||||
*******************************/
|
||||
|
||||
:- use_module(http_json).
|
||||
:- use_module(http_client).
|
||||
:- use_module(thread_httpd).
|
||||
|
||||
:- dynamic
|
||||
port/1.
|
||||
|
||||
make_server :-
|
||||
retractall(port(_)),
|
||||
http_server(reply,
|
||||
[ port(Port),
|
||||
workers(1)
|
||||
]),
|
||||
assert(port(Port)).
|
||||
|
||||
kill_server :-
|
||||
retract(port(Port)),
|
||||
http_stop_server(Port, []).
|
||||
|
||||
reply(Request) :-
|
||||
memberchk(path('/json/echo'), Request), !,
|
||||
http_read_json(Request, JSON),
|
||||
reply_json(JSON).
|
||||
|
||||
echo(Term, Reply) :-
|
||||
port(Port),
|
||||
format(string(URL), 'http://localhost:~w/json/echo', [Port]),
|
||||
http_post(URL, json(Term), Reply, []).
|
||||
|
||||
:- begin_tests(json_http, [ setup(make_server),
|
||||
cleanup(kill_server)
|
||||
]).
|
||||
|
||||
test(echo, X == 42) :-
|
||||
echo(42, X).
|
||||
test(echo, X == -3.14) :-
|
||||
echo(-3.14, X).
|
||||
test(echo, X == name) :-
|
||||
echo(name, X).
|
||||
test(echo, X == [1,2,3]) :-
|
||||
echo([1,2,3], X).
|
||||
test(echo, X == json([name=json, arity=2])) :-
|
||||
echo(json([name=json, arity=2]), X).
|
||||
|
||||
test(unicode, X == Atom) :-
|
||||
Atom = '\u0411\u0435\u0437\u0443\u043f\u0440\u0435\u0447\u043d\u043e\u0435',
|
||||
echo(Atom, X).
|
||||
test(quote, X == Atom) :-
|
||||
Atom = 'hello, "world"',
|
||||
echo(Atom, X).
|
||||
test(control, X == Atom) :-
|
||||
Atom = 'hello\n\t\r\b\003\',
|
||||
echo(Atom, X).
|
||||
|
||||
:- end_tests(json_http).
|
||||
|
||||
:- multifile
|
||||
user:message_hook/3.
|
||||
|
||||
user:message_hook(httpd_stopped_worker(_, true), _Kind, _Lines).
|
||||
593
packages/http/thread_httpd.pl
Normal file
593
packages/http/thread_httpd.pl
Normal file
@ -0,0 +1,593 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2007, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(thread_httpd,
|
||||
[ http_current_server/2, % ?:Goal, ?Port
|
||||
http_server_property/2, % ?Port, ?Property
|
||||
http_server/2, % :Goal, +Options
|
||||
http_workers/2, % +Port, ?WorkerCount
|
||||
http_current_worker/2, % ?Port, ?ThreadID
|
||||
http_stop_server/2, % +Port, +Options
|
||||
http_spawn/2, % :Goal, +Options
|
||||
|
||||
http_requeue/1, % +Request
|
||||
http_close_connection/1 % +Request
|
||||
]).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(socket)).
|
||||
:- use_module(library(thread_pool)).
|
||||
:- use_module(http_wrapper).
|
||||
:- use_module(http_stream).
|
||||
|
||||
|
||||
/** <module> Threaded HTTP server
|
||||
|
||||
This library provides a multi-threaded Prolog-based HTTP server based on
|
||||
the same wrapper as xpce_httpd and inetd_httpd. This server can handle
|
||||
multiple clients in Prolog threads and doesn't need XPCE.
|
||||
|
||||
In addition to the other two frontends (XPCE and inetd), this frontend
|
||||
provides hooks for http_ssl_plugin.pl for creating an HTTPS server. It
|
||||
is activated using the option ssl(+SSLOptions), where SSLOptions are
|
||||
options required by ssl_init/3. See http_ssl_plugin.pl and package ssl
|
||||
for details.
|
||||
*/
|
||||
|
||||
:- meta_predicate
|
||||
http_server(1, +),
|
||||
http_current_server(1, ?),
|
||||
http_spawn(0, +).
|
||||
|
||||
:- dynamic
|
||||
port_option/2, % Port, Option
|
||||
current_server/5, % Port, Goal, Thread, Queue, StartTime
|
||||
queue_worker/2, % Queue, ThreadID
|
||||
queue_options/2. % Queue, Options
|
||||
|
||||
:- multifile
|
||||
make_socket_hook/3,
|
||||
accept_hook/2,
|
||||
close_hook/1,
|
||||
open_client_hook/5.
|
||||
|
||||
%% http_server(:Goal, +Options) is det.
|
||||
%
|
||||
% Create a server at Port that calls Goal for each parsed request.
|
||||
% Options provide a list of options. Defined options are
|
||||
%
|
||||
% | port(?Port) | - | Port to listen to |
|
||||
% | workers(N) | 2 | Define the number of worker threads |
|
||||
% | timeout(S) | 60 | Max inactivity for reading request |
|
||||
% | keep_alive_timeout | 10 | Drop Keep-Alive connection timeout |
|
||||
% | local(KBytes) | <CommandLine> | |
|
||||
% | global(KBytes) | <CommandLine> | |
|
||||
% | trail(KBytes) | <CommandLine> | Stack-sizes of worker threads |
|
||||
|
||||
http_server(Goal, Options) :-
|
||||
strip_module(Goal, Module, G),
|
||||
select_option(port(Port), Options, Options1), !,
|
||||
make_socket(Port, Options1, Options2),
|
||||
set_port_options(Port, Options2),
|
||||
create_workers(Options2),
|
||||
create_server(Module:G, Port, Options2).
|
||||
http_server(_Goal, _Options) :-
|
||||
throw(error(existence_error(option, port), _)).
|
||||
|
||||
|
||||
%% make_socket(?Port, +OptionsIn, -OptionsOut) is det.
|
||||
%
|
||||
% Create the HTTP server socket and worker pool queue. OptionsOut
|
||||
% is quaranteed to hold the option queue(QueueId).
|
||||
|
||||
make_socket(Port, Options0, Options) :-
|
||||
make_socket_hook(Port, Options0, Options), !.
|
||||
make_socket(Port, Options0, Options) :-
|
||||
tcp_socket(Socket),
|
||||
tcp_setopt(Socket, reuseaddr),
|
||||
tcp_bind(Socket, Port),
|
||||
tcp_listen(Socket, 5),
|
||||
atom_concat('httpd@', Port, Queue),
|
||||
Options = [ queue(Queue),
|
||||
tcp_socket(Socket)
|
||||
| Options0
|
||||
].
|
||||
|
||||
create_server(Goal, Port, Options) :-
|
||||
get_time(StartTime),
|
||||
memberchk(queue(Queue), Options),
|
||||
atom_concat('http@', Port, Alias),
|
||||
thread_create(accept_server(Goal, Options), _,
|
||||
[ alias(Alias)
|
||||
]),
|
||||
assert(current_server(Port, Goal, Alias, Queue, StartTime)).
|
||||
|
||||
|
||||
%% set_port_options(+Port, +Options) is det.
|
||||
%
|
||||
% Register Options for the HTTP server at Port.
|
||||
|
||||
set_port_options(Port, Options) :-
|
||||
retractall(port_option(Port, _)),
|
||||
assert_port_options(Options, Port).
|
||||
|
||||
assert_port_options([], _).
|
||||
assert_port_options([Name=Value|T], Port) :- !,
|
||||
Opt =.. [Name,Value],
|
||||
assert(port_option(Port, Opt)),
|
||||
assert_port_options(T, Port).
|
||||
assert_port_options([Opt|T], Port) :- !,
|
||||
assert(port_option(Port, Opt)),
|
||||
assert_port_options(T, Port).
|
||||
|
||||
|
||||
%% http_current_server(:Goal, ?Port) is nondet.
|
||||
%
|
||||
% True if Goal is the goal of a server at Port.
|
||||
%
|
||||
% @deprecated Use http_server_property(Port, goal(Goal))
|
||||
|
||||
http_current_server(Goal, Port) :-
|
||||
current_server(Port, Goal, _, _, _).
|
||||
|
||||
|
||||
%% http_server_property(?Port, ?Property) is nondet.
|
||||
%
|
||||
% True if Property is a property of the HTTP server running at
|
||||
% Port. Defined properties are:
|
||||
%
|
||||
% * goal(:Goal)
|
||||
% Goal used to start the server. This is often
|
||||
% http_dispatch/1.
|
||||
% * start_time(?Time)
|
||||
% Time-stamp when the server was created.
|
||||
|
||||
http_server_property(Port, Property) :-
|
||||
server_property(Property, Port).
|
||||
|
||||
server_property(goal(Goal), Port) :-
|
||||
current_server(Port, Goal, _, _, _).
|
||||
server_property(start_time(Time), Port) :-
|
||||
current_server(Port, _, _, _, Time).
|
||||
|
||||
|
||||
%% http_workers(+Port, -Workers) is det.
|
||||
%% http_workers(+Port, +Workers:int) is det.
|
||||
%
|
||||
% Query or set the number of workers for the server at this port.
|
||||
% The number of workers is dynamically modified. Setting it to 1
|
||||
% (one) can be used to profile the worker using tprofile/1.
|
||||
|
||||
http_workers(Port, Workers) :-
|
||||
must_be(integer, Port),
|
||||
current_server(Port, _, _, Queue, _), !,
|
||||
( integer(Workers)
|
||||
-> resize_pool(Queue, Workers)
|
||||
; findall(W, queue_worker(Queue, W), WorkerIDs),
|
||||
length(WorkerIDs, Workers)
|
||||
).
|
||||
http_workers(Port, _) :-
|
||||
existence_error(http_server, Port).
|
||||
|
||||
|
||||
%% http_current_worker(?Port, ?ThreadID) is nondet.
|
||||
%
|
||||
% True if ThreadID is the identifier of a Prolog thread serving
|
||||
% Port. This predicate is motivated to allow for the use of
|
||||
% arbitrary interaction with the worker thread for development and
|
||||
% statistics.
|
||||
|
||||
http_current_worker(Port, ThreadID) :-
|
||||
current_server(Port, _, _, Queue, _),
|
||||
queue_worker(Queue, ThreadID).
|
||||
|
||||
|
||||
%% accept_server(:Goal, +Options)
|
||||
%
|
||||
% The goal of a small server-thread accepting new requests and
|
||||
% posting them to the queue of workers.
|
||||
|
||||
accept_server(Goal, Options) :-
|
||||
catch(accept_server2(Goal, Options), http_stop, true),
|
||||
thread_self(Thread),
|
||||
retract(current_server(_Port, _, Thread, _Queue, _StartTime)),
|
||||
close_server_socket(Options).
|
||||
|
||||
accept_server2(Goal, Options) :-
|
||||
accept_hook(Goal, Options), !.
|
||||
accept_server2(Goal, Options) :-
|
||||
memberchk(tcp_socket(Socket), Options), !,
|
||||
memberchk(queue(Queue), Options),
|
||||
repeat,
|
||||
( catch(tcp_accept(Socket, Client, Peer), E, true)
|
||||
-> ( var(E)
|
||||
-> debug(http(connection), 'New HTTP connection from ~p', [Peer]),
|
||||
thread_send_message(Queue, tcp_client(Client, Goal, Peer)),
|
||||
fail
|
||||
; accept_rethrow_error(E)
|
||||
-> throw(E)
|
||||
; print_message(error, E),
|
||||
fail
|
||||
)
|
||||
; print_message(error, goal_failed(tcp_accept(Socket, Client, Peer)))
|
||||
).
|
||||
|
||||
accept_rethrow_error(http_stop).
|
||||
accept_rethrow_error('$aborted').
|
||||
|
||||
|
||||
%% close_server_socket(+Options)
|
||||
%
|
||||
% Close the server socket.
|
||||
|
||||
close_server_socket(Options) :-
|
||||
close_hook(Options), !.
|
||||
close_server_socket(Options) :-
|
||||
memberchk(tcp_socket(Socket), Options), !,
|
||||
tcp_close_socket(Socket).
|
||||
|
||||
|
||||
%% http_stop_server(+Port, +Options)
|
||||
%
|
||||
% Stop the indicated HTTP server gracefully. First stops all
|
||||
% workers, then stops the server.
|
||||
%
|
||||
% @tbd Realise non-graceful stop
|
||||
|
||||
http_stop_server(Port, _Options) :-
|
||||
http_workers(Port, 0),
|
||||
current_server(Port, _, Thread, Queue, _Start),
|
||||
retractall(queue_options(Queue, _)),
|
||||
thread_signal(Thread, throw(http_stop)),
|
||||
catch(connect(localhost:Port), _, true),
|
||||
thread_join(Thread, _),
|
||||
message_queue_destroy(Queue).
|
||||
|
||||
connect(Address) :-
|
||||
tcp_socket(Socket),
|
||||
tcp_connect(Socket, Address),
|
||||
tcp_close_socket(Socket).
|
||||
|
||||
|
||||
/*******************************
|
||||
* WORKER QUEUE OPERATIONS *
|
||||
*******************************/
|
||||
|
||||
%% create_workers(+Options)
|
||||
%
|
||||
% Create the pool of HTTP worker-threads. Each worker has the
|
||||
% alias http_worker_N.
|
||||
|
||||
create_workers(Options) :-
|
||||
option(workers(N), Options, 2),
|
||||
option(queue(Queue), Options),
|
||||
catch(message_queue_create(Queue), _, true),
|
||||
atom_concat(Queue, '_', AliasBase),
|
||||
create_workers(1, N, Queue, AliasBase, Options),
|
||||
assert(queue_options(Queue, Options)).
|
||||
|
||||
create_workers(I, N, _, _, _) :-
|
||||
I > N, !.
|
||||
create_workers(I, N, Queue, AliasBase, Options) :-
|
||||
gensym(AliasBase, Alias),
|
||||
thread_create(http_worker(Options), Id,
|
||||
[ alias(Alias)
|
||||
| Options
|
||||
]),
|
||||
assert(queue_worker(Queue, Id)),
|
||||
I2 is I + 1,
|
||||
create_workers(I2, N, Queue, AliasBase, Options).
|
||||
|
||||
|
||||
%% resize_pool(+Queue, +Workers) is det.
|
||||
%
|
||||
% Create or destroy workers. If workers are destroyed, the call
|
||||
% waits until the desired number of waiters is reached.
|
||||
|
||||
resize_pool(Queue, Size) :-
|
||||
findall(W, queue_worker(Queue, W), Workers),
|
||||
length(Workers, Now),
|
||||
( Now < Size
|
||||
-> queue_options(Queue, Options),
|
||||
atom_concat(Queue, '_', AliasBase),
|
||||
I0 is Now+1,
|
||||
create_workers(I0, Size, Queue, AliasBase, Options)
|
||||
; Now == Size
|
||||
-> true
|
||||
; Now > Size
|
||||
-> Excess is Now - Size,
|
||||
thread_self(Me),
|
||||
forall(between(1, Excess, _), thread_send_message(Queue, quit(Me))),
|
||||
forall(between(1, Excess, _), thread_get_message(quitted(_)))
|
||||
).
|
||||
|
||||
|
||||
%% http_worker(+Options)
|
||||
%
|
||||
% Run HTTP worker main loop. Workers simply wait until they are
|
||||
% passed an accepted socket to process a client.
|
||||
%
|
||||
% If the message quit(Sender) is read from the queue, the worker
|
||||
% stops.
|
||||
|
||||
http_worker(Options) :-
|
||||
thread_at_exit(done_worker),
|
||||
option(queue(Queue), Options),
|
||||
repeat,
|
||||
garbage_collect,
|
||||
debug(http(worker), 'Waiting for a job ...', []),
|
||||
thread_get_message(Queue, Message),
|
||||
debug(http(worker), 'Got job ~p', [Message]),
|
||||
( Message = quit(Sender)
|
||||
-> !,
|
||||
thread_self(Self),
|
||||
thread_detach(Self),
|
||||
thread_send_message(Sender, quitted(Self))
|
||||
; open_client(Message, Queue, Goal, In, Out,
|
||||
Options, ClientOptions),
|
||||
( catch(http_process(Goal, In, Out, ClientOptions),
|
||||
Error, true)
|
||||
-> true
|
||||
; Error = goal_failed(http_process/4)
|
||||
),
|
||||
( var(Error)
|
||||
-> fail
|
||||
; current_message_level(Error, Level),
|
||||
print_message(Level, Error),
|
||||
memberchk(peer(Peer), ClientOptions),
|
||||
close_connection(Peer, In, Out),
|
||||
fail
|
||||
)
|
||||
).
|
||||
|
||||
|
||||
%% open_client(+Message, +Queue, -Goal, -In, -Out,
|
||||
%% +Options, -ClientOptions) is semidet.
|
||||
%
|
||||
% Opens the connection to the client in a worker from the message
|
||||
% sent to the queue by accept_server/2.
|
||||
|
||||
open_client(requeue(In, Out, Goal, ClOpts),
|
||||
_, Goal, In, Out, Opts, ClOpts) :- !,
|
||||
memberchk(peer(Peer), ClOpts),
|
||||
option(keep_alive_timeout(KeepAliveTMO), Opts, 5),
|
||||
check_keep_alife_connection(In, KeepAliveTMO, Peer, In, Out).
|
||||
open_client(Message, Queue, Goal, In, Out, _Opts,
|
||||
[ pool(client(Queue, Goal, In, Out))
|
||||
| Options
|
||||
]) :-
|
||||
catch(open_client(Message, Goal, In, Out, Options),
|
||||
E, report_error(E)),
|
||||
memberchk(peer(Peer), Options),
|
||||
debug(http(connection), 'Opened connection from ~p', [Peer]).
|
||||
|
||||
|
||||
open_client(Message, Goal, In, Out, Options) :-
|
||||
open_client_hook(Message, Goal, In, Out, Options), !.
|
||||
open_client(tcp_client(Socket, Goal, Peer), Goal, In, Out,
|
||||
[ peer(Peer),
|
||||
protocol(http)
|
||||
]) :-
|
||||
tcp_open_socket(Socket, In, Out).
|
||||
|
||||
report_error(E) :-
|
||||
print_message(error, E),
|
||||
fail.
|
||||
|
||||
|
||||
%% check_keep_alife_connection(+In, +TimeOut, +Peer, +In, +Out) is semidet.
|
||||
%
|
||||
% Wait for the client for at most TimeOut seconds. Succeed if the
|
||||
% client starts a new request within this time. Otherwise close
|
||||
% the connection and fail.
|
||||
|
||||
check_keep_alife_connection(In, TMO, Peer, In, Out) :-
|
||||
stream_property(In, timeout(Old)),
|
||||
set_stream(In, timeout(TMO)),
|
||||
debug(http(keep_alife), 'Waiting for keep-alife ...', []),
|
||||
catch(peek_code(In, Code), E, true),
|
||||
( var(E), % no exception
|
||||
Code \== -1 % no end-of-file
|
||||
-> set_stream(In, timeout(Old)),
|
||||
debug(http(keep_alife), '\tre-using keep-alife connection', [])
|
||||
; ( Code == -1
|
||||
-> debug(http(keep_alife), '\tRemote closed keep-alife connection', [])
|
||||
; debug(http(keep_alife), '\tTimeout on keep-alife connection', [])
|
||||
),
|
||||
close_connection(Peer, In, Out),
|
||||
fail
|
||||
).
|
||||
|
||||
|
||||
%% done_worker
|
||||
%
|
||||
% Called when worker is terminated due to http_workers/2.
|
||||
|
||||
done_worker :-
|
||||
thread_self(Self),
|
||||
thread_property(Self, status(Status)),
|
||||
retract(queue_worker(_Queue, Self)),
|
||||
print_message(informational,
|
||||
httpd_stopped_worker(Self, Status)).
|
||||
|
||||
|
||||
% thread_httpd:message_level(+Exception, -Level)
|
||||
%
|
||||
% Determine the message stream used for exceptions that may occur
|
||||
% during server_loop/5. Being multifile, clauses can be added by
|
||||
% the application to refine error handling. See also
|
||||
% message_hook/3 for further programming error handling.
|
||||
|
||||
:- multifile
|
||||
message_level/2.
|
||||
|
||||
message_level(error(io_error(read, _), _), silent).
|
||||
message_level(error(timeout_error(read, _), _), informational).
|
||||
message_level(keep_alive_timeout, silent).
|
||||
|
||||
current_message_level(Term, Level) :-
|
||||
( message_level(Term, Level)
|
||||
-> true
|
||||
; Level = error
|
||||
).
|
||||
|
||||
|
||||
%% http_requeue(+Header)
|
||||
%
|
||||
% Re-queue a connection to the worker pool. This deals with
|
||||
% processing additional requests on keep-alife connections.
|
||||
|
||||
http_requeue(Header) :-
|
||||
requeue_header(Header, ClientOptions),
|
||||
memberchk(pool(client(Queue, Goal, In, Out)), ClientOptions),
|
||||
thread_send_message(Queue, requeue(In, Out, Goal, ClientOptions)), !.
|
||||
http_requeue(Header) :-
|
||||
debug(http(error), 'Re-queue failed: ~p', [Header]),
|
||||
fail.
|
||||
|
||||
requeue_header([], []).
|
||||
requeue_header([H|T0], [H|T]) :-
|
||||
requeue_keep(H), !,
|
||||
requeue_header(T0, T).
|
||||
requeue_header([_|T0], T) :-
|
||||
requeue_header(T0, T).
|
||||
|
||||
requeue_keep(pool(_)).
|
||||
requeue_keep(peer(_)).
|
||||
requeue_keep(protocol(_)).
|
||||
|
||||
|
||||
%% http_process(Message, Queue, +Options)
|
||||
%
|
||||
% Handle a single client message on the given stream.
|
||||
|
||||
http_process(Goal, In, Out, Options) :-
|
||||
debug(http(server), 'Running server goal ~p on ~p -> ~p',
|
||||
[Goal, In, Out]),
|
||||
option(timeout(TMO), Options, 60),
|
||||
set_stream(In, timeout(TMO)),
|
||||
http_wrapper(Goal, In, Out, Connection,
|
||||
[ request(Request)
|
||||
| Options
|
||||
]),
|
||||
next(Connection, Request).
|
||||
|
||||
next(spawned(ThreadId), _) :- !,
|
||||
debug(http(spawn), 'Handler spawned to thread ~w', [ThreadId]).
|
||||
next(Connection, Request) :-
|
||||
downcase_atom(Connection, 'keep-alive'),
|
||||
http_requeue(Request), !.
|
||||
next(_, Request) :-
|
||||
http_close_connection(Request).
|
||||
|
||||
|
||||
%% http_close_connection(+Request)
|
||||
%
|
||||
% Close connection associated to Request. See also http_requeue/1.
|
||||
|
||||
http_close_connection(Request) :-
|
||||
memberchk(pool(client(_Queue, _Goal, In, Out)), Request),
|
||||
memberchk(peer(Peer), Request),
|
||||
close_connection(Peer, In, Out).
|
||||
|
||||
%% close_connection(+Peer, +In, +Out)
|
||||
%
|
||||
% Closes the connection from the server to the client. Errors are
|
||||
% currently silently ignored.
|
||||
|
||||
close_connection(Peer, In, Out) :-
|
||||
debug(http(connection), 'Closing connection from ~p', [Peer]),
|
||||
catch(close(In, [force(true)]), _, true),
|
||||
catch(close(Out, [force(true)]), _, true).
|
||||
|
||||
%% http_spawn(:Goal, +Options) is det.
|
||||
%
|
||||
% Continue this connection on a new thread. A handler may call
|
||||
% http_spawn/2 to start a new thread that continues processing the
|
||||
% current request using Goal. The original thread returns to the
|
||||
% worker pool for processing new requests. Options are passed to
|
||||
% thread_create/3, except for:
|
||||
%
|
||||
% * pool(+Pool)
|
||||
% Interfaces to library(thread_pool), starting the thread
|
||||
% on the given pool.
|
||||
% * backlog(+MaxBacklog)
|
||||
% Reply using a 503 (service unavailable) if too many requests
|
||||
% are waiting in this pool.
|
||||
|
||||
http_spawn(Goal, Options) :-
|
||||
select_option(pool(Pool), Options, Options1), !,
|
||||
select_option(backlog(BackLog), Options1, ThreadOptions, infinite),
|
||||
check_backlog(BackLog, Pool),
|
||||
current_output(CGI),
|
||||
thread_create_in_pool(Pool,
|
||||
wrap_spawned(CGI, Goal), Id,
|
||||
[ detached(true)
|
||||
| ThreadOptions
|
||||
]),
|
||||
http_spawned(Id).
|
||||
http_spawn(Goal, Options) :-
|
||||
current_output(CGI),
|
||||
thread_create(wrap_spawned(CGI, Goal), Id,
|
||||
[ detached(true)
|
||||
| Options
|
||||
]),
|
||||
http_spawned(Id).
|
||||
|
||||
wrap_spawned(CGI, Goal) :-
|
||||
set_output(CGI),
|
||||
http_wrap_spawned(Goal, Request, Connection),
|
||||
next(Connection, Request).
|
||||
|
||||
%% check_backlog(+MaxBackLog, +Pool)
|
||||
%
|
||||
% Check whether the backlog in the pool has been exceeded. If so,
|
||||
% reply as =busy=, which causes an HTTP 503 response.
|
||||
|
||||
check_backlog(BackLog, Pool) :-
|
||||
integer(BackLog),
|
||||
thread_pool_property(Pool, backlog(Waiting)),
|
||||
Waiting > BackLog, !,
|
||||
throw(http_reply(busy)).
|
||||
check_backlog(_, _).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(httpd_stopped_worker(Self, Status)) -->
|
||||
[ 'Stopped worker ~p: ~p'-[Self, Status] ].
|
||||
20
packages/http/txttotex.pl
Normal file
20
packages/http/txttotex.pl
Normal file
@ -0,0 +1,20 @@
|
||||
:- asserta(user:file_search_path(library, ..)).
|
||||
|
||||
:- load_files([ library(doc_latex),
|
||||
library('http/html_write'),
|
||||
library('http/json'),
|
||||
library('http/json_convert'),
|
||||
library('http/http_json')
|
||||
],
|
||||
[ silent(true)
|
||||
]).
|
||||
|
||||
txttotex :-
|
||||
current_prolog_flag(argv, Argv),
|
||||
append(_, [--|Files], Argv), !,
|
||||
maplist(txttotex, Files).
|
||||
|
||||
txttotex(File) :-
|
||||
file_name_extension(Base, _, File),
|
||||
file_name_extension(Base, tex, TexFile),
|
||||
doc_latex(File, TexFile, [stand_alone(false)]).
|
||||
24
packages/http/web/css/dirindex.css
Normal file
24
packages/http/web/css/dirindex.css
Normal file
@ -0,0 +1,24 @@
|
||||
/* CSS for SWI-Prolog HTTPD directory indices
|
||||
*/
|
||||
|
||||
table.dirindex th.name
|
||||
{ text-align: left;
|
||||
}
|
||||
|
||||
table.dirindex tr.dirindex_header
|
||||
{ background-color: #b0ffb0;
|
||||
}
|
||||
|
||||
table.dirindex tr.odd
|
||||
{ background-color: #d0d0d0;
|
||||
}
|
||||
|
||||
table.dirindex th.modified, th.size
|
||||
{ text-align: right;
|
||||
}
|
||||
|
||||
table.dirindex td.modified, td.size
|
||||
{ text-align: right;
|
||||
padding-left: 10px;
|
||||
font-family: monospace;
|
||||
}
|
||||
42
packages/http/web/css/openid.css
Normal file
42
packages/http/web/css/openid.css
Normal file
@ -0,0 +1,42 @@
|
||||
/* $Id$
|
||||
|
||||
CSS for OpenID module,
|
||||
Author: Jan Wielemaker
|
||||
Copying: Public domain
|
||||
|
||||
For a tutorial on CSS, see
|
||||
<http://www.htmldog.com/guides/cssbeginner/selectors/>
|
||||
*/
|
||||
|
||||
div.openid-title
|
||||
{ margin-bottom: 1em;
|
||||
}
|
||||
|
||||
div.openid-title img
|
||||
{ border: 0;
|
||||
height: 4em;
|
||||
vertical-align: sub;
|
||||
}
|
||||
|
||||
div.openid-title span
|
||||
{ font-size: 2em;
|
||||
font-weight: 300;
|
||||
}
|
||||
|
||||
div.openid-message
|
||||
{ margin-top: 1em;
|
||||
}
|
||||
|
||||
table.openid-form
|
||||
{ margin-top: 1em;
|
||||
}
|
||||
|
||||
table.openid-form td
|
||||
{
|
||||
}
|
||||
|
||||
input.openid-input
|
||||
{ background: #fff url('../icons/openid-logo-tiny.png') no-repeat center left;
|
||||
padding-left: 20px;
|
||||
margin-left: 2cm;
|
||||
}
|
||||
BIN
packages/http/web/icons/back.png
Normal file
BIN
packages/http/web/icons/back.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 284 B |
BIN
packages/http/web/icons/c.png
Normal file
BIN
packages/http/web/icons/c.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 285 B |
BIN
packages/http/web/icons/compressed.png
Normal file
BIN
packages/http/web/icons/compressed.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 315 B |
BIN
packages/http/web/icons/folder.png
Normal file
BIN
packages/http/web/icons/folder.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 272 B |
BIN
packages/http/web/icons/generic.png
Normal file
BIN
packages/http/web/icons/generic.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 260 B |
BIN
packages/http/web/icons/layout.png
Normal file
BIN
packages/http/web/icons/layout.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 306 B |
BIN
packages/http/web/icons/openid-logo-square.png
Normal file
BIN
packages/http/web/icons/openid-logo-square.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 2.2 KiB |
BIN
packages/http/web/icons/openid-logo-tiny.png
Normal file
BIN
packages/http/web/icons/openid-logo-tiny.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 493 B |
286
packages/http/xpce_httpd.pl
Normal file
286
packages/http/xpce_httpd.pl
Normal file
@ -0,0 +1,286 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2005, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(xpce_httpd,
|
||||
[ http_current_server/2, % ?:Goal, ?Port
|
||||
http_server/2 % :Goal, :Options
|
||||
]).
|
||||
:- use_module(library(pce)).
|
||||
:- use_module(http_header).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(http_wrapper).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
:- meta_predicate
|
||||
http_server(:, ?),
|
||||
http_server(:, ?, +).
|
||||
|
||||
% @http_servers: keep track of them and avoid the servers being
|
||||
% garbage collected.
|
||||
|
||||
:- pce_global(@http_servers, new(chain)).
|
||||
|
||||
%:- debug(connection).
|
||||
|
||||
http_current_server(Goal, Port) :-
|
||||
object(@open_sockets),
|
||||
chain_list(@open_sockets, Sockets),
|
||||
member(Socket, Sockets),
|
||||
send(Socket, instance_of, interactive_httpd),
|
||||
get(Socket, goal, Goal),
|
||||
get(Socket, address, Port).
|
||||
|
||||
%% http_server(:Goal, +Options) is det.
|
||||
%
|
||||
% Start server at given or arbitrary port.
|
||||
|
||||
http_server(Goal, Options) :-
|
||||
select(port(Port), Options, Options1), !,
|
||||
http_server(Goal, Port, Options1).
|
||||
http_server(_Goal, _Options) :-
|
||||
throw(error(existence_error(option, port), _)).
|
||||
|
||||
http_server(Goal, Port, _Options) :-
|
||||
strip_module(Goal, M, PlainGoal),
|
||||
( var(Port)
|
||||
-> new(X, interactive_httpd(M:PlainGoal)),
|
||||
get(X, address, Port)
|
||||
; new(X, interactive_httpd(M:PlainGoal, Port))
|
||||
).
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
XPCE based socket handling for generic HTTP interface infra-structure.
|
||||
This module acts as a replacement for inetd_httpd, which allows a Prolog
|
||||
process to acts as an inet-driven HTTP server.
|
||||
|
||||
Using this module the user can easily debug HTTP connections or provide
|
||||
services while running the XPCE GUI.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
:- pce_begin_class(interactive_httpd, socket,
|
||||
"Prolog HTTP debugger").
|
||||
|
||||
variable(allowed_hosts, chain*, both, "Chain of regex with acceptable peers").
|
||||
variable(goal, prolog, get, "Goal to use for processing").
|
||||
variable(out_stream, prolog, get, "Stream for output").
|
||||
variable(peer, name, get, "Peer connection (host only)").
|
||||
variable(request, string*, get, "Data for first line").
|
||||
variable(data, string*, get, "Data for POST request").
|
||||
variable(chunk_data, string*, get, "Collect chunked input").
|
||||
variable(mode,
|
||||
{request,header,post_content_length,chunked} := request,
|
||||
get, "Mode of operation").
|
||||
|
||||
:- pce_global(@http_end_header_regex,
|
||||
new(regex('\n\r?\n\r?'))).
|
||||
:- pce_global(@http_end_line_regex,
|
||||
new(regex('\n\r?'))).
|
||||
:- pce_global(@http_has_header_regex,
|
||||
new(regex('[^\n]*HTTP/'))).
|
||||
|
||||
initialise(S, Goal:prolog, Port:[int]) :->
|
||||
default(Port, 0, ThePort), % anonymous
|
||||
send_super(S, initialise, ThePort),
|
||||
send(S, slot, goal, Goal),
|
||||
send(S, record_separator, @http_end_line_regex),
|
||||
send(S, input_message, message(@receiver, input, @arg1)),
|
||||
send(S, accept_message, message(@arg1, accepted)),
|
||||
send(S, listen, reuse := @on),
|
||||
send(@http_servers, append, S).
|
||||
|
||||
unlink(S) :->
|
||||
send(@http_servers, delete_all, S),
|
||||
send_super(S, unlink).
|
||||
|
||||
:- pce_group(connection).
|
||||
|
||||
accepted(S) :->
|
||||
"A new connection is established on this socket"::
|
||||
( pce_catch_error(_, get(S, peer_name, tuple(Peer, _Port)))
|
||||
-> send(S, slot, peer, Peer),
|
||||
send(S, authorise),
|
||||
debug(connection, 'New connection from ~w', [Peer]),
|
||||
pce_open(S, append, Fd),
|
||||
send(S, slot, out_stream, Fd)
|
||||
; debug(connection, 'Cannot get peer: closing.', []),
|
||||
free(S)
|
||||
).
|
||||
|
||||
authorise(S) :->
|
||||
"See whether we will proceeed with this connection"::
|
||||
get(S, allowed_hosts, Allowed),
|
||||
( Allowed == @nil
|
||||
-> true
|
||||
; get(S, peer, Peer),
|
||||
get(Allowed, find,
|
||||
message(@arg1, match, Peer),
|
||||
_)
|
||||
-> true
|
||||
; debug(connection, 'Refused connection from ~w', [Peer]),
|
||||
free(S),
|
||||
fail
|
||||
).
|
||||
|
||||
unlink(S) :->
|
||||
( debugging(connection)
|
||||
-> get(S, peer, Peer),
|
||||
debug(connection, 'Closed connection from ~w', [Peer])
|
||||
; true
|
||||
),
|
||||
( get(S, slot, out_stream, Fd),
|
||||
Fd \== @nil
|
||||
-> catch(close(Fd), _, true)
|
||||
; true
|
||||
),
|
||||
send_super(S, unlink).
|
||||
|
||||
:- pce_group(request).
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
->input collects input from the stream until an entire request is
|
||||
complete. A request consists of one of the following:
|
||||
|
||||
<Request> ::= <Action> <Path>\n
|
||||
| <Action> <Path> HTTP/<Version>\n
|
||||
<Header>
|
||||
<Post Data>?
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
input(S, Input:string) :->
|
||||
"Process input. The argument is the header"::
|
||||
get(S, mode, Mode),
|
||||
( debugging(input)
|
||||
-> send(@pce, format, 'GOT (mode %s): "%s"\n', Mode, Input)
|
||||
; true
|
||||
),
|
||||
( Mode == request % got first line
|
||||
-> ( send(@http_has_header_regex, match, Input)
|
||||
-> send(S, slot, request, Input),
|
||||
send(S, slot, mode, header),
|
||||
send(S, record_separator, @http_end_header_regex)
|
||||
; send(S, dispatch, Input)
|
||||
)
|
||||
; Mode == header
|
||||
-> send(Input, prepend, S?request),
|
||||
send(S, slot, request, @nil),
|
||||
( send(S, collect_post_data, Input)
|
||||
-> true
|
||||
; send(S, dispatch, Input)
|
||||
)
|
||||
; Mode == post_content_length
|
||||
-> send(S, slot, mode, request),
|
||||
send(S, record_separator, @http_end_line_regex),
|
||||
get(S, data, Header),
|
||||
send(Header, append, Input),
|
||||
send(Header, lock_object, @on),
|
||||
send(S, slot, data, @nil),
|
||||
send(S, dispatch, Header),
|
||||
send(Header, lock_object, @off)
|
||||
; Mode == chunked
|
||||
-> get(S, chunk_data, ChunkData),
|
||||
( get(S, record_separator, Bytes),
|
||||
integer(Bytes)
|
||||
-> send(ChunkData, append, Input),
|
||||
send(S, record_separator, '\n')
|
||||
; send(Input, prepend, '0x'),
|
||||
get(Input, value, HexAtom),
|
||||
term_to_atom(Bytes, HexAtom),
|
||||
( Bytes == 0
|
||||
-> get(S, data, Header),
|
||||
get(ChunkData, size, ContentLength),
|
||||
send(@http_chunked_regex, search, Header),
|
||||
send(@http_chunked_regex, register_value, 0, Header,
|
||||
string('Content-Length: %d', ContentLength)),
|
||||
send(Header, append, ChunkData),
|
||||
send(S, slot, chunk_data, @nil),
|
||||
send(S, slot, mode, request),
|
||||
send(S, record_separator, @http_end_line_regex),
|
||||
send(S, dispatch, Header)
|
||||
; send(S, record_separator, Bytes)
|
||||
)
|
||||
)
|
||||
).
|
||||
|
||||
|
||||
dispatch(S, Input:string) :->
|
||||
"Hand complete input for dispatching"::
|
||||
( debugging(dispatch)
|
||||
-> send(@pce, write_ln, Input)
|
||||
; true
|
||||
),
|
||||
pce_open(Input, read, In),
|
||||
get(S, goal, Goal),
|
||||
get(S, out_stream, Out),
|
||||
( catch(http_wrapper(Goal, In, Out, Close, []),
|
||||
E, wrapper_error(E))
|
||||
-> close(In),
|
||||
( downcase_atom(Close, 'keep-alive')
|
||||
-> send(S, slot, mode, request), % prepare for next
|
||||
send(S, record_separator, @http_end_line_regex),
|
||||
send(S, slot, data, @nil)
|
||||
; free(S)
|
||||
)
|
||||
; close(In), % exception or failure
|
||||
free(S)
|
||||
).
|
||||
|
||||
wrapper_error(Error) :-
|
||||
( debugging(connection)
|
||||
-> print_message(error, Error)
|
||||
; true
|
||||
),
|
||||
fail.
|
||||
|
||||
:- pce_group(post).
|
||||
|
||||
|
||||
:- pce_global(@http_content_length_regex,
|
||||
new(regex('^Content-Length:[[:blank:]]*([0-9]+)', @off))).
|
||||
:- pce_global(@http_chunked_regex,
|
||||
new(regex('^Transfer-encoding:[[:blank:]]*chunked', @off))).
|
||||
|
||||
|
||||
collect_post_data(S, Header:string) :->
|
||||
( send(@http_content_length_regex, search, Header)
|
||||
-> get(@http_content_length_regex, register_value, Header,
|
||||
1, int, Len),
|
||||
debug(dispatch, '[POST] Content-length: ~w~n', [Len]),
|
||||
send(S, slot, mode, post_content_length),
|
||||
send(S, slot, data, Header),
|
||||
send(S, record_separator, Len)
|
||||
; send(@http_chunked_regex, search, Header)
|
||||
-> send(S, slot, mode, chunked),
|
||||
send(S, slot, chunk_data, new(string)),
|
||||
send(S, record_separator, '\n')
|
||||
).
|
||||
|
||||
:- pce_end_class(interactive_httpd).
|
||||
|
||||
Reference in New Issue
Block a user