mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-10 03:13:46 +00:00
9095985aa8
deep_profiler/*.m:
Fix inconsistencies between (a) the order in which functions and predicates
are declared, and (b) the order in which they are defined.
In most modules, either the order of the declarations or the order
of the definitions made sense, and I changed the other to match.
In some modules, neither made sense, so I changed *both* to an order
that *does* make sense (i.e. it has related predicates together).
In query.m, put the various commands in the same sensible order
as the code processing them.
In html_format.m, merge two exported functions together, since
they can't be used separately.
In some places, put dividers between groups of related
functions/predicates, to make the groups themselves more visible.
In some places, fix comments or programming style.
deep_profiler/DEEP_FLAGS.in:
Since all the modules in this directory are now free from any warnings
generated by --warn-inconsistent-pred-order-clauses, specify that option
by default in this directory to keep it that way.
913 lines
31 KiB
Mathematica
913 lines
31 KiB
Mathematica
%---------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 2001-2012 The University of Melbourne.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% File: mdprof_cgi.m.
|
|
% Author of initial version: conway.
|
|
% Author of this version: zs.
|
|
%
|
|
% This file contains the CGI "script" that is executed by the web server
|
|
% to handle web page requests implemented by the Mercury deep profiler server.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- module mdprof_cgi.
|
|
:- interface.
|
|
|
|
:- import_module io.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred main(io::di, io::uo) is cc_multi.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module conf.
|
|
:- import_module interface.
|
|
:- import_module profile.
|
|
:- import_module query.
|
|
:- import_module startup.
|
|
:- import_module timeout.
|
|
|
|
:- import_module bool.
|
|
:- import_module char.
|
|
:- import_module getopt.
|
|
:- import_module int.
|
|
:- import_module library.
|
|
:- import_module list.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module require.
|
|
:- import_module string.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% The web server should always set QUERY_STRING. It may also pass its contents
|
|
% as arguments, but if any characters special to the shell occur in the query,
|
|
% they will screw up the argument list. We therefore look at the argument list
|
|
% only if QUERY_STRING isn't set, which means that the program was invoked
|
|
% from the command line for debugging.
|
|
|
|
main(!IO) :-
|
|
write_html_header(!IO),
|
|
io.get_environment_var("QUERY_STRING", MaybeQueryString, !IO),
|
|
(
|
|
MaybeQueryString = yes(QueryString0),
|
|
getopt.process_options(
|
|
option_ops_multi(short, long, defaults), [], _, MaybeOptions),
|
|
(
|
|
MaybeOptions = ok(Options)
|
|
;
|
|
MaybeOptions = error(_Msg),
|
|
error("mdprof_cgi: error parsing empty command line")
|
|
),
|
|
string_to_maybe_query(QueryString0) = MaybeDeepQuery,
|
|
(
|
|
MaybeDeepQuery = yes(DeepQuery),
|
|
DeepQuery = deep_query(MaybeCmd, DeepFileName, MaybePrefs),
|
|
(
|
|
MaybeCmd = yes(Cmd)
|
|
;
|
|
MaybeCmd = no,
|
|
Cmd = default_command
|
|
),
|
|
process_query(Cmd, DeepFileName, MaybePrefs, Options, !IO)
|
|
;
|
|
MaybeDeepQuery = no,
|
|
io.set_exit_status(1, !IO),
|
|
% Give the simplest URL in the error message.
|
|
io.write_string("Bad URL; expected filename \n", !IO)
|
|
)
|
|
;
|
|
MaybeQueryString = no,
|
|
process_command_line(!IO)
|
|
).
|
|
|
|
:- pred process_command_line(io::di, io::uo) is cc_multi.
|
|
|
|
process_command_line(!IO) :-
|
|
io.progname_base(mdprof_cgi_progname, ProgName, !IO),
|
|
io.command_line_arguments(Args0, !IO),
|
|
trace [compiletime(flag("debug-args")), io(!DIO)] (
|
|
io.write_string("command line: ", !DIO),
|
|
io.write_list(Args0, " ", write_bracketed_string, !DIO),
|
|
io.nl(!DIO)
|
|
),
|
|
getopt.process_options(option_ops_multi(short, long, defaults),
|
|
Args0, Args, MaybeOptions),
|
|
(
|
|
MaybeOptions = ok(Options),
|
|
lookup_bool_option(Options, help, Help),
|
|
lookup_bool_option(Options, version, Version),
|
|
lookup_bool_option(Options, decode, Decode),
|
|
lookup_bool_option(Options, decode_cmd, DecodeCmd),
|
|
lookup_bool_option(Options, decode_prefs, DecodePrefs),
|
|
(
|
|
Help = yes,
|
|
write_help_message(ProgName, !IO)
|
|
;
|
|
Help = no
|
|
),
|
|
(
|
|
Version = yes,
|
|
write_version_message(ProgName, !IO)
|
|
;
|
|
Version = no
|
|
),
|
|
( if
|
|
Decode = no,
|
|
DecodeCmd = no,
|
|
DecodePrefs = no
|
|
then
|
|
true
|
|
else
|
|
decode_input_lines(Decode, DecodeCmd, DecodePrefs, !IO)
|
|
),
|
|
( if
|
|
Help = no,
|
|
Version = no,
|
|
Decode = no,
|
|
DecodeCmd = no,
|
|
DecodePrefs = no
|
|
then
|
|
process_args(ProgName, Args, Options, !IO)
|
|
else
|
|
true
|
|
)
|
|
;
|
|
MaybeOptions = error(Msg),
|
|
io.set_exit_status(1, !IO),
|
|
io.format("%s: error parsing options: %s\n",
|
|
[s(ProgName), s(Msg)], !IO)
|
|
).
|
|
|
|
:- pred decode_input_lines(bool::in, bool::in, bool::in, io::di, io::uo)
|
|
is det.
|
|
|
|
decode_input_lines(Decode, DecodeCmd, DecodePrefs, !IO) :-
|
|
io.read_line_as_string(LineResult, !IO),
|
|
(
|
|
LineResult = ok(LineStr),
|
|
(
|
|
Decode = no
|
|
;
|
|
Decode = yes,
|
|
io.write_string("considering as query string:\n", !IO),
|
|
string_to_maybe_query(LineStr) = MaybeQuery,
|
|
(
|
|
MaybeQuery = yes(deep_query(MaybeCmd, DeepFileName,
|
|
MaybePrefs)),
|
|
io.write_string("Maybe Command:\n", !IO),
|
|
io.write(MaybeCmd, !IO),
|
|
io.nl(!IO),
|
|
io.format("Deep File Name: %s\n", [s(DeepFileName)], !IO),
|
|
% The preferences may fail to parse, in this case no
|
|
% preferences are assumed.
|
|
io.write_string("Maybe Preferences:\n", !IO),
|
|
io.write(MaybePrefs, !IO),
|
|
io.nl(!IO)
|
|
;
|
|
MaybeQuery = no,
|
|
io.write_string("invalid query string: " ++
|
|
"cannot split into components\n", !IO)
|
|
)
|
|
),
|
|
(
|
|
DecodeCmd = no
|
|
;
|
|
DecodeCmd = yes,
|
|
io.write_string("considering as cmd string:\n", !IO),
|
|
MaybeCmd1 = string_to_maybe_cmd(LineStr),
|
|
(
|
|
MaybeCmd1 = no,
|
|
io.format("invalid command string %s\n", [s(LineStr)], !IO)
|
|
;
|
|
MaybeCmd1 = yes(Cmd),
|
|
io.write(Cmd, !IO),
|
|
io.nl(!IO)
|
|
)
|
|
),
|
|
(
|
|
DecodePrefs = no
|
|
;
|
|
DecodePrefs = yes,
|
|
io.write_string("considering as preference string:\n", !IO),
|
|
MaybePref = string_to_maybe_pref(LineStr),
|
|
(
|
|
MaybePref = no,
|
|
io.format("invalid preferences string %s\n", [s(LineStr)], !IO)
|
|
;
|
|
MaybePref = yes(Pref),
|
|
io.write(Pref, !IO),
|
|
io.nl(!IO)
|
|
)
|
|
),
|
|
decode_input_lines(Decode, DecodeCmd, DecodePrefs, !IO)
|
|
;
|
|
LineResult = error(Error),
|
|
io.error_message(Error, Msg),
|
|
io.format("%s\n", [s(Msg)], !IO)
|
|
;
|
|
LineResult = eof
|
|
).
|
|
|
|
:- func mdprof_cgi_progname = string.
|
|
|
|
mdprof_cgi_progname = "mdprof_cgi".
|
|
|
|
:- pred write_version_message(string::in, io::di, io::uo) is det.
|
|
|
|
write_version_message(ProgName, !IO) :-
|
|
library.version(Version, Fullarch),
|
|
io.format("%s: Mercury deep profiler\n", [s(ProgName)], !IO),
|
|
io.format("version: %s, on %s.\n",
|
|
[s(Version), s(Fullarch)], !IO).
|
|
|
|
:- pred write_help_message(string::in, io::di, io::uo) is det.
|
|
|
|
write_help_message(ProgName, !IO) :-
|
|
% The options are deliberately not documented; they change
|
|
% quite rapidly, based on the debugging needs of the moment.
|
|
% The optional filename argument is also for implementors only.
|
|
io.format("Usage: %s\n", [s(ProgName)], !IO),
|
|
io.format("This program doesn't expect any arguments;\n", [], !IO),
|
|
io.format("instead it decides what to do based on the\n", [], !IO),
|
|
io.format("QUERY_STRING environment variable.\n", [], !IO).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred process_args(string::in, list(string)::in, option_table::in,
|
|
io::di, io::uo) is cc_multi.
|
|
|
|
process_args(ProgName, Args, Options, !IO) :-
|
|
( if Args = [DeepFileName] then
|
|
% Although this mode of usage is not intended for production use,
|
|
% allowing the filename and a limited range of commands to be supplied
|
|
% on the command line makes debugging very much easier.
|
|
process_query(default_cmd(Options), DeepFileName, no, Options, !IO)
|
|
else
|
|
io.set_exit_status(1, !IO),
|
|
write_help_message(ProgName, !IO),
|
|
trace [compiletime(flag("debug-args")), io(!DIO)] (
|
|
io.write_string("processed args: ", !DIO),
|
|
io.write_list(Args, " ", write_bracketed_string, !DIO)
|
|
)
|
|
).
|
|
|
|
% This predicate is for debugging the command line given to mdprof_cgi by the
|
|
% web server, should that be necessary.
|
|
|
|
:- pred write_bracketed_string(string::in, io::di, io::uo) is det.
|
|
|
|
write_bracketed_string(S, !IO) :-
|
|
io.write_string("<", !IO),
|
|
io.write_string(S, !IO),
|
|
io.write_string(">", !IO).
|
|
|
|
:- pred write_html_header(io::di, io::uo) is det.
|
|
|
|
write_html_header(!IO) :-
|
|
io.write_string(html_header_text, !IO),
|
|
io.flush_output(!IO).
|
|
|
|
:- func html_header_text = string.
|
|
|
|
html_header_text = "Content-type: text/html\n\n".
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred process_query(cmd::in, string::in, maybe(preferences)::in,
|
|
option_table::in, io::di, io::uo) is cc_multi.
|
|
|
|
process_query(Cmd0, DeepFileName0, MaybePref, Options0, !IO) :-
|
|
( if Cmd0 = deep_cmd_restart then
|
|
% This process got started because there was no server, and this
|
|
% process will become the new server, so the user just got the freshly
|
|
% started server they asked for. There is no point in starting it
|
|
% again. As it is, create_report would throw an exception for
|
|
% deep_cmd_restart, expecting it to be filtered out by its usual caller
|
|
% server_loop. To avoid the exception, we have to filter it out too.
|
|
Cmd = deep_cmd_menu
|
|
else
|
|
Cmd = Cmd0
|
|
),
|
|
(
|
|
MaybePref = yes(Pref),
|
|
PrefInd = given_pref(Pref)
|
|
;
|
|
MaybePref = no,
|
|
PrefInd = default_pref
|
|
),
|
|
( if
|
|
string.remove_suffix(DeepFileName0, ".localhost", DeepFileNamePrime)
|
|
then
|
|
DeepFileName = DeepFileNamePrime,
|
|
map.det_update(localhost, bool(yes), Options0, Options)
|
|
else
|
|
DeepFileName = DeepFileName0,
|
|
Options = Options0
|
|
),
|
|
( if string.remove_suffix(DeepFileName, ".data", _BaseFileName) then
|
|
ToServerPipe = to_server_pipe_name(DeepFileName),
|
|
FromServerPipe = from_server_pipe_name(DeepFileName),
|
|
StartupFile = server_startup_name(DeepFileName),
|
|
MutexFile = mutex_file_name(DeepFileName),
|
|
lookup_bool_option(Options, debug, Debug),
|
|
WantFile = want_file_name,
|
|
make_want_file(WantFile, !IO),
|
|
get_lock(Debug, MutexFile, !IO),
|
|
(
|
|
Debug = yes
|
|
% Do not set up any cleanups; leave all files around,
|
|
% since they may be needed for postmortem examination.
|
|
;
|
|
Debug = no,
|
|
setup_signals(MutexFile, want_dir, want_prefix, !IO)
|
|
),
|
|
check_for_existing_fifos(ToServerPipe, FromServerPipe, FifoCount, !IO),
|
|
( if FifoCount = 0 then
|
|
handle_query_from_new_server(Cmd, PrefInd, DeepFileName,
|
|
ToServerPipe, FromServerPipe, StartupFile, MutexFile, WantFile,
|
|
Options, !IO)
|
|
else if FifoCount = 2 then
|
|
handle_query_from_existing_server(Cmd, PrefInd,
|
|
ToServerPipe, FromServerPipe, MutexFile, WantFile, Options,
|
|
!IO)
|
|
else
|
|
release_lock(Debug, MutexFile, !IO),
|
|
remove_want_file(WantFile, !IO),
|
|
io.set_exit_status(1, !IO),
|
|
io.write_string("mdprof internal error: bad fifo count", !IO)
|
|
)
|
|
else
|
|
io.set_exit_status(1, !IO),
|
|
io.format("<h3> Invalid file name %s.<h3>\n\n",
|
|
[s(DeepFileName)], !IO),
|
|
io.write_string(
|
|
"Deep profiling data files must have a .data suffix, " ++
|
|
"to allow the deep profiler to locate any related files.\n", !IO)
|
|
).
|
|
|
|
% This type is used to pass queries between the two servers.
|
|
%
|
|
:- type cmd_pref
|
|
---> cmd_pref(cmd, preferences_indication).
|
|
|
|
% Handle the given query using the existing server. Delete the mutex and
|
|
% want files when we get out of the critical region.
|
|
%
|
|
:- pred handle_query_from_existing_server(cmd::in, preferences_indication::in,
|
|
string::in, string::in, string::in, string::in, option_table::in,
|
|
io::di, io::uo) is det.
|
|
|
|
handle_query_from_existing_server(Cmd, PrefInd, ToServerPipe, FromServerPipe,
|
|
MutexFile, WantFile, Options, !IO) :-
|
|
lookup_bool_option(Options, debug, Debug),
|
|
trace [compiletime(flag("debug_client_server")), io(!S)] (
|
|
io.open_append("/tmp/deep_debug", Res1, !S),
|
|
(
|
|
Res1 = ok(DebugStream1),
|
|
io.write_string(DebugStream1,
|
|
"sending query to existing server.\n", !S),
|
|
io.write(DebugStream1, cmd_pref(Cmd, PrefInd), !S),
|
|
io.close_output(DebugStream1, !S)
|
|
;
|
|
Res1 = error(_)
|
|
)
|
|
),
|
|
send_term(ToServerPipe, Debug, cmd_pref(Cmd, PrefInd), !IO),
|
|
release_lock(Debug, MutexFile, !IO),
|
|
remove_want_file(WantFile, !IO),
|
|
recv_string(FromServerPipe, Debug, ResponseFileName, !IO),
|
|
CatCmd = string.format("cat %s", [s(ResponseFileName)]),
|
|
io.call_system(CatCmd, _, !IO),
|
|
trace [compiletime(flag("debug_client_server")), io(!T)] (
|
|
io.open_append("/tmp/deep_debug", Res2, !T),
|
|
(
|
|
Res2 = ok(DebugStream2),
|
|
io.write_string(DebugStream2,
|
|
"sending reply from existing server.\n", !T),
|
|
io.close_output(DebugStream2, !T),
|
|
DebugCatCmd = string.format("cat %s >> /tmp/deep_debug",
|
|
[s(ResponseFileName)]),
|
|
io.call_system(DebugCatCmd, _, !T)
|
|
;
|
|
Res2 = error(_)
|
|
)
|
|
),
|
|
(
|
|
Debug = yes
|
|
% Leave the response file to be examined.
|
|
;
|
|
Debug = no,
|
|
io.remove_file(ResponseFileName, _, !IO)
|
|
).
|
|
|
|
% Handle the given query and then become the new server. Delete the mutex
|
|
% and want files when we get out of the critical region.
|
|
%
|
|
:- pred handle_query_from_new_server(cmd::in, preferences_indication::in,
|
|
string::in, string::in, string::in, string::in, string::in, string::in,
|
|
option_table::in, io::di, io::uo) is cc_multi.
|
|
|
|
handle_query_from_new_server(Cmd, PrefInd, FileName, ToServerPipe,
|
|
FromServerPipe, StartupFile, MutexFile, WantFile, Options, !IO) :-
|
|
lookup_bool_option(Options, localhost, LocalHost),
|
|
(
|
|
LocalHost = no,
|
|
server_name_port(Machine, !IO)
|
|
;
|
|
LocalHost = yes,
|
|
Machine = "localhost"
|
|
),
|
|
script_name(ScriptName, !IO),
|
|
lookup_bool_option(Options, canonical_clique, Canonical),
|
|
lookup_bool_option(Options, server_process, ServerProcess),
|
|
lookup_bool_option(Options, debug, Debug),
|
|
lookup_bool_option(Options, record_startup, RecordStartup),
|
|
(
|
|
RecordStartup = yes,
|
|
io.open_output(StartupFile, StartupStreamRes, !IO),
|
|
(
|
|
StartupStreamRes = ok(StartupStream0),
|
|
MaybeStartupStream = yes(StartupStream0),
|
|
register_file_for_cleanup(StartupFile, !IO)
|
|
;
|
|
StartupStreamRes = error(_),
|
|
error("cannot create startup file")
|
|
)
|
|
;
|
|
RecordStartup = no,
|
|
MaybeStartupStream = no
|
|
),
|
|
read_and_startup_default_deep_options(Machine, ScriptName, FileName,
|
|
Canonical, MaybeStartupStream, [], StartupResult, !IO),
|
|
(
|
|
StartupResult = ok(Deep),
|
|
Pref = solidify_preference(Deep, PrefInd),
|
|
try_exec(Cmd, Pref, Deep, HTML),
|
|
(
|
|
MaybeStartupStream = yes(StartupStream1),
|
|
io.format(StartupStream1, "query 0 output:\n%s\n", [s(HTML)], !IO),
|
|
% If we don't flush the output before the fork, it will be flushed
|
|
% twice, once by the parent process and once by the child process.
|
|
io.flush_output(StartupStream1, !IO)
|
|
;
|
|
MaybeStartupStream = no
|
|
),
|
|
(
|
|
ServerProcess = no,
|
|
% --no-server-process should be specified only during debugging.
|
|
release_lock(Debug, MutexFile, !IO),
|
|
remove_want_file(WantFile, !IO),
|
|
io.write_string(HTML, !IO)
|
|
;
|
|
ServerProcess = yes,
|
|
make_pipes(FileName, Success, !IO),
|
|
(
|
|
Success = yes,
|
|
io.write_string(HTML, !IO),
|
|
io.flush_output(!IO),
|
|
start_server(Options, ToServerPipe, FromServerPipe,
|
|
MaybeStartupStream, MutexFile, WantFile, Deep, !IO)
|
|
;
|
|
Success = no,
|
|
release_lock(Debug, MutexFile, !IO),
|
|
remove_want_file(WantFile, !IO),
|
|
io.set_exit_status(1, !IO),
|
|
io.write_string("could not make pipes\n", !IO)
|
|
)
|
|
)
|
|
;
|
|
StartupResult = error(Error),
|
|
release_lock(Debug, MutexFile, !IO),
|
|
remove_want_file(WantFile, !IO),
|
|
io.set_exit_status(1, !IO),
|
|
io.format("%s\n", [s(Error)], !IO)
|
|
).
|
|
|
|
% Become the new server. Delete the mutex and want files when we get out
|
|
% of the critical region.
|
|
%
|
|
:- pred start_server(option_table::in, string::in, string::in,
|
|
maybe(io.output_stream)::in, string::in, string::in,
|
|
deep::in, io::di, io::uo) is cc_multi.
|
|
|
|
start_server(Options, ToServerPipe, FromServerPipe, MaybeStartupStream,
|
|
MutexFile, WantFile, Deep, !IO) :-
|
|
lookup_bool_option(Options, detach_process, DetachProcess),
|
|
lookup_bool_option(Options, record_loop, RecordLoop),
|
|
lookup_bool_option(Options, debug, Debug),
|
|
(
|
|
DetachProcess = no,
|
|
% We behave as if we were in the child, to allow the server
|
|
% loop to be debugged.
|
|
DetachRes = in_child(child_has_no_parent)
|
|
;
|
|
DetachProcess = yes,
|
|
detach_process(DetachRes, !IO)
|
|
),
|
|
(
|
|
DetachRes = in_child(ChildHasParent),
|
|
% We are in the child; start serving queries.
|
|
(
|
|
ChildHasParent = child_has_parent,
|
|
% Our parent process will perform the file removals needed to exit
|
|
% the critical section; we don't want to duplicate them. We also
|
|
% don't want to delete the pipes we need or the startup file.
|
|
unregister_file_for_cleanup(MutexFile, !IO),
|
|
unregister_file_for_cleanup(WantFile, !IO),
|
|
|
|
% We need to close stdout and stderr to let the web server
|
|
% know that there will be no further outputs on those streams.
|
|
% We also close stdin, since that may also be a named pipe.
|
|
%
|
|
% The binary streams are clones of the text streams, and we must
|
|
% close them too to let the web server finish displaying the page.
|
|
io.stdin_stream(StdIn, !IO),
|
|
io.close_input(StdIn, !IO),
|
|
io.stdout_stream(StdOut, !IO),
|
|
io.close_output(StdOut, !IO),
|
|
io.stderr_stream(StdErr, !IO),
|
|
io.close_output(StdErr, !IO),
|
|
io.binary_input_stream(BinaryStdIn, !IO),
|
|
io.close_binary_input(BinaryStdIn, !IO),
|
|
io.binary_output_stream(BinaryStdOut, !IO),
|
|
io.close_binary_output(BinaryStdOut, !IO)
|
|
;
|
|
ChildHasParent = child_has_no_parent,
|
|
% We don't actually have a parent process, so we need to perform
|
|
% the file removals needed to exit the critical section ourselves.
|
|
release_lock(Debug, MutexFile, !IO),
|
|
remove_want_file(WantFile, !IO)
|
|
),
|
|
(
|
|
RecordLoop = yes,
|
|
MaybeDebugStream = MaybeStartupStream
|
|
;
|
|
RecordLoop = no,
|
|
MaybeDebugStream = no
|
|
),
|
|
lookup_int_option(Options, timeout, TimeOut),
|
|
lookup_bool_option(Options, canonical_clique, Canonical),
|
|
server_loop(ToServerPipe, FromServerPipe, TimeOut,
|
|
MaybeDebugStream, Debug, Canonical, 0, Deep, !IO)
|
|
;
|
|
DetachRes = in_parent,
|
|
% We are in the parent after we spawned the child. We cause the process
|
|
% to exit simply by not calling server_loop.
|
|
%
|
|
% We leave the pipes and the startup file; we clean up only the files
|
|
% involved in the critical section.
|
|
release_lock(Debug, MutexFile, !IO),
|
|
remove_want_file(WantFile, !IO)
|
|
;
|
|
DetachRes = fork_failed,
|
|
% We are in the parent because the fork failed. Again we cause
|
|
% the process to exit simply by not calling server_loop, but we also
|
|
% report the failure through the exit status. We don't report it
|
|
% via the generated web page, since the cause could be transitory
|
|
% and may not recur.
|
|
%
|
|
% This deletes all the files created by the process, including
|
|
% WantFile and MutexFile, with MutexFile being deleted last.
|
|
delete_cleanup_files(!IO),
|
|
io.set_exit_status(1, !IO)
|
|
).
|
|
|
|
:- pred server_loop(string::in, string::in, int::in,
|
|
maybe(io.output_stream)::in, bool::in, bool::in, int::in,
|
|
deep::in, io::di, io::uo) is cc_multi.
|
|
|
|
server_loop(ToServerPipe, FromServerPipe, TimeOut0, MaybeStartupStream,
|
|
Debug, Canonical, QueryNum0, Deep0, !IO) :-
|
|
setup_timeout(TimeOut0, !IO),
|
|
QueryNum = QueryNum0 + 1,
|
|
recv_term(ToServerPipe, Debug, CmdPref0, !IO),
|
|
(
|
|
MaybeStartupStream = yes(StartupStream0),
|
|
io.format(StartupStream0, "server loop query %d\n",
|
|
[i(QueryNum)], !IO),
|
|
io.write(StartupStream0, CmdPref0, !IO),
|
|
io.nl(StartupStream0, !IO),
|
|
io.flush_output(StartupStream0, !IO)
|
|
;
|
|
MaybeStartupStream = no
|
|
),
|
|
CmdPref0 = cmd_pref(Cmd0, PrefInd0),
|
|
|
|
( if Cmd0 = deep_cmd_restart then
|
|
read_and_startup_default_deep_options(Deep0 ^ server_name_port,
|
|
Deep0 ^ script_name, Deep0 ^ data_file_name, Canonical,
|
|
MaybeStartupStream, [], MaybeDeep, !IO),
|
|
(
|
|
MaybeDeep = ok(Deep),
|
|
MaybeMsg = no,
|
|
Cmd = deep_cmd_menu
|
|
;
|
|
MaybeDeep = error(ErrorMsg),
|
|
MaybeMsg = yes(ErrorMsg),
|
|
Deep = Deep0,
|
|
Cmd = deep_cmd_quit
|
|
)
|
|
else
|
|
Deep = Deep0,
|
|
MaybeMsg = no,
|
|
Cmd = Cmd0
|
|
),
|
|
Pref0 = solidify_preference(Deep, PrefInd0),
|
|
(
|
|
MaybeMsg = yes(HTML)
|
|
;
|
|
MaybeMsg = no,
|
|
try_exec(Cmd, Pref0, Deep, HTML)
|
|
),
|
|
|
|
ResponseFileName = response_file_name(Deep0 ^ data_file_name, QueryNum),
|
|
io.open_output(ResponseFileName, ResponseRes, !IO),
|
|
(
|
|
ResponseRes = ok(ResponseStream)
|
|
;
|
|
ResponseRes = error(_),
|
|
error("cannot open response file")
|
|
),
|
|
io.write_string(ResponseStream, HTML, !IO),
|
|
io.close_output(ResponseStream, !IO),
|
|
|
|
send_string(FromServerPipe, Debug, ResponseFileName, !IO),
|
|
|
|
(
|
|
MaybeStartupStream = yes(StartupStream1),
|
|
io.format(StartupStream1, "query %d output:\n%s\n",
|
|
[i(QueryNum), s(HTML)], !IO),
|
|
io.flush_output(StartupStream1, !IO)
|
|
;
|
|
MaybeStartupStream = no
|
|
),
|
|
|
|
( if Cmd = deep_cmd_quit then
|
|
% The lack of a recursive call here shuts down the server.
|
|
%
|
|
% This deletes all the files created by the process, including
|
|
% WantFile and MutexFile, with MutexFile being deleted last.
|
|
delete_cleanup_files(!IO)
|
|
else if Cmd = deep_cmd_timeout(TimeOut) then
|
|
server_loop(ToServerPipe, FromServerPipe, TimeOut, MaybeStartupStream,
|
|
Debug, Canonical, QueryNum, Deep, !IO)
|
|
else
|
|
server_loop(ToServerPipe, FromServerPipe, TimeOut0, MaybeStartupStream,
|
|
Debug, Canonical, QueryNum, Deep, !IO)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred make_pipes(string::in, bool::out, io::di, io::uo) is det.
|
|
|
|
make_pipes(FileName, Success, !IO) :-
|
|
ToServerPipe = to_server_pipe_name(FileName),
|
|
FromServerPipe = from_server_pipe_name(FileName),
|
|
MakeToServerPipeCmd = make_pipe_cmd(ToServerPipe),
|
|
MakeFromServerPipeCmd = make_pipe_cmd(FromServerPipe),
|
|
io.call_system(MakeToServerPipeCmd, ToServerRes, !IO),
|
|
io.call_system(MakeFromServerPipeCmd, FromServerRes, !IO),
|
|
( if
|
|
ToServerRes = ok(0),
|
|
FromServerRes = ok(0)
|
|
then
|
|
register_file_for_cleanup(ToServerPipe, !IO),
|
|
register_file_for_cleanup(FromServerPipe, !IO),
|
|
Success = yes
|
|
else
|
|
% In case one of the pipes *was* created. We ignore the return values
|
|
% because at least one of these calls *will* fail (since we did not
|
|
% create both pipes), and if we can't remove a named pipe we did
|
|
% succeed in creating, then something is so screwed up that probably
|
|
% there is nothing we can do to fix the situation.
|
|
io.remove_file(ToServerPipe, _, !IO),
|
|
io.remove_file(FromServerPipe, _, !IO),
|
|
Success = no
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pragma foreign_decl("C", "
|
|
#ifdef MR_DEEP_PROFILER_ENABLED
|
|
#include <sys/types.h>
|
|
#include <sys/stat.h>
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <unistd.h>
|
|
#endif
|
|
").
|
|
|
|
:- pred check_for_existing_fifos(string::in, string::in, int::out,
|
|
io::di, io::uo) is det.
|
|
|
|
:- pragma foreign_proc("C",
|
|
check_for_existing_fifos(Fifo1::in, Fifo2::in, FifoCount::out,
|
|
S0::di, S::uo),
|
|
[will_not_call_mercury, promise_pure, tabled_for_io],
|
|
"
|
|
#ifdef MR_DEEP_PROFILER_ENABLED
|
|
struct stat statbuf;
|
|
int status;
|
|
|
|
FifoCount = 0;
|
|
status = stat(Fifo1, &statbuf);
|
|
if ((status == 0) && (S_ISFIFO(statbuf.st_mode))) {
|
|
FifoCount++;
|
|
}
|
|
status = stat(Fifo2, &statbuf);
|
|
if ((status == 0) && (S_ISFIFO(statbuf.st_mode))) {
|
|
FifoCount++;
|
|
}
|
|
|
|
S = S0;
|
|
#else
|
|
MR_fatal_error(""deep profiling not enabled"");
|
|
#endif
|
|
").
|
|
|
|
:- type child_has_parent
|
|
---> child_has_parent
|
|
; child_has_no_parent.
|
|
|
|
:- type detach_process_result
|
|
---> in_child(child_has_parent)
|
|
; in_parent
|
|
; fork_failed.
|
|
|
|
:- pred detach_process(detach_process_result::out, io::di, io::uo) is cc_multi.
|
|
|
|
detach_process(Result, !IO) :-
|
|
raw_detach_process(ResCode, !IO),
|
|
( if ResCode < 0 then
|
|
Result = fork_failed
|
|
else if ResCode > 0 then
|
|
Result = in_parent
|
|
else
|
|
Result = in_child(child_has_parent)
|
|
).
|
|
|
|
% Raw_detach_process performs a fork.
|
|
%
|
|
% If the fork succeeds, the result returned by detach_process is:
|
|
%
|
|
% - a positive number in the parent, and
|
|
% - zero in the child.
|
|
%
|
|
% If the fork fails, the result returned by detach_process is:
|
|
%
|
|
% - a negative number in the parent (there is no child process).
|
|
%
|
|
:- pred raw_detach_process(int::out, io::di, io::uo) is cc_multi.
|
|
|
|
:- pragma foreign_proc("C",
|
|
raw_detach_process(ResCode::out, S0::di, S::uo),
|
|
[will_not_call_mercury, promise_pure],
|
|
"{
|
|
#ifdef MR_DEEP_PROFILER_ENABLED
|
|
pid_t status;
|
|
|
|
fflush(stdout);
|
|
fflush(stderr);
|
|
status = fork();
|
|
if (status < 0) {
|
|
ResCode = -1;
|
|
} else if (status > 0) {
|
|
ResCode = 1;
|
|
} else {
|
|
#ifdef MR_HAVE_SETPGID
|
|
/*
|
|
** Try to detach the server process from the parent's process group,
|
|
** in case it uses the number of processes in the process group
|
|
** to decide when the cgi `script' is done.
|
|
*/
|
|
setpgid(0, 0);
|
|
#else
|
|
/* Hope that web server doesn't depend on the process group. */
|
|
#endif
|
|
ResCode = 0;
|
|
}
|
|
|
|
S = S0;
|
|
#else
|
|
MR_fatal_error(""deep profiling not enabled"");
|
|
#endif
|
|
}").
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type option
|
|
---> canonical_clique
|
|
; clique
|
|
; debug
|
|
; decode
|
|
; decode_cmd
|
|
; decode_prefs
|
|
; detach_process
|
|
; help
|
|
; localhost
|
|
; modules
|
|
; proc
|
|
; quit
|
|
; root
|
|
; record_startup
|
|
; record_loop
|
|
; server_process
|
|
; timeout
|
|
; version
|
|
; write_query_string.
|
|
|
|
:- type option_table == (option_table(option)).
|
|
|
|
:- pred short(char::in, option::out) is semidet.
|
|
|
|
short('c', canonical_clique).
|
|
short('C', clique).
|
|
short('d', debug).
|
|
short('m', modules).
|
|
short('p', proc).
|
|
short('q', quit).
|
|
short('r', root).
|
|
short('s', server_process).
|
|
short('t', timeout).
|
|
short('w', write_query_string).
|
|
|
|
:- pred long(string::in, option::out) is semidet.
|
|
|
|
long("canonical-clique", canonical_clique).
|
|
long("clique", clique).
|
|
long("debug", debug).
|
|
long("decode", decode).
|
|
long("decode-cmd", decode_cmd).
|
|
long("decode-prefs", decode_prefs).
|
|
long("detach-process", detach_process).
|
|
long("help", help).
|
|
long("localhost", localhost).
|
|
long("modules", modules).
|
|
long("proc", proc).
|
|
long("quit", quit).
|
|
long("root", root).
|
|
long("record-startup", record_startup).
|
|
long("record-loop", record_loop).
|
|
long("server-process", server_process).
|
|
long("timeout", timeout).
|
|
long("version", version).
|
|
long("write-query-string", write_query_string).
|
|
|
|
:- pred defaults(option::out, option_data::out) is multi.
|
|
|
|
defaults(canonical_clique, bool(no)).
|
|
defaults(clique, int(0)).
|
|
defaults(debug, bool(no)).
|
|
defaults(decode, bool(no)).
|
|
defaults(decode_cmd, bool(no)).
|
|
defaults(decode_prefs, bool(no)).
|
|
defaults(detach_process, bool(yes)).
|
|
defaults(help, bool(no)).
|
|
defaults(localhost, bool(no)).
|
|
defaults(modules, bool(no)).
|
|
defaults(proc, int(0)).
|
|
defaults(quit, bool(no)).
|
|
defaults(root, bool(no)).
|
|
defaults(record_loop, bool(yes)).
|
|
defaults(record_startup, bool(yes)).
|
|
defaults(server_process, bool(yes)).
|
|
defaults(timeout, int(30)).
|
|
defaults(version, bool(no)).
|
|
defaults(write_query_string, bool(yes)).
|
|
|
|
:- func default_cmd(option_table) = cmd.
|
|
|
|
default_cmd(Options) = Cmd :-
|
|
lookup_bool_option(Options, quit, Quit),
|
|
lookup_bool_option(Options, root, Root),
|
|
lookup_bool_option(Options, modules, Modules),
|
|
lookup_int_option(Options, clique, CliqueNum),
|
|
lookup_int_option(Options, proc, ProcProcNum),
|
|
( if Root = yes then
|
|
Cmd = deep_cmd_root(no)
|
|
else if Modules = yes then
|
|
Cmd = deep_cmd_program_modules
|
|
else if CliqueNum > 0 then
|
|
Cmd = deep_cmd_clique(clique_ptr(CliqueNum))
|
|
else if ProcProcNum > 0 then
|
|
Cmd = deep_cmd_proc(proc_static_ptr(ProcProcNum))
|
|
else if Quit = yes then
|
|
Cmd = deep_cmd_quit
|
|
else
|
|
Cmd = deep_cmd_menu
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module mdprof_cgi.
|
|
%---------------------------------------------------------------------------%
|