diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
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.
62a2c14c12
yap-6.3/LGPL/pillow/pillow.pl
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
Raw Blame History

% 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).
Reference in New Issue View Git Blame Copy Permalink