This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
vsc e5f4633c39 This commit was generated by cvs2svn to compensate for changes in r4,
which included commits to RCS files with non-trunk default branches.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@5 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2001-04-09 19:54:03 +00:00

1945 lines
54 KiB
Prolog

% Copyright (C) 1996/1997/1998/1999/2000 CLIP.
% This package is free software; you can redistribute it and/or
% modify it under the terms of the GNU Library General Public
% License as published by the Free Software Foundation; either
% version 2 of the License, or (at your option) any later version.
%
% This package 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
% Library General Public License for more details.
%
% You should have received a copy of the GNU Library General Public
% License along with this package; if not, write to the Free
% Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
%
% M. Hermenegildo (herme@fi.upm.es) & D. Cabeza (dcabeza@fi.upm.es)
:- module(pillow, [
output_html/1, html2terms/2, xml2terms/2, html_template/3,
html_report_error/1, get_form_input/1, get_form_value/3,
form_empty_value/1, form_default/3, % text_lines/2,
set_cookie/2, get_cookies/1, url_query/2, my_url/1,
url_info/2, url_info_relative/3,
form_request_method/1, icon_address/2, html_protect/1,
http_lines/3,
fetch_url/3]).
:- op(150,xfx,'$').
:- op(150,fx,'$').
% :- comment(title, "HTML/XML/CGI programming").
% :- comment(author, "Daniel Cabeza").
% :- comment(author, "Manuel Hermenegildo").
% :- comment(author, "Sacha Varma").
% :- comment(module, "This module implements the predicates of the PiLLoW
% package related to @concept{HTML}/@concept{XML} generation and
% parsing, @concept{CGI} and form handlers programming, and in general
% all the predicates which do not imply the use of the HTTP
% protocol.").
% :- comment(appendix, "The code uses input from from L. Naish's forms and
% F. Bueno's previous Chat interface. Other people who have
% contributed is (please inform us if we leave out anybody):
% Markus Fromherz, Samir Genaim.").
%%% Some icon addresses %%%
:- include(icon_address).
% :- comment(icon_address(Img, IAddress), "The PiLLoW image @var{Img} has
% URL @var{IAddress}.").
% :- true pred icon_address(?atm,?atm).
icon_address(Img, IAddress):-
icon_base_address(BAddress),
icon_img(Img,ImgSrc),
atom_concat(BAddress,ImgSrc,IAddress).
icon_img(warning,'warning_large.gif').
icon_img(dot,'redball.gif').
icon_img(clip,'clip.gif').
icon_img(pillow,'pillow_d.gif').
%%% HTML <-> Terms translation %%%
% The idea is to have a CIAO/Prolog syntax description of a document as
% a term and then use html2terms/2 to translate the term into a string for
% writing and to translate a string to a term for reading
% :- true pred html_expansion(Term,Expansion)
% # "Hook predicate to define macros. Expand occurrences of
% @var{Term} into @var{Expansion}, in @pred{output_html/1}.
% Take care to not transform something into itself!".
:- multifile html_expansion/2.
html_expansion(bf(X),b(X)).
html_expansion(it(X),i(X)).
html_expansion(pr,
ref("http://www.clip.dia.fi.upm.es/Software/pillow/pillow.html",
image(Pillow, [alt="developed with PiLLoW",border=0,align=bottom]))
) :-
icon_address(pillow,Pillow).
% :- comment(output_html(HTMLTerm), "Outputs @var{HTMLTerm}, interpreted
% as an @pred{html_term/1}, to current output stream.").
% :- true pred output_html(+html_term).
% Translate html format and send to current output
output_html(F) :-
html_term(F,T,[]),
write_string(T).
% :- true pred html_report_error(Error)
% # "Outputs error @var{Error} as a standard HTML page.".
% Error handling
html_report_error(X) :-
(icon_address(warning,Icon) -> Image = image(Icon); Image = ""),
output_html([
cgi_reply,
start,
title("Error Report"),
--,
h1([ Image, ' Error:' ]),
--,
X,
--,
end]),
flush_output,
halt.
% HTML <-> Terms translation
% :- comment(html2terms(String,Terms), "@var{String} is a character list
% containing HTML code and @var{Terms} is its prolog structured
% representation.").
% :- true pred html2terms(-string,+html_term)
% # "Translates an HTML-term into the HTML code it represents.".
% :- true pred html2terms(+string,?canonic_html_term)
% # "Translates HTML code into a structured HTML-term.".
html2terms(Chars, Terms) :-
var(Chars), !,
html_term(Terms, Chars, []).
html2terms(Chars, Terms) :-
parse_html([], Terms, [], Chars, []).
% XML <-> Terms translation
% :- comment(xml2terms(String,Terms), "@var{String} is a character list
% containing XML code and @var{Terms} is its prolog structured
% representation.").
% :- true pred xml2terms(-string,+html_term)
% # "Translates a XML-term into the XML code it represents.".
% :- true pred xml2terms(+string,?canonic_xml_term)
% # "Translates XML code into a structured XML-term.".
xml2terms(Chars, Terms) :-
var(Chars), !,
html_term(Terms, Chars, []). % Uses the same as HTML
xml2terms(Chars, Terms) :-
parse_xml([], Terms, [], Chars, []).
%% Terms -> HTML/XML translation %%
html_term(X) --> {var(X)}, !,
"<b>**Warning free variable**</b>".
html_term(T) --> {html_expansion(T,NT)}, !,
html_term(NT).
html_term(start) --> !, "<html>".
html_term(end) --> !, "</html>".
html_term(--) --> !, newline, "<hr>", newline.
html_term(\\) --> !, "<br>", newline.
html_term($) --> !, newline, "<p>".
html_term(comment(C)) --> !,
"<!-- ",atomic_or_string(C)," -->",
newline.
html_term(declare(C)) --> !,
"<!",atomic_or_string(C),">",
newline.
% XML declaration
html_term(xmldecl(Atts)) --> !,
"<?xml",
html_atts(Atts),
"?>".
html_term(image(Addr)) --> !,
"<img",
html_atts([src=Addr]),
">".
html_term(image(Addr,Atts)) --> !,
"<img",
html_atts([src=Addr|Atts]),
">".
html_term(ref(Addr,Text)) --> !,
"<a",
html_atts([href=Addr]),
">",
html_term(Text),
"</a>".
html_term(label(Label,Text)) --> !,
"<a",
html_atts([name=Label]),
">",
html_term(Text),
"</a>".
html_term(heading(L,X)) -->
{number_codes(L,[N])}, !,
html_env([0'h,N],X),
newline.
html_term(itemize(L)) --> !,
"<ul>",
newline,
html_items(L),
"</ul>".
html_term(enumerate(L)) --> !,
"<ol>",
newline,
html_items(L),
"</ol>".
html_term(description(L)) --> !,
"<dl>",
newline,
html_descriptions(L),
"</dl>".
html_term(nice_itemize(Dot, L)) --> !,
"<dl>",
newline,
{atom(Dot) -> atom_codes(Dot,D) ; D = Dot},
html_nice_items(L, D),
"</dl>".
html_term(preformatted(X)) --> !,
"<pre>",
newline,
preformatted_lines(X),
"</pre>".
html_term(entity(Name)) --> !,
"&",atomic_or_string(Name),";".
% Forms
html_term(start_form) --> !,
"<form",
html_atts([method="POST"]),
">",
newline.
html_term(start_form(Addr)) --> !,
"<form",
html_atts([method="POST", action=Addr]),
">",
newline.
html_term(start_form(Addr,Atts)) --> !,
"<form",
html_atts([action=Addr|Atts]),
">",
newline.
html_term(end_form) --> !,
"</form>", newline.
html_term(checkbox(Name,on)) --> !,
"<input",
html_atts([name=Name,type=checkbox,checked]),
">".
html_term(checkbox(Name,_)) --> !,
"<input",
html_atts([name=Name,type=checkbox]),
">".
html_term(radio(Name,Value,Value)) --> !,
"<input",
html_atts([name=Name,type=radio,value=Value,checked]),
">".
html_term(radio(Name,Value,_)) --> !,
"<input",
html_atts([name=Name,type=radio,value=Value]),
">".
html_term(input(Type,Atts)) --> !,
"<input",
html_atts([type=Type|Atts]),
">".
html_term(textinput(Name,Atts,Text)) --> !,
"<textarea",
html_atts([name=Name|Atts]),
">",
textarea_data(Text),
"</textarea>".
html_term(menu(Name,Atts,Items)) --> !,
"<select",
html_atts([name=Name|Atts]),
">", newline,
html_options(Items),
"</select>".
html_term(option(Name,Val,Options)) --> !,
"<select",
html_atts([name=Name]),
">", newline,
html_one_option(Options, Val),
"</select>".
html_term(form_reply) --> !,
"Content-type: text/html",
newline,
newline.
html_term(cgi_reply) --> !,
"Content-type: text/html",
newline,
newline.
html_term(prolog_term(T)) --> !,
prolog_term(T).
% Constructs
html_term(verbatim(Text)) --> !,
html_quoted(Text).
html_term(nl) --> !, newline. % Just to improve HTML source readability
html_term([]) --> !.
html_term([E|Es]) --> !,
html_term(E),
html_term(Es).
html_term(begin(T)) --> {atom(T), atom_codes(T,TS)}, !,
"<",string(TS),">".
html_term(begin(T,Atts)) --> {atom(T), atom_codes(T,TS)}, !,
"<",string(TS),
html_atts(Atts),
">".
html_term(end(T)) --> {atom(T), atom_codes(T,TS)}, !,
"</",string(TS),">".
html_term(env(Name,Atts,Text)) --> {atom(Name), atom_codes(Name,NS)}, !,
html_env_atts(NS,Atts,Text).
html_term(T$Atts) --> {atom(T), atom_codes(T,TS)}, !,
"<",string(TS),
html_atts(Atts),
">".
% XML empty element
html_term(elem(N,Atts)) --> {atom(N), atom_codes(N,NS)}, !,
"<",string(NS),
html_atts(Atts),
"/>".
html_term(F) --> {F =.. [Env,X], atom_codes(Env, ES)}, !,
html_env(ES,X).
html_term(F) --> {F =.. [Env,Atts,X], atom_codes(Env, ES)}, !,
html_env_atts(ES,Atts,X).
html_term(C) --> {integer(C), C >= 0, C =< 255}, !, [C].
html_term(T) -->
prolog_term(T).
newline --> [10].
html_atts([]) --> [].
html_atts([A|As]) -->
" ",
html_att(A),
html_atts(As).
html_att(A=V) --> {atom_codes(A,AS)}, !,
string(AS),"=""",atomic_or_string(V),"""".
html_att(A) --> {atom_codes(A,AS)},
string(AS).
html_env(E,I) -->
"<",string(E),">",
html_term(I),
"</",string(E),">".
html_env_atts(E,Atts,I) -->
"<",string(E),
html_atts(Atts),
">",
html_term(I),
"</",string(E),">".
html_items([]) --> [].
html_items([It|Its]) -->
"<li>",
html_term(It),
"</li>",
newline,
html_items(Its).
html_descriptions([]) --> [].
html_descriptions([D|Ds]) -->
html_description(D),
html_descriptions(Ds).
html_description((T,D)) --> !,
"<dt>",
html_term(T),
"</dt>",
newline,
html_description(D).
html_description(D) -->
"<dd>",
html_term(D),
"</dd>",
newline.
html_nice_items([],_) --> [].
html_nice_items([It|Its],Dot) -->
"<dd><img src=""",
string(Dot),
""" align=""bottom"" alt=""*"">",
html_term(It),
"</dd>",
newline,
html_nice_items(Its, Dot).
preformatted_lines([]) --> [].
preformatted_lines([X|Xs]) -->
html_term(X),
newline,
preformatted_lines(Xs).
html_options([]) --> [].
html_options([Op|Ops]) -->
html_option(Op),
newline,
html_options(Ops).
html_option($Op) --> !,
"<option selected>",atomic_or_string(Op),"</option>".
html_option(Op) -->
"<option>",atomic_or_string(Op),"</option>".
html_one_option([], _) --> [].
html_one_option([Op|Ops], Sel) -->
"<option",
html_one_option_sel(Op, Sel),
">",atomic_or_string(Op),"</option>",
newline,
html_one_option(Ops, Sel).
html_one_option_sel(Op, Op) --> !, " selected".
html_one_option_sel(_, _) --> "".
html_quoted(T) -->
{atom(T) -> atom_codes(T,TS) ; TS = T},
html_quoted_chars(TS).
html_quoted_chars([]) --> [].
html_quoted_chars([C|T]) -->
html_quoted_char(C),
html_quoted_chars(T).
html_quoted_char(0'>) --> !, "&gt;".
html_quoted_char(0'<) --> !, "&lt;".
html_quoted_char(0'&) --> !, "&amp;".
html_quoted_char(0'") --> !, "&quot;".
html_quoted_char(0' ) --> !, "&nbsp;".
html_quoted_char(C) --> [C].
prolog_term(V) -->
{var(V)}, !, "_".
prolog_term(T) -->
{functor(T,F,A), name(F,FS)},
string(FS), prolog_term_maybe_args(A,T).
prolog_term_maybe_args(0,_) --> !, "".
prolog_term_maybe_args(A,T) -->
"(",
prolog_term_args(1,A,T),
")".
prolog_term_args(N, N, T) --> !,
{arg(N,T,A)},
prolog_term(A).
prolog_term_args(N, M, T) -->
{arg(N,T,A)},
prolog_term(A),
",",
{N1 is N+1},
prolog_term_args(N1,M,T).
%% HTML -> Terms translation %%
% :- comment(html_template(Chars, Terms, Dict), "Interprets @var{Chars} as
% an HTML template returning in @var{Terms} the corresponding
% structured HTML-term, which includes variables, and unifying
% @var{Dict} with a dictionary of those variables (an incomplete list of
% @em{name}@tt{=}@em{Var} pairs). An HTML template is standard HTML
% code, but in which ``slots'' can be defined and given an identifier.
% These slots represent parts of the HTML code in which other HTML code
% can be inserted, and are represented in the HTML-term as free
% variables. There are two kinds of variables in templates:
% @begin{itemize}
%
% @item Variables representing page contents. A variable with name
% @em{name} is defined with the special tag @tt{<V>}@em{name}@tt{</V>}.
%
% @item Variables representing tag attributes. They occur as an
% attribute or an attribute value starting with @tt{_}, followed by its
% name, which must be formed by alphabetic characters.
%
% @end{itemize}
%
% As an example, suposse the following HTML template:
% @begin{verbatim}
% @includeverbatim{examples/template.html}
% @end{verbatim}
% The following query in the Ciao toplevel shows how the template is
% parsed, and the dictionary returned:
% @begin{verbatim}
% ?- file_to_string('template.html',_S), html_template(_S,Terms,Dict).
%
% Dict = [bgcolor=_A,content=_B|_],
% Terms = [env(html,[],[\"
% \",env(body,[bgcolor=_A],[\"
% \",_B,\"
% \"]),\"
% \"]),\"
% \"] ?
%
% yes
% @end{verbatim}
% If a dictionary with values is supplied at call time, then variables
% are unified accordingly inside the template:
% @begin{verbatim}
% ?- file_to_string('template.html',_S),
% html_template(_S,Terms,[content=b(\"hello world!\"),bgcolor=\"white\"]).
%
% Terms = [env(html,[],[\"
% \",env(body,[bgcolor=\"white\"],[\"
% \",b(\"hello world!\"),\"
% \"]),\"
% \"]),\"
% \"] ?
%
% yes
% @end{verbatim}
% ").
% :- true pred html_template(+string,?canonic_html_term,?list).
html_template(Chars, Terms, Dict) :-
parse_html([], Terms, Dict, Chars, []).
% see a '<' - possible item
parse_html(Stack,NStack,Dict) -->
"<",
{tidy_string(Stack, Stack2)},
html_unit(Stack2,Stack3,Dict), !,
parse_html(Stack3,NStack,Dict).
% build on an open string
parse_html([Elem|Stack],NStack,Dict) -->
{nonvar(Elem), Elem = string(S,T)},
[C], !,
{T = [C|TT]},
parse_html([string(S,TT)|Stack],NStack,Dict).
% open a new string
parse_html(Stack,NStack,Dict) -->
[C], !,
parse_html([string([C|T],T)|Stack],NStack,Dict).
% base case - close open strings
parse_html(Stack,NStack,_Dict) --> "",
{tidy_string(Stack,Stack2),
reverse(Stack2,NStack)}.
% env terminators
html_unit(S,NS,Dict) -->
"/",
html_tag(N),
whitespace0,
">",
{ poptokenstack(N,S,NS,Dict) },
!.
% comment
html_unit(S,[comment(Text)|S],_Dict) -->
"!--",
string(Text),
"-->",
!.
% declaration
html_unit(S,[declare(Text)|S],_Dict) -->
"!",
string(Text),
">",
!.
% items
html_unit(S,[N$A|S],Dict) -->
html_tag(N),
html_tag_atts(A,Dict),
whitespace0,
">",
!.
html_tag(N) -->
loupalpha(C),
html_tag_rest(Cs),
{ atom_codes(N,[C|Cs]) }.
html_tag_rest([C|Cs]) -->
html_tag_char(C), !,
html_tag_rest(Cs).
html_tag_rest([]) --> "".
html_tag_char(C) --> loupalpha(C).
html_tag_char(C) --> digit(C).
html_tag_char(0'.) --> ".".
html_tag_char(0'-) --> "-".
html_tag_atts([],_Dict) --> "".
html_tag_atts([A|As],Dict) -->
whitespace,
html_tag_att(A,Dict),
html_tag_atts(As,Dict).
% template variable
html_tag_att(A,Dict) -->
"_", html_tag(N),
{list_lookup(Dict, (=), N, V)},
html_opt_value(A, V, Dict).
html_tag_att(A,Dict) -->
html_tag(N),
html_opt_value(A, N, Dict).
html_opt_value(N = V, N, Dict) -->
whitespace0,
"=",
whitespace0,
html_value(V, Dict), !.
html_opt_value(N, N,_Dict) --> "".
% template variable
html_value(V, Dict) -->
"_",
html_tag(N),
{list_lookup(Dict, (=), N, V)}.
% html_value(V,_Dict) --> http_lo_up_token(V). % People do not write valid HTML
html_value(V,_Dict) --> http_quoted_string(V).
html_value(V,_Dict) --> html_lax_value(V).
html_lax_value([C|Cs]) --> [C], { C \== 0'> , C > 32 },
html_lax_value(Cs).
html_lax_value([]) --> "".
poptokenstack(EnvTag,Stack,NStack,Dict) :-
pop_ts(EnvTag,Stack,[],NStack,Dict),
!.
poptokenstack(EnvTag,Stack,[SlashEnvTag$[]|Stack],_) :-
atom_concat('/',EnvTag,SlashEnvTag).
pop_ts(EnvTag,[Elem|S],Insides,NS,Dict) :-
( nonvar(Elem), Elem = EnvTag$Atts ->
elem_or_template_var(EnvTag,Atts,Insides,E,Dict),
NS = [E|S]
; pop_ts(EnvTag,S,[Elem|Insides],NS,Dict)
).
elem_or_template_var('v',_,[NameS],Var,Dict) :-
catch(atom_codes(Name,NameS), _, fail),
list_lookup(Dict, (=), Name, Var), !.
elem_or_template_var(EnvTag,Atts,Insides,env(EnvTag,Atts,Insides),_).
tidy_string([Elem|Stack],[L|Stack]) :-
nonvar(Elem), Elem = string(L,T), !, T = [].
tidy_string(Stack,Stack).
%% XML -> Terms translation %%
parse_xml(Stack,NStack,Dict) -->
"<",
{tidy_string(Stack, Stack2)},
xml_unit(Stack2,Stack3,Dict), !,
parse_xml(Stack3,NStack,Dict).
% build on an open string
parse_xml([Elem|Stack],NStack,Dict) -->
{nonvar(Elem), Elem = string(S,T)},
[C], !,
{T = [C|TT]},
parse_xml([string(S,TT)|Stack],NStack,Dict).
% open a new string
parse_xml(Stack,NStack,Dict) -->
[C], !,
parse_xml([string([C|T],T)|Stack],NStack,Dict).
% base case - close open strings
parse_xml(Stack,NStack,_Dict) --> "",
{tidy_string(Stack,Stack2),
reverse(Stack2,NStack)}.
% env terminators
xml_unit(S,NS,Dict) -->
"/",
xml_tag(N),
whitespace0,
">",
{ poptokenstack(N,S,NS,Dict) },
!.
% comment
xml_unit(S,[comment(Text)|S],_Dict) -->
"!--",
string(Text),
"-->",
!.
% declaration
xml_unit(S,[declare(Text)|S],_Dict) -->
"!",
string(Text),
">",
!.
% xml declarations
xml_unit(S,[xmldecl(Ats)|S],Dict) -->
"?xml",
xml_tag_atts(Ats,Dict),
whitespace0,
"?>",
!.
% elements or env beginnings
xml_unit(S,[El|S],Dict) -->
xml_tag(N),
xml_tag_atts(A,Dict),
whitespace0,
elem_envbeg(El, N, A),
">",
!.
elem_envbeg(elem(N,A), N, A) -->
"/", !.
elem_envbeg(N$A,N, A) --> "".
xml_tag(N) -->
xml_tag_start(C),
xml_tag_rest(Cs),
{ atom_codes(N,[C|Cs]) }.
xml_tag_atts([],_Dict) --> "".
xml_tag_atts([A|As],Dict) -->
whitespace,
xml_tag_att(A,Dict),
xml_tag_atts(As,Dict).
xml_tag_att(N=V,Dict) -->
xml_tag(N),
whitespace0,
"=",
whitespace0,
xml_value(V, Dict).
xml_value(V, Dict) -->
"_",
xml_tag(N),
{list_lookup(Dict, (=), N, V)}.
xml_value(V,_Dict) -->
"""",
xml_quoted_string(0'",V).
xml_value(V,_Dict) -->
"'",
xml_quoted_string(0'',V).
xml_value(V,_Dict) --> % This is not correct syntax
xml_bad_value(V).
xml_quoted_string(Q, []) --> [Q], !.
xml_quoted_string(Q, [0'&,0'q,0'u,0'o,0't,0';|Cs]) -->
"""",
xml_quoted_string(Q, Cs).
xml_quoted_string(Q, [C|Cs]) -->
[C],
xml_quoted_string(Q, Cs).
xml_bad_value([]) --> "".
xml_bad_value([C|Cs]) -->
[C],
xml_bad_value(Cs).
xml_tag_start(C) --> loalpha(C).
xml_tag_start(C) --> upalpha(C).
xml_tag_start(0'_) --> "_".
xml_tag_start(0':) --> ":".
xml_tag_rest([C|Cs]) -->
xml_tag_char(C), !,
xml_tag_rest(Cs).
xml_tag_rest([]) --> "".
xml_tag_char(C) --> loalpha(C).
xml_tag_char(C) --> upalpha(C).
xml_tag_char(C) --> digit(C).
xml_tag_char(0'_) --> "_".
xml_tag_char(0':) --> ":".
xml_tag_char(0'.) --> ".".
xml_tag_char(0'-) --> "-".
%%% Parsing of forms input %%%
% :- comment(get_form_input(Dict), "Translates input from the form (with
% either the POST or GET methods, and even with CONTENT_TYPE
% multipart/form-data) to a dictionary @var{Dict} of
% @em{attribute}=@em{value} pairs. It translates empty values (which
% indicate only the presence of an attribute) to the atom
% @tt{'$empty'}, values with more than one line (from text areas or
% files) to a list of lines as strings, the rest to atoms or numbers
% (using @pred{name/2}).").
% :- true pred get_form_input(-form_dict).
get_form_input(Dic) :-
form_request_method(M),
get_form_input_method(M, Dic), !.
get_form_input([]).
get_form_input_method('GET', Dic) :-
getenvstr('QUERY_STRING',Q), Q \== [] ->
append(Q,"&",Cs),
form_urlencoded_to_dic(Dic, Cs, [])
; Dic = [].
get_form_input_method('POST', Dic) :-
getenvstr('CONTENT_TYPE', ContentType),
http_media_type(Type,Subtype,Params,ContentType,[]),
get_form_input_of_type(Type,Subtype,Params,Dic).
get_form_input_method(M, _) :-
html_report_error(['Unknown request method ', tt(M),
' or bad request.']).
get_form_input_of_type(application, 'x-www-form-urlencoded', _, Dic) :-
getenvstr('CONTENT_LENGTH', N),
number_codes(No,N),
( No > 0 ->
read_all(No,Cs,"&"),
form_urlencoded_to_dic(Dic, Cs, [])
; Dic = []
).
get_form_input_of_type(multipart, 'form-data', Params, Dic) :-
member((boundary=B), Params),
name(B, BS),
Boundary = [0'-,0'-|BS],
get_lines_to_boundary(Boundary, _, End),
get_multipart_form_data(End, Boundary, Dic).
get_form_input_of_type(Type,Subtype,_,_) :-
html_report_error(['Unknown Content-type ',tt([Type,"/",Subtype]),
' or bad request.']).
% read N chars from input (N>=0)
read_all(0) --> !, "".
read_all(N) -->
{get_code(C)},
[C],
{N1 is N - 1},
read_all(N1).
% Converts string "name1=val1&name2=val2&name3=&" into
% list of pairs [name1='val1', name2='val2', name3='$empty'] etc
% Funny chars, eg = and & never occur in vals (they appear as
% escape sequences)
form_urlencoded_to_dic([]) --> "".
form_urlencoded_to_dic([N1=V1|NVs]) -->
chars_to(N,0'=),
{name(N1, N)},
chars_to(V,0'&),
{expand_esc_plus(V,EV,[13,10]),
http_lines(Ls, EV, []),
to_value(Ls,V1)},
form_urlencoded_to_dic(NVs).
chars_to([],C) --> [C].
chars_to([C|Cs],D) -->
[C],
{C \== D},
chars_to(Cs,D).
% Expands escape sequences and converts "+" back into " " in a string
expand_esc_plus([]) --> "".
expand_esc_plus([0'+|Cs]) --> !,
" ",
expand_esc_plus(Cs).
expand_esc_plus([0'%,C1,C2|Cs]) --> !,
{hex_digit(C1,D1),
hex_digit(C2,D2),
C is D1 * 16 + D2},
[C],
expand_esc_plus(Cs).
expand_esc_plus([C|Cs]) -->
[C],
expand_esc_plus(Cs).
hex_digit(C, D) :-
(C >= 0'A ->
D is ((C /\ 223) - 0'A) + 10 % 223 = bin(11011111)
;
D is C - 0'0
).
to_value([L|Ls], V) :-
to_value_(Ls, L, V).
to_value_([], [], '$empty') :- !.
to_value_([], L, V) :- !,
name(V, L). % if only a line, return an atom or number
to_value_(Ls, L, [L|Ls]). % else, return the list of lines
% :- true pred http_lines(Lines, String, Tail)
% :: list(string) * string * string
% # "@var{Lines} is a list of the lines with occur in @var{String}
% until @var{Tail}. The lines may end UNIX-style or DOS-style
% in @var{String}, in @var{Lines} they have not end of line
% characters. Suitable to be used in DCGs.".
http_lines([L|Ls]) -->
http_line(L), !,
http_lines(Ls).
http_lines([]) --> "".
% ----------------------------------------------------------------------------
get_multipart_form_data(end, _, []).
get_multipart_form_data(continue, Boundary, [N=V|NVs]) :-
get_lines_to_boundary(Boundary, Lines, End),
extract_name_value(Lines, N, V),
get_multipart_form_data(End, Boundary, NVs).
get_lines_to_boundary(Boundary, Lines, End) :-
get_line(Line),
get_lines_to_boundary_(Line, Boundary, Lines, End).
get_lines_to_boundary_(Line, Boundary, Lines, End) :-
append(Boundary, R, Line),
check_end(R, End), !,
Lines = [].
get_lines_to_boundary_(Line, Boundary, [Line|Lines], End) :-
get_line(OtherLine),
get_lines_to_boundary_(OtherLine, Boundary, Lines, End).
check_end([], continue).
check_end("--", end).
extract_name_value([L|Ls], N, V) :-
head_and_body_lines(L, Ls, HLs, BLs),
extract_name_type(HLs, N, T),
extract_value(T, BLs, V).
head_and_body_lines([], BLs, [], BLs) :- !.
head_and_body_lines(HL, [L|Ls], [HL|HLs], BLs) :-
head_and_body_lines(L, Ls, HLs, BLs).
extract_name_type(HLs, N, T) :-
member(HL, HLs),
content_disposition_header(Params, HL, []),
extract_name(Params, N),
extract_type(Params, T).
content_disposition_header(Params) -->
"Content-Disposition: form-data",
http_type_params(Params).
extract_name(Params, N) :-
member((name=NS), Params), !,
atom_codes(N, NS).
extract_type(Params, T) :-
(
member((filename=FS), Params) ->
atom_codes(F, FS),
T = file(F)
; T = data
).
extract_value(data, [L|Ls], V) :-
to_value_(Ls, L, V).
extract_value(file(F), Ls, file(F,Ls)).
% ----------------------------------------------------------------------------
% :- comment(get_form_value(Dict,Var,Val), "Unifies @var{Val} with the
% value for attribute @var{Var} in dictionary @var{Dict}. Does not
% fail: value is @tt{''} if not found (this simplifies the programming
% of form handlers when they can be accessed directly).").
% :- true pred get_form_value(+form_dict,+atm,?form_value).
% Get value Val for attribute Var in dictionary Dic
% Does not fail: value is '' if not found.
get_form_value([],_Var,'').
get_form_value([Var=Val|_],Var,Val) :- !.
get_form_value([_|Dic],Var,Val) :-
get_form_value(Dic,Var,Val).
% :- comment(text_lines(Val,Lines), "Transforms a value @var{Val} from a
% text area to a list of lines @var{Lines}. Not needed now,
% automatically done.").
% :- true pred text_lines(+form_value,-list(string)).
% Transform input from a text area to a list of lines - not needed now
text_lines('$empty', []) :- !.
text_lines(A, [L]) :-
atomic(A), !,
name(A,L).
text_lines(T,T).
% :- true pred form_empty_value(Term)
% # "Checks that @var{Term}, a value comming from a text area is
% empty (can have spaces, newlines and linefeeds).".
% Some generic help for dealing with the very weird things that empty text
% areas and boxes can send
form_empty_value(T) :-
text_lines(T, Ls),
empty_lines(Ls).
empty_lines([]).
empty_lines([L|Ls]) :-
whitespace0(L, []),
empty_lines(Ls), !.
% :- true pred form_default(+Val,+Default,-NewVal)
% # "Useful when a form is only partially filled, or when the
% executable can be invoked either by a link or by a form, to set
% form defaults. If the value of @var{Val} is empty then
% @var{NewVal}=@var{Default}, else @var{NewVal}=@var{Val}.".
% Set form defaults
form_default(Val,Default,NewVal) :-
( Val == '' -> NewVal = Default; NewVal = Val).
% :- true pred form_request_method(Method) => atm
% # "Unifies @var{Method} with the method of invocation of the form
% handler (@tt{GET} or @tt{POST}).".
form_request_method(M) :-
getenvstr('REQUEST_METHOD', MS),
atom_codes(M,MS).
% :- comment(my_url(URL), "Unifies @var{URL} with the Uniform
% Resource Locator (WWW address) of this cgi executable.").
% :- true pred my_url(?string).
my_url(URL) :-
getenvstr('SERVER_NAME', Server),
getenvstr('SCRIPT_NAME', File),
getenvstr('SERVER_PORT', Port),
(
Port = "80" ->
mappend(["http://",Server,File], URL)
; mappend(["http://",Server,[0':|Port],File], URL)
).
%%% Cookies, contributed by Samir Genaim %%%
% sending a cookie is done by printing
%
% Set-Cookie: var=value
%
% before sending Content-Type
% :- comment(set_cookie(Name,Value), "Sets a cookie of name @var{Name} and
% value @var{Value}. Must be invoked before outputting any data,
% including the @tt{cgi_reply} html-term.").
% :- true pred set_cookie(+atm,+constant).
set_cookie(Name,Value) :-
display_list(['Set-Cookie: ',Name,'=',Value,'\n']).
% :- comment(get_cookies(Cookies), "Unifies @var{Cookies} with a dictionary of
% @em{attribute}=@em{value} pairs of the active cookies for this URL.").
% :- true pred get_cookies(-value_dict).
% Cookies are available in the environment variable "HTTP_COOKIE".
% The cookies string is of the form:
%
% var1=val1; var2=val2; ..... varn=valn
get_cookies(Cs) :-
getenvstr('HTTP_COOKIE',CookiesStr),
cookies(Cs,[0';,0' |CookiesStr],[]), !.
get_cookies([]).
cookies([]) --> "".
cookies([C=V|Cs]) -->
"; ",
cookie_str(StrC),
"=",
cookie_str(StrV),
{
atom_codes(C,StrC),
name(V,StrV)
},
cookies(Cs).
cookie_str([C]) -->
legal_cookie_char(C).
cookie_str([C|Cs]) -->
legal_cookie_char(C),
cookie_str(Cs).
legal_cookie_char(C) -->
[C],
{C \== 0';, C\== 0'=}.
% ----------------------------------------------------------------------------
%% To compute GET parameters for CGI's
% -- from an idea of Markus Fromherz <fromherz@parc.xerox.com> */
% :- comment(url_query(Dict,URLArgs), "Translates a dictionary @var{Dict}
% of parameter values into a string @var{URLArgs} for appending to a URL
% pointing to a form handler.").
% :- true pred url_query(+value_dict,-string).
url_query(Args, URLArgs) :-
params_to_string(Args, 0'?, URLArgs).
params_to_string([], _, "").
params_to_string([N=V|NVs], C, [C|String]) :-
name(N,NS),
name(V,VS),
encoded_value(VS,EVS,Rest),
params_to_string(NVs, 0'&, Rest),
append(NS,[0'=|EVS],String).
encoded_value([]) --> "".
encoded_value([32|Cs]) --> !, % " " = [32]
"+",
encoded_value(Cs).
encoded_value([C|Cs]) -->
{no_conversion(C)}, !,
[C],
encoded_value(Cs).
encoded_value([C|Cs]) -->
{hex_chars(C,C1,C2)},
[0'%,C1,C2],
encoded_value(Cs).
no_conversion(0'*).
no_conversion(0'-).
no_conversion(0'.).
no_conversion(0'_).
no_conversion(C) :- C >= 0'0, C =< 0'9.
no_conversion(C) :- C >= 0'@, C =< 0'Z.
no_conversion(C) :- C >= 0'a, C =< 0'z.
hex_chars(C, H, L) :-
Hn is C >> 4,
hex_char(Hn,H),
Ln is C /\ 15,
hex_char(Ln,L).
hex_char(N,C) :- N < 10, !, C is N+0'0.
hex_char(N,C) :- C is N-10+0'A.
%%% URL encoding/decoding %%%
% :- comment(url_info(URL,URLTerm), "Translates a URL @var{URL} to a
% Prolog structure @var{URLTerm} which details its various components,
% and vice-versa. For now non-HTTP URLs make the predicate fail.").
% :- true pred url_info(+atm, ?url_term).
% :- true pred url_info(+string, ?url_term).
% :- true pred url_info(-string, +url_term).
url_info(Url, Info) :-
atom(Url), !,
atom_codes(Url, UrlStr),
url_to_info(UrlStr, Info).
url_info(Url, Info) :-
instantiated_string(Url), !,
url_to_info(Url, Info).
url_info(Url, Info) :-
info_to_url(Info, Url).
url_to_info(Url, http(Host,Port,Document)) :-
http_url(Host, Port, Document, Url, []), !.
% More protocols may be added here...
http_url(Host,Port,Doc) -->
"http://",
internet_host(Host),
optional_port(Port),
http_document(Doc).
internet_host(Host) -->
internet_host_char(C),
internet_host_char_rest(Cs),
{
atom_codes(Host, [C|Cs])
}.
internet_host_char_rest([C|Cs]) -->
internet_host_char(C),
internet_host_char_rest(Cs).
internet_host_char_rest([]) --> "".
internet_host_char(C) --> digit(C).
internet_host_char(C) --> loupalpha(C).
internet_host_char(0'-) --> "-".
internet_host_char(0'.) --> ".".
optional_port(Port) -->
":", !,
parse_integer(Port).
optional_port(80) --> "".
http_document([0'/|Doc]) -->
"/", !,
rest(Doc).
http_document("/") --> "".
rest(S, S, []).
instantiated_string(S) :- var(S), !, fail.
instantiated_string([]).
instantiated_string([C|Cs]) :-
integer(C),
instantiated_string(Cs).
info_to_url(http(Host,Port,Document), Info) :- !,
atom(Host),
integer(Port),
atom_codes(Host, HostS),
port_codes(Port, PortS),
mappend(["http://", HostS, PortS, Document], Info).
% More protocols may be added here...
port_codes(80, "") :- !.
port_codes(Port, [0':|PortS]) :-
number_codes(Port, PortS).
% ============================================================================
% url_info_relative(+Url:(atom ; string), +Base:url_info, -Info:url_info)
%
% Extracts information from a URL, relative to a base page
% ============================================================================
% :- comment(url_info_relative(URL,BaseURLTerm,URLTerm), "Translates a
% relative URL @var{URL} which appears in the HTML page refered to by
% @var{BaseURLTerm} into @var{URLTerm}, a Prolog structure containing its
% absolute parameters. Absolute URLs are translated as with
% @pred{url_info/2}. E.g.
% @begin{verbatim}
% url_info_relative(\"dadu.html\",
% http('www.foo.com',80,\"/bar/scoob.html\"), Info)
% @end{verbatim}
% gives @tt{Info = http('www.foo.com',80,\"/bar/dadu.html\")}.").
% :- true pred url_info_relative(+atm,+url_term,?url_term).
% :- true pred url_info_relative(+string,+url_term,?url_term).
url_info_relative(URL, Base, Info) :-
atom(URL), !,
atom_codes(URL, URLStr),
url_info_relative(URLStr, Base, Info).
url_info_relative(URL, _Base, Info) :-
url_info(URL, Info), !.
url_info_relative(Path, http(Host,Port,_), http(Host,Port,Path)) :-
Path = [0'/|_], !.
url_info_relative(File, http(Host,Port,BaseDoc), http(Host,Port,Document)) :-
\+ member(0':, File), % Naive check to ensure it is not a valid URL
append(BasePath, BaseFile, BaseDoc),
\+ member(0'/, BaseFile), !,
append(BasePath, File, Document).
atomic_or_string(X) -->
{atomic(X), name(X,S)}, !,
string(S).
atomic_or_string(S) -->
string(S).
textarea_data('$empty') --> [].
textarea_data(X) -->
{atomic(X), name(X,S)}, !,
string(S).
textarea_data(L) -->
http_lines(L), !.
textarea_data(S) -->
string(S).
% :- comment(html_protect(Goal), "Calls @var{Goal}. If an error occurs
% during its execution, or it fails, an HTML page is output informing
% about the incident. Normaly the whole execution of a CGI is
% protected thus.").
% :- true pred html_protect(callable).
:- meta_predicate(html_protect(:)). % For compatibility
html_protect(Goal) :-
catch(Goal,E,html_report_error(E)).
html_protect(_) :-
html_report_error('Sorry, application failed.').
%%% Support predicates %%%
%% Concatenates a list of lists
mappend([], []).
mappend([S|Ss], R) :-
append(S, R0, R),
mappend(Ss, R0).
% ----------------------------------------------------------------------------
% :- comment(version_maintenance,dir('../../version')).
% :- comment(version(1*5+114,2000/04/11,20:23*43+'CEST'), "Added pillow
% term prolog_term/1. (Daniel Cabeza Gras)").
% :- comment(version(1*3+115,1999/11/24,00:58*36+'MET'), "Added file to
% version control. (Manuel Hermenegildo)").
% ----------------------------------------------------------------------------
pillow_version("1.1").
% :- comment(title, "HTTP conectivity").
% :- comment(author, "Daniel Cabeza").
% :- comment(module, "This module implements the @concept{HTTP} protocol, which
% allows retrieving data from HTTP servers.").
% :- comment(fetch_url(URL, Request, Response), "Fetches the document
% pointed to by @var{URL} from Internet, using request parameters
% @var{Request}, and unifies @var{Response} with the parameters of the
% response. Fails on timeout. Note that redirections are not handled
% automatically, that is, if @var{Response} contains terms of the form
% @tt{status(redirection,301,_)} and @tt{location(NewURL)}, the program
% should in most cases access location @tt{NewURL}.").
% :- true pred fetch_url(URL, Request, Response)
% : (url_term(URL), list(Request, http_request_param))
% => list(Response, http_response_param).
fetch_url(http(Host, Port, Document), Request, Response) :-
timeout_option(Request, Timeout, Request1),
http_request(Document, Request1, RequestChars, []), !,
http_transaction(Host, Port, RequestChars, Timeout, ResponseChars),
http_response(Response, ResponseChars, []).
% :- pred timeout_option(+Options, -Timeout, -RestOptions)
% # "Returns timeout option, by default 5 min. (300s).".
timeout_option(Options, Timeout, RestOptions) :-
select(timeout(Timeout), Options, RestOptions), !.
timeout_option(Options, 300, Options).
% :- pred http_request(+Document, +Request, -RequestChars, -RequestCharsTail)
% # "Generate an HTTP request from a list of parameters, conforming to
% the RFC 1945 guidelines. Does not use the headers: current date,
% pragma, referer, and entity body (this will have to change if the
% implementation extends beyond the GET and HEAD methods. cf
% RFC1945 section 7.2)".
http_request(Document,Options) -->
http_request_method(Options,Options1),
" ",
string(Document),
" HTTP/1.0",
http_crlf,
http_req(Options1), !.
http_request_method(Options,Options1) -->
{
select(head, Options, Options1)
}, !,
"HEAD".
http_request_method(Options, Options) -->
"GET".
http_req([]) --> http_crlf.
http_req([Option|Options]) -->
http_request_option(Option), !,
http_req(Options).
http_request_option(user_agent(A)) --> !,
{
atom_codes(A,AStr),
pillow_version(Ver)
},
"User-Agent: ",
string(AStr),
" PiLLoW/",
string(Ver),
http_crlf.
http_request_option(if_modified_since(date(WkDay,Day,Month,Year,Time))) --> !,
"If-Modified-Since: ",
http_internet_date(WkDay,Day,Month,Year,Time),
http_crlf.
http_request_option(authorization(Scheme, Params)) --> !,
"Authorization: ",
http_credentials(Scheme, Params),
http_crlf.
http_request_option(O) -->
{
functor(O,F,1),
atom_codes(F,FS),
arg(1,O,A),
atom_codes(A,AS)
}, !,
string(FS),
": ",
string(AS),
http_crlf.
http_request_option(O) --> "",
{warning(['Invalid http_request_param ',O])}.
http_credentials(basic, Cookie) --> !,
"Basic ",
string(Cookie).
http_credentials(Scheme,Params) --> !,
{
atom_codes(Scheme, S)
},
string(S), " ",
http_credential_params(Params).
http_credential_params([]) --> "".
http_credential_params([P|Ps]) -->
http_credential_param(P),
http_credential_params_rest(Ps).
http_credential_params_rest([]) --> "".
http_credential_params_rest([P|Ps]) -->
", ",
http_credential_param(P),
http_credential_params_rest(Ps).
http_credential_param(P=V) -->
{
atom_codes(P,PS)
},
string(PS), "=""", string(V), """".
% ============================================================================
% PROLOG BNF GRAMMAR FOR HTTP RESPONSES
% Based on RFC 1945
%
% ============================================================================
http_response(R) -->
http_full_response(R), !.
http_response(R) -->
http_simple_response(R).
http_full_response([Status|Head_Body]) -->
http_status_line(Status),
http_response_headers(Head_Body,Body),
http_crlf,
http_entity_body(Body).
http_simple_response(Body) -->
http_entity_body(Body).
http_response_headers([H|Hs], Hs_) -->
http_response_header(H), !,
http_response_headers(Hs, Hs_).
http_response_headers(Hs, Hs) --> "".
http_entity_body([content(B)],B,[]).
% ----------------------------------------------------------------------------
http_status_line(status(Ty,SC,RP)) -->
"HTTP/", parse_integer(_Major), ".", parse_integer(_Minor),
http_sp,
http_status_code(Ty,SC),
http_sp,
http_line(RP), !.
http_status_code(Ty,SC) -->
[X,Y,Z],
{
type_of_status_code(X,Ty), !,
number_codes(SC,[X,Y,Z])
}.
type_of_status_code(0'1, informational).
type_of_status_code(0'2, success).
type_of_status_code(0'3, redirection).
type_of_status_code(0'4, request_error).
type_of_status_code(0'5, server_error).
type_of_status_code(_, extension_code).
% ----------------------------------------------------------------------------
% General header
http_response_header(P) --> http_pragma(P).
http_response_header(D) --> http_message_date(D).
% Response header
http_response_header(L) --> http_location(L).
http_response_header(S) --> http_server(S).
http_response_header(A) --> http_authenticate(A).
% Entity header
http_response_header(A) --> http_allow(A).
http_response_header(E) --> http_content_encoding(E).
http_response_header(L) --> http_content_length(L).
http_response_header(T) --> http_content_type(T).
http_response_header(X) --> http_expires(X).
http_response_header(M) --> http_last_modified(M).
http_response_header(E) --> http_extension_header(E).
% ----------------------------------------------------------------------------
http_pragma(pragma(P)) -->
http_field("pragma"),
http_line(P).
http_message_date(message_date(D)) -->
http_field("date"),
http_date(D),
http_crlf.
http_location(location(URL)) -->
http_field("location"),
http_line(URLStr),
{
atom_codes(URL,URLStr)
}.
http_server(http_server(S)) -->
http_field("server"),
http_line(S).
http_authenticate(authenticate(C)) -->
http_field("www-authenticate"),
http_challenges(C).
http_allow(allow(Methods)) -->
http_field("allow"),
http_token_list(Methods),
http_crlf.
http_content_encoding(content_encoding(E)) -->
http_field("content-encoding"),
http_lo_up_token(E),
http_lws0,
http_crlf.
http_content_length(content_length(L)) -->
http_field("content-length"),
parse_integer(L),
http_lws0,
http_crlf.
http_content_type(content_type(Type,SubType,Params)) -->
http_field("content-type"),
http_media_type(Type,SubType,Params),
http_crlf.
http_expires(expires(D)) -->
http_field("expires"),
http_date(D),
http_crlf.
http_last_modified(last_modified(D)) -->
http_field("last-modified"),
http_date(D),
http_crlf.
http_extension_header(T) -->
http_field(F),
http_line(A),
{
atom_codes(Fu,F),
functor(T,Fu,1),
arg(1,T,A)
}.
% ----------------------------------------------------------------------------
http_date(date(WeekDay,Day,Month,Year,Time)) -->
http_internet_date(WeekDay,Day,Month,Year,Time)
;
http_asctime_date(WeekDay,Day,Month,Year,Time).
http_internet_date(WeekDay,Day,Month,Year,Time) -->
http_weekday(WeekDay),
",",
http_sp,
http_day(Day),
(http_sp ; "-"),
http_month(Month),
(http_sp ; "-"),
http_year(Year),
http_sp,
http_time(Time),
http_sp,
"GMT".
http_asctime_date(WeekDay,Day,Month,Year,Time) -->
http_weekday(WeekDay),
http_sp,
http_month(Month),
http_sp,
http_day(Day),
http_sp,
http_time(Time),
http_sp,
http_year(Year).
http_weekday('Monday') --> "Mon".
http_weekday('Tuesday') --> "Tue".
http_weekday('Wednesday') --> "Wed".
http_weekday('Thursday') --> "Thu".
http_weekday('Friday') --> "Fri".
http_weekday('Saturday') --> "Sat".
http_weekday('Sunday') --> "Sun".
http_weekday('Monday') --> "Monday".
http_weekday('Tuesday') --> "Tuesday".
http_weekday('Wednesday') --> "Wednesday".
http_weekday('Thursday') --> "Thursday".
http_weekday('Friday') --> "Friday".
http_weekday('Saturday') --> "Saturday".
http_weekday('Sunday') --> "Sunday".
http_day(Day) -->
[D1,D2],
{
number_codes(Day,[D1,D2])
}.
http_day(Day) -->
[0'0,D2],
{
number_codes(Day,[D2])
}.
http_day(Day) -->
http_sp,
[D],
{
number_codes(Day,[D])
}.
http_month('January') --> "Jan".
http_month('February') --> "Feb".
http_month('March') --> "Mar".
http_month('April') --> "Apr".
http_month('May') --> "May".
http_month('June') --> "Jun".
http_month('July') --> "Jul".
http_month('August') --> "Aug".
http_month('September') --> "Sep".
http_month('October') --> "Oct".
http_month('November') --> "Nov".
http_month('December') --> "Dec".
% Assumes Year > 999
http_year(Year) -->
[Y1,Y2,Y3,Y4],
{
number_codes(Year,[Y1,Y2,Y3,Y4])
}.
http_year(Year) -->
[Y1,Y2],
{
number_codes(Y,[Y1,Y2]),
( Y >= 70 -> Year is 1900+Y ; Year is 2000+Y )
}.
http_time(Time) -->
[H1,H2,0':,M1,M2,0':,S1,S2],
{
atom_codes(Time,[H1,H2,0':,M1,M2,0':,S1,S2])
}.
% ----------------------------------------------------------------------------
http_challenges([C|CS]) -->
http_maybe_commas,
http_challenge(C),
http_more_challenges(CS).
http_more_challenges([C|CS]) -->
http_commas,
http_challenge(C),
http_more_challenges(CS).
http_more_challenges([]) --> http_lws0, http_crlf.
http_challenge(challenge(Scheme,Realm,Params)) -->
http_lo_up_token(Scheme),
http_sp,
http_lo_up_token(realm), "=", http_quoted_string(Realm),
http_lws0,
http_auth_params(Params).
http_auth_params([P|Ps]) -->
",", http_lws0,
http_auth_param(P), http_lws0,
http_auth_params(Ps).
http_auth_params([]) --> "".
http_auth_param(P=V) -->
http_lo_up_token(P),
"=",
http_quoted_string(V).
% ----------------------------------------------------------------------------
http_token_list([T|Ts]) -->
http_maybe_commas,
http_token(T),
http_token_list0(Ts).
http_token_list0([T|Ts]) -->
http_commas,
http_token(T),
http_token_list0(Ts).
http_token_list0([]) -->
http_maybe_commas.
http_commas -->
http_lws0,",",http_lws0,
http_maybe_commas.
http_maybe_commas --> "".
http_maybe_commas -->
",", http_lws0,
http_maybe_commas.
% ----------------------------------------------------------------------------
http_field([C|Cs]) -->
http_lo_up_token_char(C),
http_lo_up_token_rest(Cs),
":", http_lws.
% ----------------------------------------------------------------------------
% :- comment(version_maintenance,dir('../../version')).
% :- comment(version(1*3+114,1999/11/24,00:57*16+'MET'), "Added file to
% version control. (Manuel Hermenegildo)").
% ----------------------------------------------------------------------------
%%% HTTP and basic parsing %%%
http_media_type(Type,SubType,Params) -->
http_lo_up_token(Type),
"/",
http_lo_up_token(SubType),
http_lws0,
http_type_params(Params).
http_type_params([P|Ps]) -->
";", http_lws0,
http_type_param(P), http_lws0,
http_type_params(Ps).
http_type_params([]) --> "".
http_type_param(A = V) -->
http_lo_up_token(A),
"=",
http_token_or_quoted(V).
http_token_or_quoted(V) --> http_token(V).
http_token_or_quoted(V) --> http_quoted_string(V).
http_token(T) -->
http_token_char(C),
http_token_rest(Cs),
{
atom_codes(T, [C|Cs])
}.
http_token_rest([C|Cs]) -->
http_token_char(C),
http_token_rest(Cs).
http_token_rest([]) --> "".
http_token_char(C) --> loalpha(C).
http_token_char(C) --> upalpha(C).
http_token_char(C) --> digit(C).
http_token_char(C) --> http_token_symb(C).
http_token_symb(0'!) --> "!".
http_token_symb(0'#) --> "#".
http_token_symb(0'$) --> "$".
http_token_symb(0'%) --> "%".
http_token_symb(0'&) --> "&".
http_token_symb(0'') --> "'".
http_token_symb(0'*) --> "*".
http_token_symb(0'+) --> "+".
http_token_symb(0'-) --> "-".
http_token_symb(0'.) --> ".".
http_token_symb(0'^) --> "^".
http_token_symb(0'_) --> "_".
http_token_symb(0'`) --> "`".
http_token_symb(0'|) --> "|".
http_token_symb(0'~) --> "~".
http_quoted_string(S) -->
"""",
http_qs_text(S).
http_qs_text([]) -->
"""", !.
http_qs_text([X|T]) -->
[X],
http_qs_text(T).
% ----------------------------------------------------------------------------
parse_integer(N) -->
digit(D),
parse_integer_rest(Ds),
{
number_codes(N,[D|Ds])
}.
parse_integer_rest([D|Ds]) -->
digit(D),
parse_integer_rest(Ds).
parse_integer_rest([]) --> "".
http_lo_up_token(T) -->
http_lo_up_token_char(C),
http_lo_up_token_rest(Cs),
{
atom_codes(T, [C|Cs])
}.
http_lo_up_token_rest([C|Cs]) -->
http_lo_up_token_char(C),
http_lo_up_token_rest(Cs).
http_lo_up_token_rest([]) --> "".
http_lo_up_token_char(C) --> loupalpha(C).
http_lo_up_token_char(C) --> digit(C).
http_lo_up_token_char(C) --> http_token_symb(C).
loupalpha(C) --> loalpha(C), !.
loupalpha(C) --> upalpha(CU), { C is CU+0'a-0'A }.
loalpha(C) --> [C], {C >= 0'a, C =< 0'z}.
upalpha(C) --> [C], {C >= 0'A, C =< 0'Z}.
digit(C) --> [C], {C >= 0'0, C =< 0'9}.
http_line([]) -->
http_crlf, !.
http_line([X|T]) -->
[X],
http_line(T).
http_sp -->
[32], !,
http_sp0.
http_sp -->
[9],
http_sp0.
http_sp0 --> [].
http_sp0 --> http_sp.
http_lws -->
http_sp.
http_lws -->
http_crlf,
http_sp.
http_lws0 --> "".
http_lws0 --> http_lws.
http_crlf -->
[13,10], !.
http_crlf -->
[10].
display_list([M|Ms]) :- !,
display(M),
display_list(Ms).
display_list([]) :- !.
display_list(M) :-
display(M).
warning(Mess) :-
current_output(OldOut),
set_output(user_error),
display_list(['WARNING: '|Mess]),
set_output(OldOut).
write_string(Stream, S) :-
current_output(OldOut),
set_output(Stream),
write_string(S),
set_output(OldOut).
write_string([]).
write_string([C|Cs]) :- put_code(C), write_string(Cs).
get_line(Line) :-
get_code(C),
get_line_after(C, Cs),
Line = Cs.
get_line_after(-1,[]) :- !. % EOF
get_line_after(10,[]) :- !. % Newline
get_line_after(13, R) :- !, % Return, delete if at end of line
get_code(C),
get_line_after(C, Cs),
( Cs = [] ->
R = []
; R = [13|Cs]
).
get_line_after(C, [C|Cs]) :-
get_code(C1),
get_line_after(C1, Cs).
whitespace --> whitespace_char, whitespace0.
whitespace0 --> whitespace_char, whitespace0.
whitespace0 --> [].
whitespace_char --> [10]. % newline
whitespace_char --> [13]. % return
whitespace_char --> [32]. % space
whitespace_char --> [9]. % tab
string([]) --> "".
string([C|Cs]) -->
[C],
string(Cs).
getenvstr(Var,ValStr) :-
environ(Var,Val),
atom_codes(Val,ValStr).
:- use_module(library(lists)).
list_lookup(List, Functor, Key, Value) :-
var(List), !,
functor(Pair, Functor, 2),
arg(1, Pair, Key),
arg(2, Pair, Value),
List=[Pair|_].
list_lookup([Pair|_], Functor, Key, Value) :-
functor(Pair, Functor, 2),
arg(1, Pair, Key0),
Key0==Key, !,
arg(2, Pair, Value).
list_lookup([_|List], Functor, Key, Value) :-
list_lookup(List, Functor, Key, Value).
http_transaction(Host, Port, Request, Timeout, Response) :-
socket('AF_INET', Socket),
socket_connect(Socket, 'AF_INET'(Host,Port), Stream),
write_string(Stream, Request),
flush_output(Stream),
stream_select([Stream],Timeout:0,R),
R \== [], % Fail if timeout
stream_to_string(Stream,Response).
stream_to_string(Stream, String) :-
current_input(OldIn),
set_input(Stream),
read_to_close(String),
set_input(OldIn),
close(Stream).
read_to_close(L) :-
get_code(C),
read_to_close1(C, L).
read_to_close1(-1, []) :- !.
read_to_close1(C, [C|L]) :-
get_code(C1),
read_to_close1(C1, L).