[m-rev.] for review: make mdprof_cgi respect CGI environment variables
Peter Wang
wangp at students.csse.unimelb.edu.au
Mon Apr 2 10:53:49 AEST 2007
Branches: main
deep_profiler/conf.m:
deep_profiler/html_format.m:
deep_profiler/interface.m:
deep_profiler/mdprof_cgi.m:
deep_profiler/mdprof_feedback.m:
deep_profiler/mdprof_test.m:
deep_profiler/profile.m:
deep_profiler/startup.m:
Respect the CGI environment variables SERVER_NAME, SERVER_PORT and
SCRIPT_NAME. This allows the mdprof_cgi to be used with any web
server, on an arbitrary port, at any URL.
Index: conf.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/conf.m,v
retrieving revision 1.9
diff -u -r1.9 conf.m
--- conf.m 12 Oct 2006 06:30:21 -0000 1.9
+++ conf.m 2 Apr 2007 00:50:20 -0000
@@ -25,9 +25,15 @@
%
:- func make_pipe_cmd(string) = string.
- % The name of the server on which mdprof is being run.
+ % The name of the server and, optionally, the port on which mdprof is
+ % being run.
%
-:- pred server_name(string::out, io::di, io::uo) is det.
+:- pred server_name_port(string::out, io::di, io::uo) is det.
+
+ % The virtual path under which this program is being executed, used for
+ % self-referencing URLs.
+ %
+:- pred script_name(string::out, io::di, io::uo) is det.
:- func getpid = int.
@@ -37,6 +43,7 @@
:- implementation.
:- import_module list.
+:- import_module maybe.
:- import_module require.
:- import_module string.
@@ -50,7 +57,31 @@
string.format("%s %s", [s(CmdName), s(PipeName)], Cmd)
).
+server_name_port(Machine, !IO) :-
+ server_name(ServerName, !IO),
+ maybe_server_port(MaybeServerPort, !IO),
+ (
+ MaybeServerPort = yes(Port),
+ Machine = ServerName ++ ":" ++ Port
+ ;
+ MaybeServerPort = no,
+ Machine = ServerName
+ ).
+
+:- pred server_name(string::out, io::di, io::uo) is det.
+
server_name(ServerName, !IO) :-
+ io.get_environment_var("SERVER_NAME", MaybeServerName, !IO),
+ (
+ MaybeServerName = yes(ServerName)
+ ;
+ MaybeServerName = no,
+ server_name_2(ServerName, !IO)
+ ).
+
+:- pred server_name_2(string::out, io::di, io::uo) is det.
+
+server_name_2(ServerName, !IO) :-
io.make_temp(TmpFile, !IO),
hostname_cmd(HostnameCmd),
ServerRedirectCmd =
@@ -78,6 +109,21 @@
io.remove_file(TmpFile, _, !IO)
;
error("cannot execute cmd to find the server's name")
+ ).
+
+:- pred maybe_server_port(maybe(string)::out, io::di, io::uo) is det.
+
+maybe_server_port(MaybeServerPort, !IO) :-
+ io.get_environment_var("SERVER_PORT", MaybeServerPort, !IO).
+
+script_name(ScriptName, !IO) :-
+ io.get_environment_var("SCRIPT_NAME", MaybeScriptName, !IO),
+ (
+ MaybeScriptName = yes(ScriptName)
+ ;
+ MaybeScriptName = no,
+ % XXX not sure how to handle this, but should not occur in practice
+ ScriptName = "/"
).
:- pred mkfifo_cmd(string::out) is det.
Index: html_format.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/html_format.m,v
retrieving revision 1.16
diff -u -r1.16 html_format.m
--- html_format.m 1 Dec 2006 15:03:46 -0000 1.16
+++ html_format.m 2 Apr 2007 00:50:20 -0000
@@ -2245,8 +2245,8 @@
[s(URL), s(escape_html_string(ProcName))]).
deep_cmd_pref_to_url(Pref, Deep, Cmd) =
- machine_datafile_cmd_pref_to_url(Deep ^ server_name,
- Deep ^ data_file_name, Cmd, Pref).
+ machine_datafile_cmd_pref_to_url(Deep ^ server_name_port,
+ Deep ^ script_name, Deep ^ data_file_name, Cmd, Pref).
%-----------------------------------------------------------------------------%
Index: interface.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/interface.m,v
retrieving revision 1.16
diff -u -r1.16 interface.m
--- interface.m 1 Dec 2006 15:03:46 -0000 1.16
+++ interface.m 2 Apr 2007 00:50:20 -0000
@@ -316,8 +316,8 @@
:- func default_inactive_items = inactive_items.
:- func query_separator_char = char.
-:- func machine_datafile_cmd_pref_to_url(string, string, cmd, preferences)
- = string.
+:- func machine_datafile_cmd_pref_to_url(string, string, string, cmd,
+ preferences) = string.
:- func url_component_to_cmd(string, cmd) = cmd.
:- func url_component_to_maybe_cmd(string) = maybe(cmd).
:- func url_component_to_maybe_pref(string) = maybe(preferences).
@@ -573,10 +573,11 @@
field_separator_char = ('-').
limit_separator_char = ('-').
-machine_datafile_cmd_pref_to_url(Machine, DataFileName, Cmd, Preferences) =
+machine_datafile_cmd_pref_to_url(Machine, ScriptName, DataFileName, Cmd,
+ Preferences) =
"http://" ++
Machine ++
- "/cgi-bin/mdprof_cgi?" ++
+ ScriptName ++ "?" ++
cmd_to_string(Cmd) ++
string.char_to_string(query_separator_char) ++
preferences_to_string(Preferences) ++
Index: mdprof_cgi.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/mdprof_cgi.m,v
retrieving revision 1.17
diff -u -r1.17 mdprof_cgi.m
--- mdprof_cgi.m 1 Dec 2006 15:03:46 -0000 1.17
+++ mdprof_cgi.m 2 Apr 2007 00:50:20 -0000
@@ -308,11 +308,12 @@
lookup_bool_option(Options, localhost, LocalHost),
(
LocalHost = no,
- server_name(Machine, !IO)
+ 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),
@@ -332,8 +333,8 @@
RecordStartup = no,
MaybeStartupStream = no
),
- read_and_startup(Machine, [FileName], Canonical, MaybeStartupStream,
- [], [], Res, !IO),
+ read_and_startup(Machine, ScriptName, [FileName], Canonical,
+ MaybeStartupStream, [], [], Res, !IO),
(
Res = ok(Deep),
Pref = solidify_preference(Deep, PrefInd),
@@ -487,11 +488,11 @@
MaybeStartupStream = no
),
CmdPref0 = cmd_pref(Cmd0, PrefInd0),
- Pref0 = solidify_preference(Deep, PrefInd0),
( Cmd0 = deep_cmd_restart ->
- read_and_startup(Deep0 ^ server_name, [Deep0 ^ data_file_name],
- Canonical, MaybeStartupStream, [], [], MaybeDeep, !IO),
+ read_and_startup(Deep0 ^ server_name_port, Deep0 ^ script_name,
+ [Deep0 ^ data_file_name], Canonical, MaybeStartupStream, [], [],
+ MaybeDeep, !IO),
(
MaybeDeep = ok(Deep),
MaybeMsg = no,
@@ -507,6 +508,7 @@
MaybeMsg = no,
Cmd = Cmd0
),
+ Pref0 = solidify_preference(Deep, PrefInd0),
(
MaybeMsg = yes(HTML)
;
Index: mdprof_feedback.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/mdprof_feedback.m,v
retrieving revision 1.2
diff -u -r1.2 mdprof_feedback.m
--- mdprof_feedback.m 13 Jan 2007 12:23:15 -0000 1.2
+++ mdprof_feedback.m 2 Apr 2007 00:50:20 -0000
@@ -145,7 +145,8 @@
maybe_error(deep)::out, io::di, io::uo) is det.
read_deep_file(Input, Verbose, DumpStages, DumpOptions, MaybeProfile, !IO) :-
- server_name(Machine, !IO),
+ server_name_port(Machine, !IO),
+ script_name(ScriptName, !IO),
(
Verbose = yes,
io.stdout_stream(Stdout, !IO),
@@ -154,7 +155,7 @@
Verbose = no,
MaybeOutput = no
),
- read_and_startup(Machine, [Input], no, MaybeOutput,
+ read_and_startup(Machine, ScriptName, [Input], no, MaybeOutput,
DumpStages, DumpOptions, MaybeProfile, !IO).
% Determine those CSSs whose CSDs' average/median call sequence counts
Index: mdprof_test.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/mdprof_test.m,v
retrieving revision 1.14
diff -u -r1.14 mdprof_test.m
--- mdprof_test.m 1 Dec 2006 15:03:46 -0000 1.14
+++ mdprof_test.m 2 Apr 2007 00:50:20 -0000
@@ -103,7 +103,8 @@
lookup_bool_option(Options, verbose, Verbose),
lookup_accumulating_option(Options, dump, DumpStages),
lookup_accumulating_option(Options, dump_options, DumpOptions),
- server_name(Machine, !IO),
+ server_name_port(Machine, !IO),
+ script_name(ScriptName, !IO),
(
Verbose = no,
MaybeOutput = no
@@ -112,8 +113,8 @@
io.stdout_stream(Stdout, !IO),
MaybeOutput = yes(Stdout)
),
- read_and_startup(Machine, [FileName], Canonical, MaybeOutput,
- DumpStages, DumpOptions, Res, !IO),
+ read_and_startup(Machine, ScriptName, [FileName], Canonical,
+ MaybeOutput, DumpStages, DumpOptions, Res, !IO),
(
Res = ok(Deep),
lookup_bool_option(Options, test, Test),
@@ -165,7 +166,9 @@
verify_profile_2(ProgName, Options, FileName, !IO) :-
lookup_bool_option(Options, canonical_clique, Canonical),
Machine = "dummy_server", % For verification this doesn't matter.
- read_and_startup(Machine, [FileName], Canonical, no, [], [], Res, !IO),
+ script_name(ScriptName, !IO),
+ read_and_startup(Machine, ScriptName, [FileName], Canonical, no,
+ [], [], Res, !IO),
(
Res = ok(_Deep)
;
Index: profile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/profile.m,v
retrieving revision 1.15
diff -u -r1.15 profile.m
--- profile.m 12 Oct 2006 06:30:22 -0000 1.15
+++ profile.m 2 Apr 2007 00:50:20 -0000
@@ -62,7 +62,8 @@
:- type deep
---> deep(
profile_stats :: profile_stats,
- server_name :: string,
+ server_name_port :: string,
+ script_name :: string,
data_file_name :: string,
root :: proc_dynamic_ptr,
Index: startup.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/startup.m,v
retrieving revision 1.15
diff -u -r1.15 startup.m
--- startup.m 1 Dec 2006 15:03:47 -0000 1.15
+++ startup.m 2 Apr 2007 00:50:20 -0000
@@ -28,8 +28,8 @@
%-----------------------------------------------------------------------------%
-:- pred read_and_startup(string::in, list(string)::in, bool::in,
- maybe(io.output_stream)::in, list(string)::in, list(string)::in,
+:- pred read_and_startup(string::in, string::in, list(string)::in,
+ bool::in, maybe(io.output_stream)::in, list(string)::in, list(string)::in,
maybe_error(deep)::out, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
@@ -55,8 +55,8 @@
%-----------------------------------------------------------------------------%
-read_and_startup(Machine, DataFileNames, Canonical, MaybeOutputStream,
- DumpStages, DumpOptions, Res, !IO) :-
+read_and_startup(Machine, ScriptName, DataFileNames, Canonical,
+ MaybeOutputStream, DumpStages, DumpOptions, Res, !IO) :-
(
DataFileNames = [],
% This should have been caught and reported by main.
@@ -72,8 +72,9 @@
maybe_report_stats(MaybeOutputStream, !IO),
(
Res0 = ok(InitDeep),
- startup(Machine, DataFileName, Canonical, MaybeOutputStream,
- DumpStages, DumpOptions, InitDeep, Deep, !IO),
+ startup(Machine, ScriptName, DataFileName, Canonical,
+ MaybeOutputStream, DumpStages, DumpOptions, InitDeep, Deep,
+ !IO),
Res = ok(Deep)
;
Res0 = error(Error),
@@ -84,11 +85,11 @@
error("mdprof_server: merging of data files is not yet implemented")
).
-:- pred startup(string::in, string::in, bool::in, maybe(io.output_stream)::in,
- list(string)::in, list(string)::in, initial_deep::in, deep::out,
- io::di, io::uo) is det.
+:- pred startup(string::in, string::in, string::in, bool::in,
+ maybe(io.output_stream)::in, list(string)::in, list(string)::in,
+ initial_deep::in, deep::out, io::di, io::uo) is det.
-startup(Machine, DataFileName, Canonical, MaybeOutputStream,
+startup(Machine, ScriptName, DataFileName, Canonical, MaybeOutputStream,
DumpStages, DumpOptions, InitDeep0, Deep, !IO) :-
InitDeep0 = initial_deep(InitStats, Root,
CallSiteDynamics0, ProcDynamics, CallSiteStatics0, ProcStatics0),
@@ -218,7 +219,7 @@
array.init(NCSDs, map.init, CSDCompTable0),
ModuleData = map.map_values(initialize_module_data, ModuleProcs),
- Deep0 = deep(InitStats, Machine, DataFileName, Root,
+ Deep0 = deep(InitStats, Machine, ScriptName, DataFileName, Root,
CallSiteDynamics, ProcDynamics, CallSiteStatics, ProcStatics,
CliqueIndex, Cliques, CliqueParents, CliqueMaybeChildren,
ProcCallers, CallSiteStaticMap, CallSiteCalls,
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list