:- ensure_loaded(common).
cvs_id('$Id').
/*

  Utilities for being a tserver (test-server) client.

*/

:- ensure_loaded(library('http/http_open')).
:- ensure_loaded(library(memfile)).
:- ensure_loaded(library(sgml)).
:- ensure_loaded(library(debug)).
:- ensure_loaded(qtest).
:- ensure_loaded(config_data).

:- dynamic tserver_base_uri/1.

:- debug(tclient).

set_tserver_base_uri :-
	app_config(portfile, PF1),
	atom_concat('tserver-sandbox', PF1, PortFile),
	open(PortFile, read, S),
	read_line_to_codes(S, Codes),
	debug(tclient, 'Codes: ~a', Codes),
	close(S),
	atom_codes(Port, Codes),
	debug(tclient, 'Atom: ~a', Port),
	concat_atom(['http://127.0.0.1:', Port, '/'], Base),
	debug(tclient, 'Base: ~a', Base),
	assert(tserver_base_uri(Base)).

:- set_tserver_base_uri.

tserved(RelativeURI, Content, Seconds, Bytes, Options) :-
	atom(RelativeURI),
	tserver_base_uri(Base),
	global_url(RelativeURI, Base, URI),
	get_time(Start),
	http_open(URI, Stream, Options),
	(   Content = stream(Stream)
	->  true
	;   new_memory_file(F),
	    open_memory_file(F, write, MemStream),
	    copy_stream_data(Stream, MemStream),
	    close(Stream),
	    close(MemStream),
	    size_memory_file(F, Bytes),
	    memory_file_convert(F, Content)
	),
	get_time(Stop),
	Seconds is Stop - Start.

aserved(Address, Content, Seconds, Bytes, Options) :-
	get_time(Start),
	http_open(Address, Stream, Options),
	(   Content = stream(Stream)
	->  true
	;   new_memory_file(F),
	    open_memory_file(F, write, MemStream),
	    copy_stream_data(Stream, MemStream),
	    close(Stream),
	    close(MemStream),
	    size_memory_file(F, Bytes),
	    memory_file_convert(F, Content)
	),
	get_time(Stop),
	Seconds is Stop - Start.

memory_file_convert(M, atom(A)) :-
	memory_file_to_atom(M, A),
	free_memory_file(M).
memory_file_convert(M, codes(C)) :-
	memory_file_to_codes(M, C),
	free_memory_file(M).
memory_file_convert(M, memory_file(M)).   % you free it, of course.

content_match(Tree, Tree).
content_match(element(_Tag, _Attrs, Kids), SubTree) :-
	content_match(Kids, SubTree).
content_match([H|T], SubTree) :-
	(   content_match(H, SubTree)
	;   content_match(T, SubTree)
	).

sgml_package_example(
         [ element(html,
             [],
             [ element(head,
           [],
           [ element(title,
               [],
               [ 'Demo'
               ])
           ]),
         element(body,
           [],
           [ '\n',
             element(h1,
               [ align = center
               ],
               [ 'This is a demo'
               ]),
             '\n\n',
             element(p,
               [],
               [ 'Paragraphs in HTML need not be closed.\n'
               ]),
             element(p,
               [],
               [ 'This is called `omitted-tag\' handling.'
               ])
           ])
             ])
         ]
        ).

qtest :-
	sgml_package_example(E),
	content_match(E, element(h1, _, ['This is a demo'])).

qtest :-
	sgml_package_example(E),
	content_match(E, element(_, [align=center], ['This is a demo'])).

qtest :-
	sgml_package_example(E),
	\+ content_match(E, element(h1, _, 'This is NOT a demo')).

qtest :-
	sgml_package_example(E),
	content_match(E, Part),
	atom(Part),
	sub_atom(Part, _, _, _, demo).

qtest :-
	sgml_package_example(E),
	\+ (
	     content_match(E, Part),
	     atom(Part),
	     sub_atom(Part, _, _, _, demoxx)
	   ).

%%  onpage(+RelativeURI, ?MatchStructure)
%%
%%  Loads an HTML page from the relative URI (to the tserver)
%%  and does a content_match against it.  Backtrackable over
%%  the entire HTML tree.
%%
onpage(RelURI, Match) :-
	tserved(RelURI, stream(Stream), _Seconds, _Bytes, []),
	load_structure(stream(Stream), H, [dialect(xml)]),
	content_match(H, Match).

onpagea(Abs, Match) :-
	aserved(Abs, stream(Stream), _Seconds, _Bytes, []),
	load_structure(stream(Stream), H, [dialect(xml)]),
	content_match(H, Match).
	