:- ensure_loaded(common).
cvs_id('$Id: reply.pl,v 1.89 2005/04/14 22:17:40 sandro Exp $').
/*

   Main http server dispatch point. 

   convert everyone to using (multifile):
  
        web_server_page(FirstPathSegment, [Handler])

        Handler is passed Q, which is the Request given
        use by http package's http_wrapper, with a few
        bits included:
            request_id(ReqId)  might become obsolete
            first_path_segment(Segment)  as used above
            post_data(Data)    like search(S) for GET forms

        Handler defaults to something which uses the FirstPath
        Segment as the name for an HTML view, expected to be
        the page body.

        Handler may throw  http_reply(303, NewAddress),  if
        doesn't want to provide a "200 OK" reponse.

*/

:- multifile web_server_page/1.
:- multifile web_server_page/2.

:- dynamic req_start_stats/3.
:- multifile req_start_stats/3.

reply_stage_1(Req) :-
	% print_message(informational, format('~q', [Req])),
	% reject_certain_robots(Req),
	detect_fast_clients(Req),   %  really, this should not apply to static
	generate_request_uri(ReqId, N),
	get_time(StartTime),
	thread_self(Thread),
	thread_statistics(Thread, cputime, CPUStartTime),
	assert(req_start_stats(ReqId, StartTime, CPUStartTime)),
	debug(reply, 'Request ~a: ~q', [ReqId, Req]),
	log_term(http_trace, start(ReqId, StartTime, Thread, Req)),
	%
	% we'll *try* to notice something going wrong and log it and
	% apologize, but some things (like Undefined Procedure) don't
	% get reported back to us.   Bug.  Why is that, even with
	% current_prolog_flag(unknown, error)?   Maybe it's happening
	% in another module?
	%
	catch((	  possible_reply(Req, ReqId)
	      ->  Status=okay
	      ;   Status=failed
	      ),
	      Error,
	      copy_term(error(Error), Status)
	     ),
	get_time(EndTime),
	Dur is EndTime-StartTime,
	%thread_statistics(Thread, cputime, CPUEndTime),
	%assert(req_end_stats(ReqId, StartTime, CPUStartTime)),
	print_message(informational, http(Status, Req, ReqId, N, StartTime, EndTime)),
	log_message(access, http(Status, Req, ReqId, N, StartTime, EndTime)),
	(   (   Status=okay
	    ;   Error = http_reply(_)
	    )
	->  true
	;   % throw(http_reply(not_found(filename_not_accessible)))
	    write_error_page(ReqId, Status),
	    gensym(req_err_, ReqErr),
	    assert(( ReqErr :- possible_reply(Req, ReqId) )),
	    print_message(error, format('ReqErr function ~q asserted', ReqErr)),
	    log_term(http_error,  error(ReqId, Status, Req)),
	    log_term(http_error_retry,
		     (ReqErr :- possible_reply(Req, ReqId)) )
	),
	log_term(http_trace, stop(Dur, ReqId)),
	thread_high_water(HW),
	log_term(HW),
	(   ground(Error),
	    Error = http_reply(_)
	->  throw(Error)
	;   true
	).

reject_certain_robots(Req) :-      % quick hack!
	(   memberchk(user_agent(UA), Req),
	    ( UA = 'Mozilla/5.0 (compatible; Googlebot/2.1; +http://www.google.com/bot.html)'
	    ; UA = 'W3C-gsa (Enterprise; GED-00155; team-syslog@w3.org)'
	    )
	->  thread_set_state(told_off_bot),
	    throw(http_reply(not_found(x)))
	; true
	).

client_ip(Req, IP) :-
	 memberchk(x_forwarded_for(IP), Req).
client_ip(Req, IP) :-
	 memberchk(x_fwd_ip_addr(IP), Req).
client_ip(Req, IP) :-
	 /* Need a mod to thread_httpd:server_loop/5 so it puts
         peer(Peer) into the Request list somehow. */
	 memberchk(peer(IP:_), Req).
client_ip(_, ip_not_available).
	
:- multi_dynamic(client_ip_last_request_time/2).
:- multi_dynamic(client_ip_last_idle_period/2).
:- thread_local(my_client_is_fast/0).
:- multi_dynamic(recently_fast_client/1).

