% 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,user:($)). :- op(150,fx,user:($)). % :- 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)}, !, "**Warning free variable**". html_term(T) --> {html_expansion(T,NT)}, !, html_term(NT). html_term(start) --> !, "". html_term(end) --> !, "". html_term(--) --> !, newline, "
", newline. html_term(\\) --> !, "
", newline. html_term($) --> !, newline, "

". html_term(comment(C)) --> !, "", newline. html_term(declare(C)) --> !, "", newline. % XML declaration html_term(xmldecl(Atts)) --> !, "". html_term(image(Addr)) --> !, "". html_term(image(Addr,Atts)) --> !, "". html_term(ref(Addr,Text)) --> !, "", html_term(Text), "". html_term(label(Label,Text)) --> !, "", html_term(Text), "". html_term(heading(L,X)) --> {number_codes(L,[N])}, !, html_env([0'h,N],X), newline. html_term(itemize(L)) --> !, "

". html_term(enumerate(L)) --> !, "
    ", newline, html_items(L), "
". html_term(description(L)) --> !, "
", newline, html_descriptions(L), "
". html_term(nice_itemize(Dot, L)) --> !, "
", newline, {atom(Dot) -> atom_codes(Dot,D) ; D = Dot}, html_nice_items(L, D), "
". html_term(preformatted(X)) --> !, "
",
        newline,
        preformatted_lines(X),
        "
". html_term(entity(Name)) --> !, "&",atomic_or_string(Name),";". % Forms html_term(start_form) --> !, "", newline. html_term(start_form(Addr)) --> !, "", newline. html_term(start_form(Addr,Atts)) --> !, "", newline. html_term(end_form) --> !, "", newline. html_term(checkbox(Name,on)) --> !, "". html_term(checkbox(Name,_)) --> !, "". html_term(radio(Name,Value,Value)) --> !, "". html_term(radio(Name,Value,_)) --> !, "". html_term(input(Type,Atts)) --> !, "". html_term(textinput(Name,Atts,Text)) --> !, "", textarea_data(Text), "". html_term(menu(Name,Atts,Items)) --> !, "", newline, html_options(Items), "". html_term(option(Name,Val,Options)) --> !, "", newline, html_one_option(Options, Val), "". 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)}, !, "". 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), "". html_env_atts(E,Atts,I) --> "<",string(E), html_atts(Atts), ">", html_term(I), "". html_items([]) --> []. html_items([It|Its]) --> "
  • ", html_term(It), "
    • ", newline, html_items(Its). html_descriptions([]) --> []. html_descriptions([D|Ds]) --> html_description(D), html_descriptions(Ds). html_description((T,D)) --> !, "
    ", html_term(T), "
    ", newline, html_description(D). html_description(D) --> "
    ", html_term(D), "
    ", newline. html_nice_items([],_) --> []. html_nice_items([It|Its],Dot) --> "
    ", html_term(It), "
    ", 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) --> !, "". html_option(Op) --> "". html_one_option([], _) --> []. html_one_option([Op|Ops], Sel) --> "",atomic_or_string(Op),"", 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'>) --> !, ">". html_quoted_char(0'<) --> !, "<". html_quoted_char(0'&) --> !, "&". html_quoted_char(0'") --> !, """. html_quoted_char(0' ) --> !, " ". 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{}@em{name}@tt{}. % % @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 */ % :- 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) :- getenv(Var,Val), atom_codes(Val,ValStr). 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) % type http_transaction(atom, integer, string, integer, string). % % Notes: Sends an HTTP Request to an HTTP server and returns the % resultant message in Response % % Fails on timeout (Timeout in seconds) % ============================================================================ % %%%%% this file allows fetch_url/3 for SWI-Prolog %%%%% based on pillow_{ciao|sicstus21|sicstus3} %%%%% changed by Frank Schilder (schilder@informatik.uni-hamburg.de) %%%%% Date: 29th May 2000 % :- use_module(library(socket)). %%% needs the clib package: %%% available from http://swi.psy.uva.nl/projects/SWI-Prolog/packages/clib/ % ============================================================================ % %The clib package consists of various basically independant libraries %dealing with some commonly encountered low-level operations that must %be defined or are easier defined in C. % %library(unix) % Deals with Unix process management (fork(), pipe(), exec(), etc.). % %library(socket) % Deals with handling tcp sockets (both server and client). This %library also runs on MS-Windows, though the server functionality is % incomplete on this platform. % %library(cgi) % Deals with fetching form-data when using SWI-Prolog as CGI %application. Supports both GET and POST methods. Also supports % multipart/form-data MIME encoded form-data. % % ============================================================================ http_transaction(Host, Port, Request, Timeout, Response) :- tcp_socket(Socket), tcp_connect(Socket, Host:Port), tcp_open_socket(Socket, ReadFd, WriteFd), write_string(WriteFd, Request), flush_output(WriteFd), wait_for_input([WriteFd],R,Timeout), R \== [], % Fail if timeout read_to_close(ReadFd, Response), close(WriteFd), close(ReadFd). read_to_close(S, L) :- get_code(S, C), read_to_close1(C, S, L). read_to_close1(-1, _, []) :- !. read_to_close1(C, S, [C|L]) :- get_code(S, C1), read_to_close1(C1, S, L).