%%  detect_fast_clients(+Req)
%%
%%  @@ ONLY WORKS WHEN PROXIED -- see note above on client_ip/2.
%%
%%  assert/retract thread_local predicate my_client_is_fast/0 based
%%  on how close together requests are coming.   Fast clients are
%%  probably robots of some sort.
%%
%%  Of course "fast clients" might also be many users NAT'd onto one IP
%%  address or something, but....   there's no way to tell that a
%%  robot can't get around.    Hrm.
%%
%%  We should perhaps have a harvest throttle, where we lose interest
%%  in harvesting if you're asking for too much.
%%


detect_fast_clients(Req) :-
	with_mutex(detect_fast_clients_mutex,
		   unsafe_detect_fast_clients(Req)).

unsafe_detect_fast_clients(Req) :-
	get_time(Now),
	client_ip(Req, IP),
	retractall(my_client_is_fast),
	(   retract(client_ip_last_request_time(IP, LastTime))
	->  ThisIdle is Now - LastTime,
	    debug(fast_client, 'fast_client: ThisIdle=~w', [ThisIdle]),
	    (   retract(client_ip_last_idle_period(IP, LastIdle))
	    ->  AvgIdle is (ThisIdle + LastIdle) / 2,
		debug(fast_client, 'fast_client: AvgIdle=~w', [AvgIdle]),
		(   recently_fast_client(IP)
		->  Threshhold = 5    % > 5 sec/page to clear your name 
		;   Threshhold = 1    % < 1 sec/page to be tagged "fast"
		),
		debug(fast_client, 'fast_client: Threshhold=~w', [Threshhold]),
		(   AvgIdle < Threshhold
		->  assert(my_client_is_fast),
		    debug(fast_client, 'fast_client: yes!', [])
		    %    not safe while holding mutex - possible deadlock
		    % log_term(fast_client, fast_client(IP, AvgIdle, ThisIdle, LastIdle, Now)),
		;   true
		)
	    ;   true
	    ),
	    assert(client_ip_last_idle_period(IP, ThisIdle))
	;   true
	),
	assert(client_ip_last_request_time(IP, Now)),
	retractall(recently_fast_client(IP)),
	(   my_client_is_fast
	->  assert(recently_fast_client(IP))
	;   true
	).
	    
	
generate_request_uri(ReqId, N) :-     % 6 usec
	flag(request, N, N+1),
	flag(aboutThisRun, Run, Run),
	atom_number(AtomN, N),
	atom_concat('request_', AtomN, Local),
	rdfpage_sub_uri(Run, Local, ReqId).

:- dynamic sent_content_type/1.

ensure_content_type_sent(ReqId, Type) :-
	(   sent_content_type(ReqId)
	->  true
	;   format('Content-type: ~a~n~n', [Type]),
	    debug(replyct, 'sent ~a', [ReqId]),
	    assert(sent_content_type(ReqId))
	).


% shim to allow non +foo BodyPart, without changing all the callers.
write_page(ReqId, BodyPart, Focus) :-
	(   % if new style (+foo or [foo])
	    (   BodyPart = +_
	    ;   BodyPart = [_|_]
	    )
	-> write_page2(ReqId, BodyPart, Focus)
	;  write_page2(ReqId, +BodyPart, Focus)
	),
	!.
write_page(A,B,C) :-
	throw(failed(write_page(A,B,C))).

% new form taking Q instead of ReqId as first arg
write_pageq(Q, BodyPart) :-
	memberchk(request_id(ReqId), Q),
	(   memberchk(focus(Focus), Q)
	->  true
	;   Focus=''
	),
	write_page2(ReqId, BodyPart, Focus).
	    
write_page2(ReqId, BodyPart, Focus) :-
	debug(reply, 'write_page ~a ~q', [ReqId, BodyPart]),
	ensure_content_type_sent(ReqId, 'text/html'),
	(   good_label([], Focus, Title)
	->  true
	;   app_config(site_title, Title),
	    app_config(release, Release)
	),
	Head = [title([Title, ' ', Release]),
		link(rel='shortcut icon', href='static/favicon'),
		link(rel='stylesheet', href='static/base-style')
	        % we could us BodyPart as the name of a sub-style or something
	       ],
	Body =
	[ div(class=sitePage,
	      +siteHead(Focus),
	      BodyPart,
	      +siteFoot(ReqId))
	],
	pagein_around(Focus),
	% with rdf_with_lockr ?
	write_html(html(head(Head), body(Body))).


write_error_page(ReqId, Message) :-
	ensure_content_type_sent(ReqId, 'text/html'),
	app_config(site_title, Title),
	app_config(release, Release),
	term_to_atom(Message, MA),
	Head = [title([Title, ' ', Release]),
		link(rel='shortcut icon', href='static/favicon'),
		link(rel='stylesheet', href='static/base-style')
	        % we could us BodyPart as the name of a sub-style or something
	       ],
	Body = [h2('Sorry, an internal error has occured'),
		p('The error has been logged for the developers to examine.  There ',
		  'should be no need for you to do anything about it.   We apologize ',
		  'for any inconvenience this error causes you.'),
		p('For reference, the error occured during request ', ReqId),
		p('Error details: ', MA)
	    ],
	write_html(html(head(Head), body(Body))).

%%
%%   possible_reply(+Req, +ReqId)
%%
%%   write some html out for this reply.    written as a whole
%%   bunch of cascading possibility.   some of the logic for
%%   accepting the request is here; some is in sub-goals.  Oh
%%   well.
%%

% this first branch is my new style, but it's not widely used yet.  At
% some point the others should be converted.


web_server_page(PathSegment1, web_server_page_default_handler) :-
	web_server_page(PathSegment1).

web_server_page_default_handler(Q) :-
	memberchk(first_path_segment(PathSegment1), Q),
	View = PathSegment1,
	ViewQ =.. [View, Q],
	write_pageq(Q, +ViewQ).

possible_reply(Req, ReqId) :-
	member(path(X), Req),
        concat_atom(['', PathSegment1 | _], '/', X),
	Q =  [request_id(ReqId), first_path_segment(PathSegment1) | Req],
	debug(reply, 'trying path-segment-1=~q', [PathSegment1]),
	(   web_server_page(PathSegment1, Handler)
	->  debug(reply, '... Match!   Calling Handler ~q', [Handler]),
	    call(Handler, Q)
	;   % for legacy code...
	    web_server_path_view(PathSegment1, View),
	    debug(reply, '... Legacy Match!   Using View ~q', [View]),
	    ViewQ =.. [View, Q],
            % user code is down in plus_eval, so fails will be noticed there
	    write_pageq(Q, +ViewQ)
	).
possible_reply(Req, _ReqId) :-
	member(method(post), Req),
	member(path(X), Req),
        concat_atom(['', PathSegment1 | _], '/', X),
	PathSegment1 = 'refresh',
	debug(refresh, 'refresh', []),
	http_read_data(Req, Data, []),
	debug(refresh, 'Data: ~q', [Data]),
	memberchk(address=Address, Data),
	memberchk(focus=Focus, Data),
	debug(refresh, 'refresh - webload ~a', [Address]),
	webload(Address, [priority(2), max_age(1), wait(1), retrieval(Ret)]),
	debug(refresh, 'retrieval: ~q', [Ret]),
	self_uri(basic, [focus=Focus, retrieval=Ret], [], To),
	debug(refresh, 'refresh throwing...', [To]),
	throw(http_reply(moved(To))).
	

%possible_reply(Req, ReqId) :-
%	hosting_reply(Req, ReqId).
possible_reply(Req, ReqId) :-
	ontology_page_view_reply(Req, ReqId).
possible_reply(Req, _ReqId) :-
	member(path(X), Req),
        concat_atom(['/diag', _], X),
        !,
	diagnostic_reply(Req).
possible_reply(Req, ReqId) :-
	member(path('/'), Req),
	!,
	thread_set_state(generating_home_page),
	write_page(ReqId, homeBody(Req), '').
possible_reply(Req, _ReqId) :-
	owned_term_reply(Req).
possible_reply(Req, ReqId) :-
	basic_reply_1(Req, ReqId).
possible_reply(Req, _ReqId) :- 
	member(path('/up'), Req),
	format('Content-type: text/plain~n~n', []),
	semwalker_start_time(T),
	convert_time(T, TA),
	current_prolog_flag(pid, PID),
	format('SemWalker running, pid ~a, started ~a~n',
	       [PID, TA]).
possible_reply(Req, ReqId) :- 
	member(path('/submit'), Req),
	!,
	thread_set_state(submit),
	handle_submit(Req, ReqId).
possible_reply(Req, _ReqId) :-
	member(path(X), Req),
        concat_atom(['/static/', File], X),
        !,
	thread_set_state(static_reply),
	( serve(File) ; throw(static_failed) ), !.
possible_reply(_Req, ReqId) :-
	write_page(ReqId, [h2('Bad site URI.  Kinda like a 404, really.')], '').


:- multifile web_server_predicate/2.

%:-multifile '$messages':translate_message/3.
%'$messages':translate_message(foo, _, _) :-
%     print_message(error, format('*** xxxx', [])).




owned_term_reply(Request) :-
	member(path(X), Request),

	% this is just until rdfpage gets better at recognizing its own pages,
	% or has some proper "groups" implementation
	sub_atom(X, 0, _, _, '/page/'),
	
	app_config(site_uri, SiteURI),
	(   sub_atom(X, 0, 1, _, '/')
	->  sub_atom(X, 1, _, 0, NoSlash)
	;   NoSlash = X
	),
	concat_atom([SiteURI, NoSlash], Full),
	debug(reply, 'M? ~a', [Full]),
	rdfpage_uri(Full),
	debug(reply, 'Sending RDF/XML for ~a', [Full]),
	telling(Stream),
	format('Content-type: application/rdf+xml~n~n', []),
	rdfpage_write(Full, Stream),
	debug(reply, 'Sent RDF/XML for ~a', [Full]).


diagnostic_reply(Request) :-
	debug(reply, diag, []),
	format('Content-type: text/html~n~n', []),
	format('<html>~n', []),
	flag(request, RN, RN),
	write('<h2>Diagnostic Page 17</h3>'),
        write(RN),
        write('-times'),
	format('<table border=1>~n'),
	print_request(Request),
	format('~n</table>~n'),
	format('</html>~n', []).


print_request([]).
print_request([H|T]) :-
	H =.. [Name, Value],
	format('<tr><td>~w<td>~w~n', [Name, Value]),
	print_request(T).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%%    Reify the Request?
%%
%%    Nice for implementing views as RDF Rules; maybe
%%    better performance
%%
%%    We'd still need "Q" in the views for backtrackable
%%    source tracking, I think.
%%

/*
% several of these should have something smarter than 'literal' here,
% something which decodes the values....	
option_name_URI(http_request, input, _, ignore).
option_name_URI(http_request, method, sw:method, literal).
option_name_URI(http_request, path, sw:path, literal).
option_name_URI(http_request, search, sw:search, uri).
option_name_URI(http_request, host, sw:host, literal).
option_name_URI(http_request, user_agent, sw:user_agent, literal).
option_name_URI(http_request, accept, sw:accept, literal).
option_name_URI(http_request, accept_language, sw:accept_language, literal).
option_name_URI(http_request, accept_encoding, sw:accept_encoding, literal).
option_name_URI(http_request, accept_charset, sw:accept_charset, literal).
option_name_URI(http_request, keep_alive, _, ignore).
option_name_URI(http_request, connection, _, ignore).
option_name_URI(http_request, http_version, _, ignore).
option_name_URI(http_request, referer, sw:referer, literal).
option_name_URI(http_request, pragma, sw:pramga, literal).
option_name_URI(http_request, cache_control, sw:cacheControl, literal).
% just ignore the others; maybe we should do something smarter with them?
option_name_URI(http_request, _, _, ignore).

assert_and_deduce_reply(Request, ReqId) :-
	/*
	gensym('blank ', ReqURI),
	% print_message(error, re(Request)),
	rdf_describe_from_options_list(http_request, Request, ReqURI, Triples),
	get_time(Now),
	% get peer name,...?
	triplesToInserts(Triples, Inserts),
	rx(anchor((
		   insert(ReqURI, rdf:type, sw:'Request'),
		   insert(ReqURI, sw:begins, time(Now)),
		   Inserts
		  ), 0)),
	debug(reply, 'Handling request ~a', [ReqURI]),
	/*
	%debug(reply, request_described_as(Triples)),

	do this in tabs?
	
	rxxm((match(Pred, , ),
	     match(ReqURI, Pred, xml_literal(XTree)),
	writexml(XTree)
	    .
	    

	response(ReqURI, XTree),    % this is CLOSE to being an rdf predicate
	xml_wrote(XTree).
	*/
	*/
	basic_reply_1(Request, ReqId).    % still here for now.

*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%





/*

  turn  QueryParms     foo=bar
        into Q         foo(bar)
  for safety, type conversion, etc.
*/

basic_reply_1(Request, ReqId) :-
	(  memberchk(path('/basic'), Request)
	;  memberchk(path('/view'), Request)
	),
	!,
	thread_set_state(basic_reply_startup),
	memberchk(search(QueryParms), Request),
	memberchk(focus=Focus, QueryParms),
	(   memberchk(stacking=RawStacking, QueryParms)
	->  concat_atom(Stacking, ',', RawStacking)
	;   Stacking=[],
	    RawStacking=''
	),
	(   memberchk(timeout=TimeoutAtom, QueryParms)
	->  atom_number(TimeoutAtom, Timeout),
	    (Timeout =< 120)
	;   Timeout = 0.5
	),
	(   memberchk(starting=StartingAtom, QueryParms)
	->  atom_number(StartingAtom, Starting)
	;   Starting=1
	),
	(   memberchk(refresh=_, QueryParms)
	->  HarvestOptions=[max_age(1)]
	;   HarvestOptions=[]
	),
	debug(reply, 'its a basic page, focussed on ~q', Focus),
	% we could bundle in the Request   |Request   if we wanted....
	basic_reply_2([focus=Focus, timeout(Timeout), stacking=RawStacking, stacking(Stacking), starting(Starting), harvest_options(HarvestOptions)], ReqId).

basic_reply_2(Q, ReqId) :-
	member(focus=Focus, Q),
	member(timeout(Timeout), Q),
	flag(basic_page_request, N, N+1),
	focus_flags(Focus, FocusFlags),
	debug(reply, 'FocusFlags: ~q', [FocusFlags]),
	%   hrm-- icky icky code
	(   memberchk(load(Address), FocusFlags),
	    \+rdfpage_uri(Address)
	->  memberchk(harvest_options(HarvestOptions), Q),
	    memberchk(timeout(Timeout), Q),
	    thread_state_call(webload(Address, [wait(Timeout), priority(2), retrieval(RR) | HarvestOptions])),
	    writeq(user_error, webload(Address, [wait(Timeout), priority(2), retrieval(RR) | HarvestOptions])),
	    !,  % hrm.
	    log_term(webload, webload(Address))
	;   true
	),
	(   member(prefix_alone(Prefix), FocusFlags),
	    rdf_db:ns(Prefix, Long)
	->  RealQ = [focus=Long | Q]
	;   RealQ = Q
	),
	(   member(qname(Prefix, Suffix), FocusFlags),
	    rdf_db:ns(Prefix, Long),
	    atom_concat(Long, Suffix, Joined)
	->  RealQ2 = [focus=Joined | RealQ]
	;   RealQ2 = RealQ
	),
	debug(reply, 'Q: ~q', [RealQ2]),
	(   member(multiple, FocusFlags)
	->  (   search_reply(Q, ReqId, Focus, FocusFlags)
	    ->  true
	    ;   throw(search_reply_failed)
	    )
	;   thread_set_state(write_basic_page),
	    write_basic_page(RealQ2, ReqId)
	).



siteHead(Focus, H) :-
	app_config(site_title, Title),
	H=div(class=siteHead,
	      h1(class=siteTitle,
		 a(href='http://www.w3.org/', border='0',
		   img(class=siteTitle1, border='0',
		       src='http://www.w3.org/Icons/WWW/w3c_home')
		  ),
		 %'&nbsp;',
		 %a(href='.',
		 %  img(class=siteTitle1, border='0',
		 %      src='http://www.w3.org/2004/05/ontaria-alpha/static/ontaria-bg-48')),
                 %'&nbsp;'  %,
		 a(class=siteTitle2,
		   href='.', Title)
		),
	      div(class=siteControls,
		  a(href='.', 'Home'),
		  a(href='http://projects.semwebcentral.org/forum/?group_id=59', 'Feedback'),
		  a(href='static/help', 'Help')
		 ),
	      +search_form(Focus)
	     ).

siteFoot(ReqID, H) :-
	get_time(Now),
	req_start_stats(ReqID, Start, _StartCPU),
	Time is Now - Start,
	%thread_self(Thread),
	%thread_statistics(Thread, cputime, NowCPU),
	%CPUTime is NowCPU - StartCPU,
	H=div(class=siteFoot,
	      p('Ontaria is an experimental service of the ',
		a(href='http://www.w3.org/', 'World Wide Web Consortium'),
		' as part of the ',
		a(href='http://www.w3.org/2000/01/sw/#daml', 'MIT/CSAIL DAML Project'),
		' under MIT/AFRL cooperative agreement number F30602-00-2-0593.   See ', a(href='static/about', 'about Ontaria')),
	      % p('This site brought to you by the letters W, W, and W.   (Financial support from DARPA.)'),
	      p('Page constructed in ',
	      float(Time,4), ' seconds.'),
	      +if(my_client_is_fast, '  You seem to be loading pages faster than one page per second, so certain slow operations will not be done on your behalf.   Waiting ten seconds will clear this state.')
	     %float(CPUTime,6), ' thread cpu seconds.')
	      ).



/*


http://127.0.0.1:7116/basic?focus=http%3a%2f%2fwww%2ew3%2eorg%2f2004%2f10%2ffamilies%23sister

*/
