Menu
▾
▴
quicksilver-developers
|
From: Ina C. <in...@st...> - 2001-02-01 01:32:56
|
Hi,
I've added an example to handle the soap message if the body is a
structure. I want to commit the example so that I can concentrate on working
on the client side afterwards.
Ina
<in...@st...>
========================================================================
Estimated hours taken: 20
Add example to handle mercury structure. Also fixup some error handling.
/server/server.m
change the header to request a library filename to be loaded for dl
add predicates to check request header
/server/soap.m
tidy up the code
/server/soap_test_methods.m
/server/web_methods.m
add example to handle mercury structure
========================================================================
Index: server.m
===================================================================
RCS file: /cvsroot/quicksilver/webserver/server/server.m,v
retrieving revision 1.5
diff -u -r1.5 server.m
--- server.m 2001/01/25 06:54:42 1.5
+++ server.m 2001/02/01 01:30:22
@@ -1,5 +1,5 @@
%---------------------------------------------------------------------------%
-% Copyright (C) 2000 Peter Ross
+% Copyright (C) 2000, 2001 Peter Ross
% This file may only be copied under the terms of the GNU General Public
% License - see the file COPYING
%-----------------------------------------------------------------------------%
@@ -82,7 +82,16 @@
{ RequestOrResponse = left(Request) },
(
{ Request^cmd = post },
- get_soapmessage(TCP, Request, Request1)
+ { check_headers(Request^headers, MayBeError) },
+ (
+ { MayBeError = yes(ErrorResponse) }
+ ->
+ send_response(TCP, ErrorResponse),
+ tcp__shutdown(TCP),
+ { error("Invalid HTTP headers in request.\n") }
+ ;
+ get_soapmessage(TCP, Request, Request1)
+ )
;
{ Request^cmd = get },
{ Request1 = Request }
@@ -226,6 +235,67 @@
%---------------------------------------------------------------------------%
+ % Section 6 Using SOAP in HTTP
+ % " HTTP applications MUST use the media type "text/xml"
+ % according to RFC 2376 when including SOAP entity bodies
+ % in HTTP messages.
+ %
+ % Section 6.1.1. The SOAPAction HTTP Header Field
+ % " An HTTP client MUST use this header field when issuing a
+ % SOAP HTTP Request. "
+
+
+:- pred check_headers(list(header)::in, maybe(response)::out) is det.
+
+check_headers(Headers, Response) :-
+ check_each_header(Headers, soapaction_header,
+ "SOAPAction header not found.\n", MayBeResponse0),
+ (
+ MayBeResponse0 = no
+ ->
+ check_each_header(Headers, content_type_header,
+ "Incorrect Content-Type value.\n", MayBeResponse1),
+ (
+ MayBeResponse1 = no
+ ->
+ Response = no
+ ;
+ Response = MayBeResponse1
+ )
+ ;
+ Response = MayBeResponse0
+ ).
+
+:- pred check_each_header(list(header), pred(header), string, maybe(response)).
+:- mode check_each_header(in, pred(in) is semidet, in, out) is det.
+
+check_each_header(Headers, Pred, ErrorMessage, Response) :-
+ list__filter(Pred, Headers, Result),
+ (
+ Result \= []
+ ->
+ Response = no
+ ;
+ Response = yes(response(
+ 400,
+ [],
+ string_body(ErrorMessage),
+ yes )
+ )
+
+ ).
+
+:- pred soapaction_header(header::in) is semidet.
+soapaction_header(header("SOAPAction:", _, _)).
+
+:- pred content_type_header(header::in) is semidet.
+content_type_header(header("Content-Type:", "text/xml", _)).
+content_type_header(header("Content-type:", "text/xml", _)).
+content_type_header(header("Content-Type:", "text/xml;", _)).
+content_type_header(header("Content-type:", "text/xml;", _)).
+
+%---------------------------------------------------------------------------%
+
:- pred get_soapmessage(S, request, request, io__state, io__state)
<= stream__duplex(S).
:- mode get_soapmessage(in, in, out, di, uo) is det.
@@ -243,7 +313,17 @@
yes(string__from_char_list(SoapMessage))
) }
;
- { error("No content-length supplied. Program Terminated.") }
+ { ErrorResponse = response(
+ 411,
+ [],
+ string_body("Content-Length not supplied.\n"),
+ yes) },
+ send_response(S, ErrorResponse),
+
+ % XXX how to convert S back to tcp such that
+ % tcp__shutdown(S) can be called ?
+
+ { error("Content-Length not supplied in request.") }
).
:- pred get_content_length(list(header)::in, int::out) is semidet.
@@ -268,13 +348,12 @@
is_content_type("Content-type:").
:- pred get_body(S, int, list(char), io__state, io__state)
- <= stream__duplex(S).
+ <= stream__input(S).
:- mode get_body(in, in, out, di, uo) is det.
-% XXX if there are still characters when length = 0
-% the rest will not be obtained and consequently parsing
-% an incomplete message will throw an exception.
-
+ % If there are still characters when length = 0,
+ % the rest will not be obtained and consequently parsing
+ % an incomplete message will throw an exception.
get_body(S, Length, RequestLines) -->
stream__read_char(S, CharResult),
{ Length0 = Length - 1 },
@@ -334,9 +413,14 @@
)
;
{ Request^cmd = post },
+ write(uri_to_filename(Request^uri)), nl,
(
{ Request^body = yes(Body) } ,
parse_soapmessage(Body, NsBody),
+
+ % parse_soapmessage calls error/1 when failed
+ % should change to response with http code = 415
+
write(NsBody), nl, nl,
{ get_procedure_call(NsBody, Proc) },
@@ -345,12 +429,12 @@
{ make_web_request(NsBody, Proc, WebRequest) },
write(WebRequest), nl, nl,
- load_dynamic_library("./libsoap_test_methods.so",
+ load_dynamic_library(uri_to_filename(Request^uri),
WebRequest, Result, HttpCode),
(
- { Result = yes(Output) },
+ { Result = yes(OutputString) },
{ generate_response_body(NsBody, Proc,
- Output, ResBody0) },
+ OutputString, ResBody0) },
{ ResBody = string_body(ResBody0) }
;
{ Result = no },
@@ -363,7 +447,7 @@
{ ResBody = no_body },
{ HttpCode = 400 }
),
- { list__filter(filter, Request^headers, Headers) },
+ { generate_headers(Request^headers, ResBody, Headers) },
{ Response = response(HttpCode, Headers,
ResBody, yes) }
).
@@ -380,9 +464,24 @@
last_char(Str)
= string__unsafe_index(Str, string__length(Str) - 1).
+:- pred generate_headers(list(header)::in, response_body::in,
+ list(header)::out) is det.
+generate_headers(RequestHeaders, ResBody, Headers) :-
+ list__filter(filter, RequestHeaders, Headers0),
+ (
+ ResBody = string_body(Body),
+ string__length(Body, BodyLength),
+ string__int_to_string(BodyLength, StringLength),
+ ConLen = [header("Content-Length:", StringLength, no)],
+ list__append(ConLen, Headers0, Headers)
+ ;
+ ResBody = no_body,
+ Headers = []
+ ).
+
:- pred filter(header::in) is semidet.
-filter(header("Content-Length:", _, _)).
filter(header("Content-Type:", _, _)).
+filter(header("Content-type:", _, _)).
%-----------------------------------------------------------------------------%
Index: soap.m
===================================================================
RCS file: /cvsroot/quicksilver/webserver/server/soap.m,v
retrieving revision 1.1
diff -u -r1.1 soap.m
--- soap.m 2001/01/25 06:54:42 1.1
+++ soap.m 2001/02/01 01:30:22
@@ -78,6 +78,9 @@
{ Res = ok((_, Doc)) },
{ nsTranslate(Doc, NsDoc) }
;
+ % instead of error, should change to response
+ % with http code 415 Unsupported Media Type
+
{ Res = error(Err) },
{ string__append("parse_soapmessage failed: ", Err, ErrMsg) },
{ error(ErrMsg) }
@@ -130,13 +133,8 @@
% Gets method name.
get_procedure_call(NsDoc, Procedure) :-
get_procedure(NsDoc, [], Procedurelist),
- get_first_element(Procedurelist, Procedure).
-
-:- pred get_first_element(list(T)::in, T::out) is det.
+ list__index1_det(Procedurelist, 1, Procedure).
-get_first_element([], _) :- error("Procedure not found.").
-get_first_element([H|_], H).
-
:- pred get_procedure(nsDocument, list(nsElement), list(nsElement)).
:- mode get_procedure(in, in, out) is det.
get_procedure(NsDoc, Acc0, Acc) :-
@@ -411,10 +409,6 @@
Acc0, Acc1),
call(Pred, ContentArray, Ref, Method, Result, URIs,
Acc1, Acc).
-
-% :- pred insert_last(list(T)::in, T::in, list(T)::out) is det.
-% insert_last([], T, [T]).
-% insert_last([
:- pred my_delete(list(T)::in, list(T)::out) is det.
my_delete([], []).
Index: soap_test_methods.m
===================================================================
RCS file: /cvsroot/quicksilver/webserver/server/soap_test_methods.m,v
retrieving revision 1.1
diff -u -r1.1 soap_test_methods.m
--- soap_test_methods.m 2001/01/25 06:54:42 1.1
+++ soap_test_methods.m 2001/02/01 01:30:22
@@ -21,20 +21,34 @@
:- module soap_test_methods.
:- interface.
-:- import_module io, int, list, std_util.
+:- import_module list, std_util.
-:- pred hello(state::di, state::uo) is det.
+:- pred hello(univ::out) is det.
:- pred get_sp(list(univ)::in, univ::out) is det.
:- func get_stockprice(list(univ)) = univ.
+% :- pred get_bookprice(book::in, univ::out) is det.
:- pred get_bookprice(list(univ)::in, univ::out) is det.
+:- type book
+ ---> book(
+ title :: string,
+ author :: author,
+ intro :: string
+ ).
+
+:- type author
+ ---> author(
+ surname :: string,
+ firstname :: string
+ ).
+
%---------------------------------------------------------------------%
:- implementation.
-:- import_module require.
+:- import_module int, require.
% remove_first_element(List, Elem, Rest)
% takes out first element of the List and gives back
@@ -51,7 +65,8 @@
% Hello
%---------------------------------------------------------------------%
-hello --> print("Hello, world\n").
+hello(ResultAsUniv) :-
+ ResultAsUniv = univ("<output>Hello, world</output>").
%---------------------------------------------------------------------%
% GetStockPrice
@@ -78,7 +93,7 @@
remove_first_element(ParamList, ParamAsUniv, _)
->
det_univ_to_type(ParamAsUniv, ParamAsInt),
- ResultAsInt = ParamAsInt + 1,
+ ResultAsInt = ParamAsInt + 0,
ResultAsUniv = univ(ResultAsInt)
;
require__error("Error in get_stockprice")
@@ -87,8 +102,22 @@
%---------------------------------------------------------------------%
% GetBookPrice
%---------------------------------------------------------------------%
-
-get_bookprice(ParamList, ResultAsUniv) :-
- ResultAsUniv = univ(100).
+get_bookprice(ParamList, ResultAsUniv) :-
+ list__index1_det(ParamList, 1, ParamAsUniv),
+ Param0 = univ_value(ParamAsUniv),
+ Param = inst_cast_book(Param0),
+ (
+ Param = book("Hello world",
+ author("Foo", "Bar"),
+ "This is a book")
+ ->
+ ResultAsUniv = univ(100)
+ ;
+ ResultAsUniv = univ(50)
+ ).
+:- func inst_cast_book(T) = book.
+:- mode inst_cast_book(in) = out is det.
+:- pragma c_code(inst_cast_book(X::in) = (Y::out),
+ [will_not_call_mercury, thread_safe], "Y = X").
Index: web_methods.m
===================================================================
RCS file: /cvsroot/quicksilver/webserver/server/web_methods.m,v
retrieving revision 1.1
diff -u -r1.1 web_methods.m
--- web_methods.m 2001/01/25 06:54:42 1.1
+++ web_methods.m 2001/02/01 01:30:22
@@ -42,14 +42,7 @@
pFields :: maybe(list(parameter))
% Struct or Array
).
-/* Ignore this
- % Converts method name and parameters in xml.ns format to
- % a web request.
-:- pred make_web_request(nsElement, list(parameter), web_method_request).
-:- mode make_web_request(in, in, out) is det.
-*/
-
% Loads library, invokes method call and generates corresponding
% response.
:- pred load_dynamic_library(string::in, web_method_request::in,
@@ -63,71 +56,11 @@
:- implementation.
:- import_module bool, int, require.
:- import_module dl, name_mangle, soap_test_methods.
-
- % XXX change that to command line argument
-:- func soap_library_file = string.
-soap_library_file = "soap_test_methods".
-
-/* Ignore this. Not used anymore
-
- % Generates a web request using method and parameters
-make_web_request(Proc, Params, Request) :-
- Request^name = Proc^eName^localName,
- Request^uri = Proc^eName^nsURI,
- Request^params = Params.
-
-make_web_request(Proc, Params, Request) :-
- Request^name = Proc^eName^localName,
- Request^uri = Proc^eName^nsURI,
- form_pair(Params, ParamsPair),
- list__map(retrieve_params, ParamsPair, Request^params).
-
- % Transform parameter list from [parameter, data, parameter, data ..]
- % to [(parameter - data)] to distinguish elements
-:- pred form_pair(list(nsContent), list(pair(nsContent, nsContent))).
-:- mode form_pair(in, out) is det.
-
-form_pair(ParamList , PairList) :-
- (
- ParamList = []
- ->
- PairList = []
- ;
- ParamList = [Param, Data | Tail]
- % list__split_list(2, ParamList, Start, End),
- % Start = [Param, Data]
- ->
- PairList = [(Param - Data) | PairList0],
- form_pair(Tail, PairList0)
- ;
- error("Incorrect Data Format")
- ).
+% :- func soap_library_file = string.
+% soap_library_file = "soap_test_methods".
- % Retrieve parameter name, uri, type if defined and data value.
-:- pred retrieve_params(pair(nsContent, nsContent), parameter).
-:- mode retrieve_params(in, out) is det.
-retrieve_params((Param0 - Data), Parameter) :-
- (
- Param0 = nsElement(Param),
- Data = data(Value)
- ->
- Name = Param^eName^localName,
- URI = Param^eName^nsURI,
- (
- search_attributes(Param^eAttrs, Type0)
- ->
- Type = yes(Type0)
- ;
- Type = no
- ),
- Parameter = parameter(Name, Type, Value, URI)
- ;
- error("Incorrect Data Format")
- ).
-*/
-
% Types in XML can be defined either by using xsi:type attribute
% or by using schema. This predicate is used to search if
% any attribute contains `xsi:type'.
@@ -172,51 +105,64 @@
% Opens library file, invokes desire function, and gets back
% corresponding response and http code.
-load_dynamic_library(L, Request, Response, HttpCode) -->
- dl__open(L, lazy, local, MaybeHandle),
+ %
+ % LibFile format = "./libfilename.so"
+ %
+load_dynamic_library(LibFile, Request, Response, HttpCode) -->
+ dl__open(LibFile, lazy, local, MaybeHandle),
+ { get_filename(LibFile, Filename) },
(
{ MaybeHandle = error(OpenMsg) },
{ string__append("dlopen failed: ", OpenMsg, OpenErrorMsg) },
- { Response = yes(OpenErrorMsg) },
- { HttpCode = 500 } % 500 Internal Server Error
+ { Response = no },
+ { HttpCode = 500 }, % 500 Internal Server Error
+ { error(OpenErrorMsg) }
;
{ MaybeHandle = ok(Handle) },
(
% Hello has no parameter
{ Request^name = "Hello" }
->
- call_Hello_pred(Handle, Request, Response0, HttpCode0)
+ call_Hello_pred(Handle, Filename, Request,
+ Response0, HttpCode0)
;
% GetStockPrice has 1 parameter
{ Request^name = "GetStockPrice" }
->
- call_SP_func(Handle, Request, Response0, HttpCode0)
+ call_SP_func(Handle, Filename, Request,
+ Response0, HttpCode0)
;
% GetBookPrice takes in a struct
{ Request^name = "GetBookPrice" }
->
- call_BP_pred(Handle, Request, Response0, HttpCode0)
+ call_BP_pred(Handle, Filename, Request,
+ Response0, HttpCode0)
;
{ Response0 = yes("Method requested not
implemented.") },
{ HttpCode0 = 501 } % 501 Not Implemented
),
+/* commented out dl__close/4 so that the .so can be referred to it
+ when generating responses. If the .so file is closed, any pointers
+ referencing the .so file will become unavailable, causing
+ runtime error: segmentation violation.
+
dl__close(Handle, Result),
(
{ Result = error(CloseMsg) },
{ string__append("dlclose failed: ", CloseMsg,
CloseErrorMsg) },
- { Response1 = yes(CloseErrorMsg) },
+ { Response1 = no },
{ HttpCode1 = 500 },
- { ChangeHttpCode = yes }
+ { ChangeHttpCode = yes },
+ { error(CloseErrorMsg) }
;
{ Result = ok },
{ Response1 = Response0 },
{ HttpCode1 = HttpCode0 },
{ ChangeHttpCode = no }
),
-
(
{ ChangeHttpCode = yes }
->
@@ -226,25 +172,29 @@
{ Response = Response0 },
{ HttpCode = HttpCode0 }
)
+*/
+ { Response = Response0 },
+ { HttpCode = HttpCode0 }
).
%-----------------------------------------------------------------------%
% Hello
%-----------------------------------------------------------------------%
-:- pred call_Hello_pred(handle, web_method_request, maybe(string), http_code,
- io__state, io__state).
-:- mode call_Hello_pred(in, in, out, out, di, uo) is det.
-
-call_Hello_pred(Handle, _Request, Response, HttpCode) -->
- { HelloProc = mercury_proc(predicate, unqualified(soap_library_file),
- "hello", 2, 0) },
+:- pred call_Hello_pred(handle, string, web_method_request, maybe(string),
+ http_code, io__state, io__state).
+:- mode call_Hello_pred(in, in, in, out, out, di, uo) is det.
+
+call_Hello_pred(Handle, Filename, _Request, Response, HttpCode) -->
+ { HelloProc = mercury_proc(predicate, unqualified(Filename),
+ "hello", 1, 0) },
dl__mercury_sym(Handle, HelloProc, MaybeHello),
(
{ MaybeHello = error(Msg) },
{ string__append("dlsym failed: ", Msg, ErrorMsg) },
- { Response = yes(ErrorMsg) },
- { HttpCode = 500 }
+ { Response = no },
+ { HttpCode = 500 },
+ { error(ErrorMsg) }
;
{ MaybeHello = ok(HelloPred0) },
@@ -254,9 +204,10 @@
% Call the procedure whose address
% we just obtained.
- HelloPred,
+ { HelloPred(HelloUniv) },
+ { det_univ_to_type(HelloUniv, HelloString) },
- { Response = yes("<output>Hello World</output>") },
+ { Response = yes(HelloString) },
{ HttpCode = 200 }
).
@@ -265,39 +216,44 @@
% `hello' procedure is `pred(di, uo) is det', before we can actually
% call it. The function inst_cast_hello/1 defined below does that.
-:- type io_pred == pred(io__state, io__state).
-:- inst io_pred == (pred(di, uo) is det).
+:- type hello_pred == pred(univ).
+:- inst hello_pred == (pred(out) is det).
-:- func inst_cast_hello(io_pred) = io_pred.
-:- mode inst_cast_hello(in) = out(io_pred) is det.
-:- pragma c_code(inst_cast_hello(X::in) = (Y::out(io_pred)),
+:- func inst_cast_hello(hello_pred) = hello_pred.
+:- mode inst_cast_hello(in) = out(hello_pred) is det.
+:- pragma c_code(inst_cast_hello(X::in) = (Y::out(hello_pred)),
[will_not_call_mercury, thread_safe], "Y = X").
%-----------------------------------------------------------------------%
% GetStockPrice
%-----------------------------------------------------------------------%
-:- pred call_SP_func(handle, web_method_request, maybe(string), http_code,
- io__state, io__state).
-:- mode call_SP_func(in, in, out, out, di, uo) is det.
+:- pred call_SP_func(handle, string, web_method_request, maybe(string),
+ http_code, io__state, io__state).
+:- mode call_SP_func(in, in, in, out, out, di, uo) is det.
+
+ % XXX error occurs for function but not for predicate
+ % Uncaught exception:
+ % Software Error: dl__mercury_sym:
+ % result type is not a higher-order type
-call_SP_func(Handle, Request, Response, HttpCode) -->
- { list__length(Request^params, Arity) },
-
+call_SP_func(Handle, Filename, Request, Response, HttpCode) -->
% XXX test for function
- % { GetSPProc = mercury_proc(function, unqualified(soap_library_file),
+ % { list__length(Request^params, Arity) },
+ % { GetSPProc = mercury_proc(function, unqualified(Filename),
% "get_stockprice", Arity, 0) },
% XXX test for predicate
- { GetSPProc = mercury_proc(predicate, unqualified(soap_library_file),
+ { GetSPProc = mercury_proc(predicate, unqualified(Filename),
"get_sp", 2, 0) },
dl__mercury_sym(Handle, GetSPProc, MaybeGetStockPrice),
(
{ MaybeGetStockPrice = error(Msg) },
{ string__append("dlsym failed: ", Msg, ErrorMsg) },
- { Response = yes(ErrorMsg) },
- { HttpCode = 500 }
+ { Response = no },
+ { HttpCode = 500 },
+ { error(ErrorMsg) }
;
{ MaybeGetStockPrice = ok(SPProc0) },
@@ -308,10 +264,6 @@
% XXX test for function
% { wrapper(SPFunc) = inst_cast_stockprice(SPProc0) },
- % message is parsed bottom up, therefore parameter
- % list is in reverse order
- % { list__reverse(Request^params, ParameterList) },
-
% Convert parameters (string) to the corresponding types
{ list__map(lookup_SP_schema, Request^params, UnivList) },
@@ -424,19 +376,20 @@
% schema for GetBookPrice:
%
% <element name="book" type="tns:book"/>
+ % <element name="author" base="tns:author"/>
+ %
% <complexType name="book">
% <sequence>
- % <element name="title" type="mercury:string"/>
+ % <element name="title" type="xsd:string"/>
% <element name="author" type="tns:author"/>
- % <element name="intro" type="mercury:string"/>
+ % <element name="intro" type="xsd:string"/>
% </sequence>
% </complexType>
%
- % <element name="author" base="tns:author"/>
% <complexType name="author">
% <sequence>
- % <element name"surname" type="mercury:string"/>
- % <element name"firstname" type="mercury:string"/>
+ % <element name"surname" type="xsd:string"/>
+ % <element name"firstname" type="xsd:string"/>
% </sequence>
% </complexType>
%
@@ -448,28 +401,27 @@
% author :: author,
% intro :: string
% ).
- %
+ %
% :- type author
% ---> author(
% surname :: string,
% firstname :: string
% ).
-:- pred call_BP_pred(handle, web_method_request, maybe(string), http_code,
- io__state, io__state).
-:- mode call_BP_pred(in, in, out, out, di, uo) is det.
-
-call_BP_pred(Handle, Request, Response, HttpCode) -->
- { list__length(Request^params, Arity0) },
- { Arity = Arity0 + 1 }, % since it is a predicate
- { GetBPProc = mercury_proc(predicate, unqualified(soap_library_file),
- "get_bookprice", Arity, 0) },
+:- pred call_BP_pred(handle, string, web_method_request, maybe(string),
+ http_code, io__state, io__state).
+:- mode call_BP_pred(in, in, in, out, out, di, uo) is det.
+
+call_BP_pred(Handle, Filename, Request, Response, HttpCode) -->
+ { GetBPProc = mercury_proc(predicate, unqualified(Filename),
+ "get_bookprice", 2, 0) },
dl__mercury_sym(Handle, GetBPProc, MaybeGetBookPrice),
(
{ MaybeGetBookPrice = error(Msg) },
{ string__append("dlsym failed: ", Msg, ErrorMsg) },
- { Response = yes(ErrorMsg) },
- { HttpCode = 500 }
+ { Response = no },
+ { HttpCode = 500 },
+ { error(ErrorMsg) }
;
{ MaybeGetBookPrice = ok(BPProc0) },
@@ -478,11 +430,11 @@
{ BPProc = inst_cast_bp(BPProc0) },
% Convert parameters (string) to the corresponding types
- % { list__map(lookup_BP_schema, Request^params, UnivList) },
-
+ { list__map(lookup_BP_schema, Request^params, UnivList) },
+
% Call the procedure whose address we just obtained
- { UnivList = [univ(1)] },
{ call(BPProc, UnivList, BPUniv) },
+
{ det_univ_to_type(BPUniv, BPInt) },
{ string__int_to_string(BPInt, BPString) },
@@ -493,64 +445,75 @@
).
-/* still working
-
-:- pred searchBPList(list(parameter), string, maybe(list(parameter)),
- maybe(string)).
-:- mode searchBPList(in, in, out, out) is semidet.
-
-searchBPList(ParamList, ElemName, Struct, Value) :-
- Elem = parameter(ElemName, _, _, _, _),
- (
- list__nth_member_search(ParamList, Elem, Pos),
- list__index1(ParamList, Pos, Param)
- ->
- Struct = Param^pFields,
- Value = Param^pValue
- ;
- fail
- ).
-
:- pred lookup_BP_schema(parameter::in, univ::out) is det.
lookup_BP_schema(Param, ValueAsUniv) :-
(
Param^pName = "book",
- Param^pFields = yes(StructList),
- (
- searchBPList(StructList, "title", Child, Value0),
- Child = no,
- Value0 = yes(Value)
- ->
- type_cast_parameter("string", Value, ValueAsUniv)
- ;
- searchBPList(StructList, "author", Child, _),
- Child = yes(ChildStructList)
- ->
- (
- searchBPList(ChildStructList, "author", _, _ )
- ;
- require__error(
- "Element Structure not defined in schema.")
+ Param^pFields = yes(FieldList)
+ ->
+ get_BP_param(FieldList, "title", Title0),
+ lookup_BP_schema(Title0, TitleAsUniv),
+ det_univ_to_type(TitleAsUniv, Title),
+
+ get_BP_param(FieldList, "author", Author0),
+ lookup_BP_schema(Author0, AuthorAsUniv),
+ det_univ_to_type(AuthorAsUniv, Author),
+
+ get_BP_param(FieldList, "intro", Intro0),
+ lookup_BP_schema(Intro0, IntroAsUniv),
+ det_univ_to_type(IntroAsUniv, Intro),
- )
- ;
- searchBPList(StructList, "intro", Child, Value0),
- Child = no,
- Value0 = yes(Value)
- ->
- type_cast_parameter("string", Value, ValueAsUniv)
- ;
- require__error(
- "Element Structure not defined in schema.")
- )
+ ValueAsBook = book(Title, Author, Intro),
+ ValueAsUniv = univ(ValueAsBook)
+ ;
+ Param^pName = "title",
+ Param^pValue = yes(Value)
+ ->
+ type_cast_parameter("string", Value, ValueAsUniv)
;
+ Param^pName = "author",
+ Param^pFields = yes(FieldList)
+ ->
+ get_BP_param(FieldList, "surname", Surname0),
+ lookup_BP_schema(Surname0, SurnameAsUniv),
+ det_univ_to_type(SurnameAsUniv, Surname),
+
+ get_BP_param(FieldList, "firstname", Firstname0),
+ lookup_BP_schema(Firstname0, FirstnameAsUniv),
+ det_univ_to_type(FirstnameAsUniv, Firstname),
+
+ ValueAsAuthor = author(Surname, Firstname),
+ ValueAsUniv = univ(ValueAsAuthor)
+ ;
+ Param^pName = "surname",
+ Param^pValue = yes(Value)
+ ->
+ type_cast_parameter("string", Value, ValueAsUniv)
+ ;
+ Param^pName = "firstname",
+ Param^pValue = yes(Value)
+ ->
+ type_cast_parameter("string", Value, ValueAsUniv)
+ ;
+ Param^pName = "intro",
+ Param^pValue = yes(Value)
+ ->
+ type_cast_parameter("string", Value, ValueAsUniv)
+ ;
require__error("Element Structure not defined in schema.")
).
-*/
+:- pred get_BP_param(list(parameter)::in, string::in, parameter::out) is det.
+
+get_BP_param(ParamList, SearchString, Parameter) :-
+ list__filter((pred(X::in) is semidet :-
+ X = parameter(SearchString,_,_,_,_)), ParamList, Result),
+ list__index1_det(Result, 1, Parameter).
+
% inst cast for get_bookprice
:- type bp_pred == pred(list(univ), univ).
+% :- type bp_pred == pred(book, univ).
:- inst bp_pred == (pred(in, out) is det).
:- func inst_cast_bp(bp_pred) = bp_pred.
@@ -561,6 +524,14 @@
%-----------------------------------------------------------------------%
% Shared functions
%-----------------------------------------------------------------------%
+
+ % Returns filename from ./libfilename.so
+:- pred get_filename(string::in, string::out) is det.
+
+get_filename(LibFile, Filename) :-
+ string__split(LibFile, 5, _Left, Filename0),
+ string__length(Filename0, Length),
+ string__left(Filename0, Length-3, Filename).
% Separates prefix and suffix.
:- pred split_on_colon(string::in, string::out, string::out) is det.
|
|
From: Peter R. <pet...@mi...> - 2001-02-01 10:33:50
|
On Thu, Feb 01, 2001 at 12:32:46PM +1100, Ina Cheng wrote:
>
> Hi,
>
> I've added an example to handle the soap message if the body is a
> structure. I want to commit the example so that I can concentrate on working
> on the client side afterwards.
>
> Ina
> <in...@st...>
>
> ========================================================================
>
> Estimated hours taken: 20
>
> Add example to handle mercury structure. Also fixup some error handling.
>
> /server/server.m
> change the header to request a library filename to be loaded for dl
> add predicates to check request header
>
> /server/soap.m
> tidy up the code
>
> /server/soap_test_methods.m
> /server/web_methods.m
> add example to handle mercury structure
>
> ========================================================================
>
> Index: server.m
> ===================================================================
> RCS file: /cvsroot/quicksilver/webserver/server/server.m,v
> retrieving revision 1.5
> diff -u -r1.5 server.m
> --- server.m 2001/01/25 06:54:42 1.5
> +++ server.m 2001/02/01 01:30:22
> @@ -1,5 +1,5 @@
> %---------------------------------------------------------------------------%
> -% Copyright (C) 2000 Peter Ross
> +% Copyright (C) 2000, 2001 Peter Ross
> % This file may only be copied under the terms of the GNU General Public
> % License - see the file COPYING
> %-----------------------------------------------------------------------------%
> @@ -82,7 +82,16 @@
> { RequestOrResponse = left(Request) },
> (
> { Request^cmd = post },
> - get_soapmessage(TCP, Request, Request1)
> + { check_headers(Request^headers, MayBeError) },
> + (
> + { MayBeError = yes(ErrorResponse) }
> + ->
> + send_response(TCP, ErrorResponse),
> + tcp__shutdown(TCP),
> + { error("Invalid HTTP headers in request.\n") }
> + ;
> + get_soapmessage(TCP, Request, Request1)
> + )
s/MayBe/Maybe/g
> ;
> { Request^cmd = get },
> { Request1 = Request }
> @@ -226,6 +235,67 @@
>
> %---------------------------------------------------------------------------%
>
> + % Section 6 Using SOAP in HTTP
> + % " HTTP applications MUST use the media type "text/xml"
> + % according to RFC 2376 when including SOAP entity bodies
> + % in HTTP messages.
> + %
> + % Section 6.1.1. The SOAPAction HTTP Header Field
> + % " An HTTP client MUST use this header field when issuing a
> + % SOAP HTTP Request. "
> +
> +
> +:- pred check_headers(list(header)::in, maybe(response)::out) is det.
> +
> +check_headers(Headers, Response) :-
> + check_each_header(Headers, soapaction_header,
> + "SOAPAction header not found.\n", MayBeResponse0),
> + (
> + MayBeResponse0 = no
> + ->
> + check_each_header(Headers, content_type_header,
> + "Incorrect Content-Type value.\n", MayBeResponse1),
> + (
> + MayBeResponse1 = no
> + ->
> + Response = no
> + ;
> + Response = MayBeResponse1
> + )
> + ;
> + Response = MayBeResponse0
> + ).
> +
> +:- pred check_each_header(list(header), pred(header), string, maybe(response)).
> +:- mode check_each_header(in, pred(in) is semidet, in, out) is det.
> +
> +check_each_header(Headers, Pred, ErrorMessage, Response) :-
> + list__filter(Pred, Headers, Result),
> + (
> + Result \= []
> + ->
> + Response = no
> + ;
> + Response = yes(response(
> + 400,
> + [],
> + string_body(ErrorMessage),
> + yes )
> + )
> +
> + ).
What about if a header occurs twice? Shouldn't happen, but you never know.
> +
> +:- pred soapaction_header(header::in) is semidet.
> +soapaction_header(header("SOAPAction:", _, _)).
> +
> +:- pred content_type_header(header::in) is semidet.
> +content_type_header(header("Content-Type:", "text/xml", _)).
> +content_type_header(header("Content-type:", "text/xml", _)).
> +content_type_header(header("Content-Type:", "text/xml;", _)).
> +content_type_header(header("Content-type:", "text/xml;", _)).
> +
> +%---------------------------------------------------------------------------%
> +
> :- pred get_soapmessage(S, request, request, io__state, io__state)
> <= stream__duplex(S).
> :- mode get_soapmessage(in, in, out, di, uo) is det.
> @@ -243,7 +313,17 @@
> yes(string__from_char_list(SoapMessage))
> ) }
> ;
> - { error("No content-length supplied. Program Terminated.") }
> + { ErrorResponse = response(
> + 411,
> + [],
> + string_body("Content-Length not supplied.\n"),
> + yes) },
> + send_response(S, ErrorResponse),
> +
> + % XXX how to convert S back to tcp such that
> + % tcp__shutdown(S) can be called ?
> +
> + { error("Content-Length not supplied in request.") }
> ).
>
Don't send the response here, but use the either type to return the
request or respone.
(
...
Result = left(Request)
;
...
Result = right(ErrorResponse)
)
This also avoids needing to pass the stream in, or worry about closing
the socket after use.
> :- pred get_content_length(list(header)::in, int::out) is semidet.
> @@ -268,13 +348,12 @@
> is_content_type("Content-type:").
>
> :- pred get_body(S, int, list(char), io__state, io__state)
> - <= stream__duplex(S).
> + <= stream__input(S).
> :- mode get_body(in, in, out, di, uo) is det.
>
> -% XXX if there are still characters when length = 0
> -% the rest will not be obtained and consequently parsing
> -% an incomplete message will throw an exception.
> -
> + % If there are still characters when length = 0,
> + % the rest will not be obtained and consequently parsing
> + % an incomplete message will throw an exception.
> get_body(S, Length, RequestLines) -->
> stream__read_char(S, CharResult),
> { Length0 = Length - 1 },
> @@ -334,9 +413,14 @@
> )
> ;
> { Request^cmd = post },
> + write(uri_to_filename(Request^uri)), nl,
> (
> { Request^body = yes(Body) } ,
> parse_soapmessage(Body, NsBody),
> +
> + % parse_soapmessage calls error/1 when failed
> + % should change to response with http code = 415
> +
This should be an XXX.
> write(NsBody), nl, nl,
>
> { get_procedure_call(NsBody, Proc) },
> @@ -345,12 +429,12 @@
> { make_web_request(NsBody, Proc, WebRequest) },
> write(WebRequest), nl, nl,
>
> - load_dynamic_library("./libsoap_test_methods.so",
> + load_dynamic_library(uri_to_filename(Request^uri),
> WebRequest, Result, HttpCode),
> (
> - { Result = yes(Output) },
> + { Result = yes(OutputString) },
> { generate_response_body(NsBody, Proc,
> - Output, ResBody0) },
> + OutputString, ResBody0) },
> { ResBody = string_body(ResBody0) }
> ;
> { Result = no },
> @@ -363,7 +447,7 @@
> { ResBody = no_body },
> { HttpCode = 400 }
> ),
> - { list__filter(filter, Request^headers, Headers) },
> + { generate_headers(Request^headers, ResBody, Headers) },
> { Response = response(HttpCode, Headers,
> ResBody, yes) }
> ).
> @@ -380,9 +464,24 @@
> last_char(Str)
> = string__unsafe_index(Str, string__length(Str) - 1).
>
> +:- pred generate_headers(list(header)::in, response_body::in,
> + list(header)::out) is det.
> +generate_headers(RequestHeaders, ResBody, Headers) :-
> + list__filter(filter, RequestHeaders, Headers0),
> + (
> + ResBody = string_body(Body),
> + string__length(Body, BodyLength),
> + string__int_to_string(BodyLength, StringLength),
> + ConLen = [header("Content-Length:", StringLength, no)],
> + list__append(ConLen, Headers0, Headers)
> + ;
> + ResBody = no_body,
> + Headers = []
> + ).
> +
> :- pred filter(header::in) is semidet.
> -filter(header("Content-Length:", _, _)).
> filter(header("Content-Type:", _, _)).
> +filter(header("Content-type:", _, _)).
>
I don't think filter is a very good name. is_content_type_header would
be better.
> %-----------------------------------------------------------------------------%
>
> Index: soap.m
> ===================================================================
> RCS file: /cvsroot/quicksilver/webserver/server/soap.m,v
> retrieving revision 1.1
> diff -u -r1.1 soap.m
> --- soap.m 2001/01/25 06:54:42 1.1
> +++ soap.m 2001/02/01 01:30:22
> @@ -78,6 +78,9 @@
> { Res = ok((_, Doc)) },
> { nsTranslate(Doc, NsDoc) }
> ;
> + % instead of error, should change to response
> + % with http code 415 Unsupported Media Type
> +
Make this an XXX.
> { Res = error(Err) },
> { string__append("parse_soapmessage failed: ", Err, ErrMsg) },
> { error(ErrMsg) }
> @@ -130,13 +133,8 @@
> % Gets method name.
> get_procedure_call(NsDoc, Procedure) :-
> get_procedure(NsDoc, [], Procedurelist),
> - get_first_element(Procedurelist, Procedure).
> -
> -:- pred get_first_element(list(T)::in, T::out) is det.
> + list__index1_det(Procedurelist, 1, Procedure).
>
> -get_first_element([], _) :- error("Procedure not found.").
> -get_first_element([H|_], H).
> -
> :- pred get_procedure(nsDocument, list(nsElement), list(nsElement)).
> :- mode get_procedure(in, in, out) is det.
> get_procedure(NsDoc, Acc0, Acc) :-
> @@ -411,10 +409,6 @@
> Acc0, Acc1),
> call(Pred, ContentArray, Ref, Method, Result, URIs,
> Acc1, Acc).
> -
> -% :- pred insert_last(list(T)::in, T::in, list(T)::out) is det.
> -% insert_last([], T, [T]).
> -% insert_last([
>
> :- pred my_delete(list(T)::in, list(T)::out) is det.
> my_delete([], []).
Generally speaking it is much better to do these sort of clean up
changes as a seperate change.
The reason is: if we need to back your changes out we don't want to lose
any unrelated changes at the same time because then we have to reproduce
them.
> Index: soap_test_methods.m
> ===================================================================
> RCS file: /cvsroot/quicksilver/webserver/server/soap_test_methods.m,v
> retrieving revision 1.1
> diff -u -r1.1 soap_test_methods.m
> --- soap_test_methods.m 2001/01/25 06:54:42 1.1
> +++ soap_test_methods.m 2001/02/01 01:30:22
> @@ -21,20 +21,34 @@
>
> :- module soap_test_methods.
> :- interface.
> -:- import_module io, int, list, std_util.
> +:- import_module list, std_util.
>
> -:- pred hello(state::di, state::uo) is det.
> +:- pred hello(univ::out) is det.
>
> :- pred get_sp(list(univ)::in, univ::out) is det.
>
> :- func get_stockprice(list(univ)) = univ.
>
> +% :- pred get_bookprice(book::in, univ::out) is det.
> :- pred get_bookprice(list(univ)::in, univ::out) is det.
>
> +:- type book
> + ---> book(
> + title :: string,
> + author :: author,
> + intro :: string
> + ).
> +
I am not sure if this is an artifact of my mailer or not but line up
the closing bracket of book with the first letter of the functor. ie.
:- type book
---> book(
...
). % XXX this bracket should line up.
> +:- type author
> + ---> author(
> + surname :: string,
> + firstname :: string
> + ).
> +
> %---------------------------------------------------------------------%
>
> :- implementation.
> -:- import_module require.
> +:- import_module int, require.
>
> % remove_first_element(List, Elem, Rest)
> % takes out first element of the List and gives back
> @@ -51,7 +65,8 @@
> % Hello
> %---------------------------------------------------------------------%
>
> -hello --> print("Hello, world\n").
> +hello(ResultAsUniv) :-
> + ResultAsUniv = univ("<output>Hello, world</output>").
>
> %---------------------------------------------------------------------%
> % GetStockPrice
> @@ -78,7 +93,7 @@
> remove_first_element(ParamList, ParamAsUniv, _)
> ->
> det_univ_to_type(ParamAsUniv, ParamAsInt),
> - ResultAsInt = ParamAsInt + 1,
> + ResultAsInt = ParamAsInt + 0,
> ResultAsUniv = univ(ResultAsInt)
> ;
> require__error("Error in get_stockprice")
> @@ -87,8 +102,22 @@
> %---------------------------------------------------------------------%
> % GetBookPrice
> %---------------------------------------------------------------------%
> -
> -get_bookprice(ParamList, ResultAsUniv) :-
> - ResultAsUniv = univ(100).
>
> +get_bookprice(ParamList, ResultAsUniv) :-
> + list__index1_det(ParamList, 1, ParamAsUniv),
> + Param0 = univ_value(ParamAsUniv),
> + Param = inst_cast_book(Param0),
> + (
> + Param = book("Hello world",
> + author("Foo", "Bar"),
> + "This is a book")
> + ->
> + ResultAsUniv = univ(100)
> + ;
> + ResultAsUniv = univ(50)
> + ).
>
> +:- func inst_cast_book(T) = book.
> +:- mode inst_cast_book(in) = out is det.
> +:- pragma c_code(inst_cast_book(X::in) = (Y::out),
> + [will_not_call_mercury, thread_safe], "Y = X").
> Index: web_methods.m
> ===================================================================
> RCS file: /cvsroot/quicksilver/webserver/server/web_methods.m,v
> retrieving revision 1.1
> diff -u -r1.1 web_methods.m
> --- web_methods.m 2001/01/25 06:54:42 1.1
> +++ web_methods.m 2001/02/01 01:30:22
> @@ -42,14 +42,7 @@
> pFields :: maybe(list(parameter))
> % Struct or Array
> ).
> -/* Ignore this
>
> - % Converts method name and parameters in xml.ns format to
> - % a web request.
> -:- pred make_web_request(nsElement, list(parameter), web_method_request).
> -:- mode make_web_request(in, in, out) is det.
> -*/
> -
> % Loads library, invokes method call and generates corresponding
> % response.
> :- pred load_dynamic_library(string::in, web_method_request::in,
> @@ -63,71 +56,11 @@
> :- implementation.
> :- import_module bool, int, require.
> :- import_module dl, name_mangle, soap_test_methods.
> -
> - % XXX change that to command line argument
> -:- func soap_library_file = string.
> -soap_library_file = "soap_test_methods".
> -
> -/* Ignore this. Not used anymore
> -
> - % Generates a web request using method and parameters
> -make_web_request(Proc, Params, Request) :-
> - Request^name = Proc^eName^localName,
> - Request^uri = Proc^eName^nsURI,
> - Request^params = Params.
> -
> -make_web_request(Proc, Params, Request) :-
> - Request^name = Proc^eName^localName,
> - Request^uri = Proc^eName^nsURI,
> - form_pair(Params, ParamsPair),
> - list__map(retrieve_params, ParamsPair, Request^params).
> -
> - % Transform parameter list from [parameter, data, parameter, data ..]
> - % to [(parameter - data)] to distinguish elements
> -:- pred form_pair(list(nsContent), list(pair(nsContent, nsContent))).
> -:- mode form_pair(in, out) is det.
> -
> -form_pair(ParamList , PairList) :-
> - (
> - ParamList = []
> - ->
> - PairList = []
> - ;
> - ParamList = [Param, Data | Tail]
> - % list__split_list(2, ParamList, Start, End),
> - % Start = [Param, Data]
> - ->
> - PairList = [(Param - Data) | PairList0],
> - form_pair(Tail, PairList0)
> - ;
> - error("Incorrect Data Format")
> - ).
>
> +% :- func soap_library_file = string.
> +% soap_library_file = "soap_test_methods".
>
> - % Retrieve parameter name, uri, type if defined and data value.
> -:- pred retrieve_params(pair(nsContent, nsContent), parameter).
> -:- mode retrieve_params(in, out) is det.
>
> -retrieve_params((Param0 - Data), Parameter) :-
> - (
> - Param0 = nsElement(Param),
> - Data = data(Value)
> - ->
> - Name = Param^eName^localName,
> - URI = Param^eName^nsURI,
> - (
> - search_attributes(Param^eAttrs, Type0)
> - ->
> - Type = yes(Type0)
> - ;
> - Type = no
> - ),
> - Parameter = parameter(Name, Type, Value, URI)
> - ;
> - error("Incorrect Data Format")
> - ).
> -*/
> -
> % Types in XML can be defined either by using xsi:type attribute
> % or by using schema. This predicate is used to search if
> % any attribute contains `xsi:type'.
> @@ -172,51 +105,64 @@
>
> % Opens library file, invokes desire function, and gets back
> % corresponding response and http code.
> -load_dynamic_library(L, Request, Response, HttpCode) -->
> - dl__open(L, lazy, local, MaybeHandle),
> + %
> + % LibFile format = "./libfilename.so"
> + %
> +load_dynamic_library(LibFile, Request, Response, HttpCode) -->
> + dl__open(LibFile, lazy, local, MaybeHandle),
> + { get_filename(LibFile, Filename) },
> (
> { MaybeHandle = error(OpenMsg) },
> { string__append("dlopen failed: ", OpenMsg, OpenErrorMsg) },
> - { Response = yes(OpenErrorMsg) },
> - { HttpCode = 500 } % 500 Internal Server Error
> + { Response = no },
> + { HttpCode = 500 }, % 500 Internal Server Error
> + { error(OpenErrorMsg) }
Why do you call error now, instead of passing the error message back?
> ;
> { MaybeHandle = ok(Handle) },
> (
> % Hello has no parameter
> { Request^name = "Hello" }
> ->
> - call_Hello_pred(Handle, Request, Response0, HttpCode0)
> + call_Hello_pred(Handle, Filename, Request,
> + Response0, HttpCode0)
> ;
> % GetStockPrice has 1 parameter
> { Request^name = "GetStockPrice" }
> ->
> - call_SP_func(Handle, Request, Response0, HttpCode0)
> + call_SP_func(Handle, Filename, Request,
> + Response0, HttpCode0)
> ;
> % GetBookPrice takes in a struct
> { Request^name = "GetBookPrice" }
> ->
> - call_BP_pred(Handle, Request, Response0, HttpCode0)
> + call_BP_pred(Handle, Filename, Request,
> + Response0, HttpCode0)
> ;
> { Response0 = yes("Method requested not
> implemented.") },
> { HttpCode0 = 501 } % 501 Not Implemented
> ),
>
> +/* commented out dl__close/4 so that the .so can be referred to it
> + when generating responses. If the .so file is closed, any pointers
> + referencing the .so file will become unavailable, causing
> + runtime error: segmentation violation.
> +
> dl__close(Handle, Result),
> (
> { Result = error(CloseMsg) },
> { string__append("dlclose failed: ", CloseMsg,
> CloseErrorMsg) },
> - { Response1 = yes(CloseErrorMsg) },
> + { Response1 = no },
> { HttpCode1 = 500 },
> - { ChangeHttpCode = yes }
> + { ChangeHttpCode = yes },
> + { error(CloseErrorMsg) }
> ;
> { Result = ok },
> { Response1 = Response0 },
> { HttpCode1 = HttpCode0 },
> { ChangeHttpCode = no }
> ),
> -
> (
> { ChangeHttpCode = yes }
> ->
> @@ -226,25 +172,29 @@
> { Response = Response0 },
> { HttpCode = HttpCode0 }
> )
> +*/
> + { Response = Response0 },
> + { HttpCode = HttpCode0 }
> ).
>
> %-----------------------------------------------------------------------%
> % Hello
> %-----------------------------------------------------------------------%
>
> -:- pred call_Hello_pred(handle, web_method_request, maybe(string), http_code,
> - io__state, io__state).
> -:- mode call_Hello_pred(in, in, out, out, di, uo) is det.
> -
> -call_Hello_pred(Handle, _Request, Response, HttpCode) -->
> - { HelloProc = mercury_proc(predicate, unqualified(soap_library_file),
> - "hello", 2, 0) },
> +:- pred call_Hello_pred(handle, string, web_method_request, maybe(string),
> + http_code, io__state, io__state).
> +:- mode call_Hello_pred(in, in, in, out, out, di, uo) is det.
> +
> +call_Hello_pred(Handle, Filename, _Request, Response, HttpCode) -->
> + { HelloProc = mercury_proc(predicate, unqualified(Filename),
> + "hello", 1, 0) },
> dl__mercury_sym(Handle, HelloProc, MaybeHello),
> (
> { MaybeHello = error(Msg) },
> { string__append("dlsym failed: ", Msg, ErrorMsg) },
> - { Response = yes(ErrorMsg) },
> - { HttpCode = 500 }
> + { Response = no },
> + { HttpCode = 500 },
> + { error(ErrorMsg) }
> ;
> { MaybeHello = ok(HelloPred0) },
>
> @@ -254,9 +204,10 @@
>
> % Call the procedure whose address
> % we just obtained.
> - HelloPred,
> + { HelloPred(HelloUniv) },
> + { det_univ_to_type(HelloUniv, HelloString) },
>
> - { Response = yes("<output>Hello World</output>") },
> + { Response = yes(HelloString) },
> { HttpCode = 200 }
> ).
>
> @@ -265,39 +216,44 @@
> % `hello' procedure is `pred(di, uo) is det', before we can actually
> % call it. The function inst_cast_hello/1 defined below does that.
>
> -:- type io_pred == pred(io__state, io__state).
> -:- inst io_pred == (pred(di, uo) is det).
> +:- type hello_pred == pred(univ).
> +:- inst hello_pred == (pred(out) is det).
>
> -:- func inst_cast_hello(io_pred) = io_pred.
> -:- mode inst_cast_hello(in) = out(io_pred) is det.
> -:- pragma c_code(inst_cast_hello(X::in) = (Y::out(io_pred)),
> +:- func inst_cast_hello(hello_pred) = hello_pred.
> +:- mode inst_cast_hello(in) = out(hello_pred) is det.
> +:- pragma c_code(inst_cast_hello(X::in) = (Y::out(hello_pred)),
> [will_not_call_mercury, thread_safe], "Y = X").
>
> %-----------------------------------------------------------------------%
> % GetStockPrice
> %-----------------------------------------------------------------------%
>
> -:- pred call_SP_func(handle, web_method_request, maybe(string), http_code,
> - io__state, io__state).
> -:- mode call_SP_func(in, in, out, out, di, uo) is det.
> +:- pred call_SP_func(handle, string, web_method_request, maybe(string),
> + http_code, io__state, io__state).
> +:- mode call_SP_func(in, in, in, out, out, di, uo) is det.
> +
> + % XXX error occurs for function but not for predicate
> + % Uncaught exception:
> + % Software Error: dl__mercury_sym:
> + % result type is not a higher-order type
>
> -call_SP_func(Handle, Request, Response, HttpCode) -->
> - { list__length(Request^params, Arity) },
> -
> +call_SP_func(Handle, Filename, Request, Response, HttpCode) -->
> % XXX test for function
> - % { GetSPProc = mercury_proc(function, unqualified(soap_library_file),
> + % { list__length(Request^params, Arity) },
> + % { GetSPProc = mercury_proc(function, unqualified(Filename),
> % "get_stockprice", Arity, 0) },
>
> % XXX test for predicate
> - { GetSPProc = mercury_proc(predicate, unqualified(soap_library_file),
> + { GetSPProc = mercury_proc(predicate, unqualified(Filename),
> "get_sp", 2, 0) },
>
> dl__mercury_sym(Handle, GetSPProc, MaybeGetStockPrice),
> (
> { MaybeGetStockPrice = error(Msg) },
> { string__append("dlsym failed: ", Msg, ErrorMsg) },
> - { Response = yes(ErrorMsg) },
> - { HttpCode = 500 }
> + { Response = no },
> + { HttpCode = 500 },
> + { error(ErrorMsg) }
ditto.
> ;
> { MaybeGetStockPrice = ok(SPProc0) },
>
> @@ -308,10 +264,6 @@
> % XXX test for function
> % { wrapper(SPFunc) = inst_cast_stockprice(SPProc0) },
>
> - % message is parsed bottom up, therefore parameter
> - % list is in reverse order
> - % { list__reverse(Request^params, ParameterList) },
> -
> % Convert parameters (string) to the corresponding types
> { list__map(lookup_SP_schema, Request^params, UnivList) },
>
> @@ -424,19 +376,20 @@
> % schema for GetBookPrice:
> %
> % <element name="book" type="tns:book"/>
> + % <element name="author" base="tns:author"/>
> + %
> % <complexType name="book">
> % <sequence>
> - % <element name="title" type="mercury:string"/>
> + % <element name="title" type="xsd:string"/>
> % <element name="author" type="tns:author"/>
> - % <element name="intro" type="mercury:string"/>
> + % <element name="intro" type="xsd:string"/>
> % </sequence>
> % </complexType>
> %
> - % <element name="author" base="tns:author"/>
> % <complexType name="author">
> % <sequence>
> - % <element name"surname" type="mercury:string"/>
> - % <element name"firstname" type="mercury:string"/>
> + % <element name"surname" type="xsd:string"/>
> + % <element name"firstname" type="xsd:string"/>
> % </sequence>
> % </complexType>
> %
> @@ -448,28 +401,27 @@
> % author :: author,
> % intro :: string
> % ).
> - %
> + %
> % :- type author
> % ---> author(
> % surname :: string,
> % firstname :: string
> % ).
>
> -:- pred call_BP_pred(handle, web_method_request, maybe(string), http_code,
> - io__state, io__state).
> -:- mode call_BP_pred(in, in, out, out, di, uo) is det.
> -
> -call_BP_pred(Handle, Request, Response, HttpCode) -->
> - { list__length(Request^params, Arity0) },
> - { Arity = Arity0 + 1 }, % since it is a predicate
> - { GetBPProc = mercury_proc(predicate, unqualified(soap_library_file),
> - "get_bookprice", Arity, 0) },
> +:- pred call_BP_pred(handle, string, web_method_request, maybe(string),
> + http_code, io__state, io__state).
> +:- mode call_BP_pred(in, in, in, out, out, di, uo) is det.
> +
> +call_BP_pred(Handle, Filename, Request, Response, HttpCode) -->
> + { GetBPProc = mercury_proc(predicate, unqualified(Filename),
> + "get_bookprice", 2, 0) },
> dl__mercury_sym(Handle, GetBPProc, MaybeGetBookPrice),
> (
> { MaybeGetBookPrice = error(Msg) },
> { string__append("dlsym failed: ", Msg, ErrorMsg) },
> - { Response = yes(ErrorMsg) },
> - { HttpCode = 500 }
> + { Response = no },
> + { HttpCode = 500 },
> + { error(ErrorMsg) }
> ;
> { MaybeGetBookPrice = ok(BPProc0) },
>
> @@ -478,11 +430,11 @@
> { BPProc = inst_cast_bp(BPProc0) },
>
> % Convert parameters (string) to the corresponding types
> - % { list__map(lookup_BP_schema, Request^params, UnivList) },
> -
> + { list__map(lookup_BP_schema, Request^params, UnivList) },
> +
> % Call the procedure whose address we just obtained
> - { UnivList = [univ(1)] },
> { call(BPProc, UnivList, BPUniv) },
> +
> { det_univ_to_type(BPUniv, BPInt) },
> { string__int_to_string(BPInt, BPString) },
>
> @@ -493,64 +445,75 @@
> ).
>
>
> -/* still working
> -
> -:- pred searchBPList(list(parameter), string, maybe(list(parameter)),
> - maybe(string)).
> -:- mode searchBPList(in, in, out, out) is semidet.
> -
> -searchBPList(ParamList, ElemName, Struct, Value) :-
> - Elem = parameter(ElemName, _, _, _, _),
> - (
> - list__nth_member_search(ParamList, Elem, Pos),
> - list__index1(ParamList, Pos, Param)
> - ->
> - Struct = Param^pFields,
> - Value = Param^pValue
> - ;
> - fail
> - ).
> -
> :- pred lookup_BP_schema(parameter::in, univ::out) is det.
>
> lookup_BP_schema(Param, ValueAsUniv) :-
> (
> Param^pName = "book",
> - Param^pFields = yes(StructList),
> - (
> - searchBPList(StructList, "title", Child, Value0),
> - Child = no,
> - Value0 = yes(Value)
> - ->
> - type_cast_parameter("string", Value, ValueAsUniv)
> - ;
> - searchBPList(StructList, "author", Child, _),
> - Child = yes(ChildStructList)
> - ->
> - (
> - searchBPList(ChildStructList, "author", _, _ )
> - ;
> - require__error(
> - "Element Structure not defined in schema.")
> + Param^pFields = yes(FieldList)
> + ->
> + get_BP_param(FieldList, "title", Title0),
> + lookup_BP_schema(Title0, TitleAsUniv),
> + det_univ_to_type(TitleAsUniv, Title),
> +
> + get_BP_param(FieldList, "author", Author0),
> + lookup_BP_schema(Author0, AuthorAsUniv),
> + det_univ_to_type(AuthorAsUniv, Author),
> +
> + get_BP_param(FieldList, "intro", Intro0),
> + lookup_BP_schema(Intro0, IntroAsUniv),
> + det_univ_to_type(IntroAsUniv, Intro),
>
> - )
> - ;
> - searchBPList(StructList, "intro", Child, Value0),
> - Child = no,
> - Value0 = yes(Value)
> - ->
> - type_cast_parameter("string", Value, ValueAsUniv)
> - ;
> - require__error(
> - "Element Structure not defined in schema.")
> - )
> + ValueAsBook = book(Title, Author, Intro),
> + ValueAsUniv = univ(ValueAsBook)
> + ;
> + Param^pName = "title",
> + Param^pValue = yes(Value)
> + ->
> + type_cast_parameter("string", Value, ValueAsUniv)
> ;
> + Param^pName = "author",
> + Param^pFields = yes(FieldList)
> + ->
> + get_BP_param(FieldList, "surname", Surname0),
> + lookup_BP_schema(Surname0, SurnameAsUniv),
> + det_univ_to_type(SurnameAsUniv, Surname),
> +
> + get_BP_param(FieldList, "firstname", Firstname0),
> + lookup_BP_schema(Firstname0, FirstnameAsUniv),
> + det_univ_to_type(FirstnameAsUniv, Firstname),
> +
> + ValueAsAuthor = author(Surname, Firstname),
> + ValueAsUniv = univ(ValueAsAuthor)
> + ;
> + Param^pName = "surname",
> + Param^pValue = yes(Value)
> + ->
> + type_cast_parameter("string", Value, ValueAsUniv)
> + ;
> + Param^pName = "firstname",
> + Param^pValue = yes(Value)
> + ->
> + type_cast_parameter("string", Value, ValueAsUniv)
> + ;
> + Param^pName = "intro",
> + Param^pValue = yes(Value)
> + ->
> + type_cast_parameter("string", Value, ValueAsUniv)
> + ;
> require__error("Element Structure not defined in schema.")
> ).
> -*/
>
> +:- pred get_BP_param(list(parameter)::in, string::in, parameter::out) is det.
> +
> +get_BP_param(ParamList, SearchString, Parameter) :-
> + list__filter((pred(X::in) is semidet :-
> + X = parameter(SearchString,_,_,_,_)), ParamList, Result),
> + list__index1_det(Result, 1, Parameter).
> +
> % inst cast for get_bookprice
> :- type bp_pred == pred(list(univ), univ).
> +% :- type bp_pred == pred(book, univ).
> :- inst bp_pred == (pred(in, out) is det).
>
> :- func inst_cast_bp(bp_pred) = bp_pred.
> @@ -561,6 +524,14 @@
> %-----------------------------------------------------------------------%
> % Shared functions
> %-----------------------------------------------------------------------%
> +
> + % Returns filename from ./libfilename.so
> +:- pred get_filename(string::in, string::out) is det.
> +
> +get_filename(LibFile, Filename) :-
> + string__split(LibFile, 5, _Left, Filename0),
> + string__length(Filename0, Length),
> + string__left(Filename0, Length-3, Filename).
>
> % Separates prefix and suffix.
> :- pred split_on_colon(string::in, string::out, string::out) is det.
>
>
> _______________________________________________
> Quicksilver-developers mailing list
> Qui...@li...
> http://lists.sourceforge.net/lists/listinfo/quicksilver-developers
|
|
From: Ina C. <in...@st...> - 2001-02-08 04:30:03
|
Hi,
I've addressed Peter's comments and here is the new diff.
If everything looks ok, I would like to commit the changes.
Ina
<in...@st...>
========================================================================
Estimated hours taken: 5
Address Peter's comment for last diff ( the diff for adding example
to handle mercury structure).
/server/server.m
add predicates to check request header.
change the header to request a library filename to be loaded for dl.
/server/soap.m
clean up some code.
(Peter mentioned that I should do this in a separate change,
but I can't remember how to change it back to the original,
sorry, please bear with it now. I'll remember it next time.)
/server/soap_test_methods.m
/server/web_methods.m
add example to handle mercury structure
========================================================================
Index: server.m
===================================================================
RCS file: /cvsroot/quicksilver/webserver/server/server.m,v
retrieving revision 1.5
diff -u -r1.5 server.m
--- server.m 2001/01/25 06:54:42 1.5
+++ server.m 2001/02/08 04:19:06
@@ -1,5 +1,5 @@
%---------------------------------------------------------------------------%
-% Copyright (C) 2000 Peter Ross
+% Copyright (C) 2000, 2001 Peter Ross
% This file may only be copied under the terms of the GNU General Public
% License - see the file COPYING
%-----------------------------------------------------------------------------%
@@ -82,12 +82,29 @@
{ RequestOrResponse = left(Request) },
(
{ Request^cmd = post },
- get_soapmessage(TCP, Request, Request1)
+ { check_headers(Request^headers, MaybeError) },
+ (
+ { MaybeError = yes(ErrorResponse) }
+ ->
+ send_response(TCP, ErrorResponse),
+ tcp__shutdown(TCP),
+ { error("Invalid HTTP headers in request.\n") }
+ ;
+ get_soapmessage(TCP, Request, Request1),
+ (
+ { Request1 = right(ErrorResponse1) },
+ send_response(TCP, ErrorResponse1),
+ tcp__shutdown(TCP),
+ { error("Invalid SOAP body.\n") }
+ ;
+ { Request1 = left(Request2) }
+ )
+ )
;
{ Request^cmd = get },
- { Request1 = Request }
+ { Request2 = Request }
),
- generate_response(Request1, Response)
+ generate_response(Request2, Response)
;
{ RequestOrResponse = right(Response) }
),
@@ -225,25 +242,92 @@
%---------------------------------------------------------------------------%
+
+ % Section 6 Using SOAP in HTTP
+ % " HTTP applications MUST use the media type "text/xml"
+ % according to RFC 2376 when including SOAP entity bodies
+ % in HTTP messages.
+ %
+ % Section 6.1.1. The SOAPAction HTTP Header Field
+ % " An HTTP client MUST use this header field when issuing a
+ % SOAP HTTP Request. "
+
+
+:- pred check_headers(list(header)::in, maybe(response)::out) is det.
+
+check_headers(Headers, Response) :-
+ check_each_header(Headers, soapaction_header,
+ "SOAPAction header not found.\n", MayBeResponse0),
+ (
+ MayBeResponse0 = no
+ ->
+ check_each_header(Headers, content_type_header,
+ "Incorrect Content-Type value.\n", MayBeResponse1),
+ (
+ MayBeResponse1 = no
+ ->
+ Response = no
+ ;
+ Response = MayBeResponse1
+ )
+ ;
+ Response = MayBeResponse0
+ ).
+
+:- pred check_each_header(list(header), pred(header), string, maybe(response)).
+:- mode check_each_header(in, pred(in) is semidet, in, out) is det.
+
+check_each_header(Headers, Pred, ErrorMessage, Response) :-
+ list__filter(Pred, Headers, Result),
+ (
+ Result \= [],
+ list__length(Result, 1) % ensure header only occur once
+ ->
+ Response = no
+ ;
+ Response = yes(response(
+ 400,
+ [],
+ string_body(ErrorMessage),
+ yes )
+ )
+
+ ).
+
+:- pred soapaction_header(header::in) is semidet.
+soapaction_header(header("SOAPAction:", _, _)).
+
+:- pred content_type_header(header::in) is semidet.
+content_type_header(header("Content-Type:", "text/xml", _)).
+content_type_header(header("Content-type:", "text/xml", _)).
+content_type_header(header("Content-Type:", "text/xml;", _)).
+content_type_header(header("Content-type:", "text/xml;", _)).
+
+%---------------------------------------------------------------------------%
-:- pred get_soapmessage(S, request, request, io__state, io__state)
- <= stream__duplex(S).
+:- pred get_soapmessage(S, request, either(request, response),
+ io__state, io__state) <= stream__input(S).
:- mode get_soapmessage(in, in, out, di, uo) is det.
-get_soapmessage(S, Request, Request0) -->
+get_soapmessage(S, Request, RequestOrResponse) -->
(
{ get_content_length(Request^headers, Length) }
->
get_body(S, Length, SoapMessage),
- { Request0 = request(
- Request^cmd,
- Request^uri,
- Request^version,
- Request^headers,
- yes(string__from_char_list(SoapMessage))
- ) }
- ;
- { error("No content-length supplied. Program Terminated.") }
+ { RequestOrResponse = left(request(
+ Request^cmd,
+ Request^uri,
+ Request^version,
+ Request^headers,
+ yes(string__from_char_list(SoapMessage))))
+ }
+ ;
+ { RequestOrResponse = right(response(
+ 411,
+ [],
+ string_body("Content-Length not supplied.\n"),
+ yes))
+ }
).
:- pred get_content_length(list(header)::in, int::out) is semidet.
@@ -268,13 +352,12 @@
is_content_type("Content-type:").
:- pred get_body(S, int, list(char), io__state, io__state)
- <= stream__duplex(S).
+ <= stream__input(S).
:- mode get_body(in, in, out, di, uo) is det.
-
-% XXX if there are still characters when length = 0
-% the rest will not be obtained and consequently parsing
-% an incomplete message will throw an exception.
+ % If there are still characters when length = 0,
+ % the rest will not be obtained and consequently parsing
+ % an incomplete message will throw an exception.
get_body(S, Length, RequestLines) -->
stream__read_char(S, CharResult),
{ Length0 = Length - 1 },
@@ -337,7 +420,8 @@
(
{ Request^body = yes(Body) } ,
parse_soapmessage(Body, NsBody),
- write(NsBody), nl, nl,
+ % XXX parse_soapmessage calls error/1 when failed
+ % should change to response with http code = 415
{ get_procedure_call(NsBody, Proc) },
write(Proc), nl, nl,
@@ -345,15 +429,15 @@
{ make_web_request(NsBody, Proc, WebRequest) },
write(WebRequest), nl, nl,
- load_dynamic_library("./libsoap_test_methods.so",
- WebRequest, Result, HttpCode),
+ load_dynamic_library(uri_to_filename(Request^uri),
+ WebRequest, Result, HttpCode, ErrorFlag),
(
- { Result = yes(Output) },
+ { ErrorFlag = no },
{ generate_response_body(NsBody, Proc,
- Output, ResBody0) },
+ Result, ResBody0) },
{ ResBody = string_body(ResBody0) }
;
- { Result = no },
+ { ErrorFlag = yes },
{ ResBody = no_body }
)
;
@@ -361,9 +445,11 @@
% 400 = Bad Request
{ Request^body = no },
{ ResBody = no_body },
+ { Result = "Body not found" },
{ HttpCode = 400 }
),
- { list__filter(filter, Request^headers, Headers) },
+ { generate_headers(Request^headers, ResBody, Result,
+ Headers) },
{ Response = response(HttpCode, Headers,
ResBody, yes) }
).
@@ -379,10 +465,27 @@
:- func last_char(string) = char.
last_char(Str)
= string__unsafe_index(Str, string__length(Str) - 1).
+
+:- pred generate_headers(list(header)::in, response_body::in, string::in,
+ list(header)::out) is det.
+generate_headers(RequestHeaders, ResBody, ErrorMsg, Headers) :-
+ list__filter(is_content_type_header, RequestHeaders, Headers0),
+ (
+ ResBody = string_body(Body),
+ string__length(Body, BodyLength),
+ string__int_to_string(BodyLength, StringLength),
+ ConLen = [header("Content-Length:", StringLength, no)],
+ list__append(ConLen, Headers0, Headers)
+ ;
+ % includes error messages resulted from loading library
+ % in the header
+ ResBody = no_body,
+ Headers = [header(ErrorMsg, "", no)]
+ ).
-:- pred filter(header::in) is semidet.
-filter(header("Content-Length:", _, _)).
-filter(header("Content-Type:", _, _)).
+:- pred is_content_type_header(header::in) is semidet.
+is_content_type_header(header("Content-Type:", _, _)).
+is_content_type_header(header("Content-type:", _, _)).
%-----------------------------------------------------------------------------%
Index: soap.m
===================================================================
RCS file: /cvsroot/quicksilver/webserver/server/soap.m,v
retrieving revision 1.1
diff -u -r1.1 soap.m
--- soap.m 2001/01/25 06:54:42 1.1
+++ soap.m 2001/02/08 04:19:06
@@ -78,6 +78,9 @@
{ Res = ok((_, Doc)) },
{ nsTranslate(Doc, NsDoc) }
;
+ % XXX instead of error, should change to response
+ % with http code 415 Unsupported Media Type
+
{ Res = error(Err) },
{ string__append("parse_soapmessage failed: ", Err, ErrMsg) },
{ error(ErrMsg) }
@@ -130,13 +133,8 @@
% Gets method name.
get_procedure_call(NsDoc, Procedure) :-
get_procedure(NsDoc, [], Procedurelist),
- get_first_element(Procedurelist, Procedure).
-
-:- pred get_first_element(list(T)::in, T::out) is det.
+ list__index1_det(Procedurelist, 1, Procedure).
-get_first_element([], _) :- error("Procedure not found.").
-get_first_element([H|_], H).
-
:- pred get_procedure(nsDocument, list(nsElement), list(nsElement)).
:- mode get_procedure(in, in, out) is det.
get_procedure(NsDoc, Acc0, Acc) :-
@@ -369,7 +367,7 @@
get_prefix(URIListRev, Method^eName^nsURI, Method^eName^localName,
ElementName),
string__append("<", ElementName, ResBody0),
- string__append(ResBody0, "Response ", ResBody1),
+ string__append(ResBody0, "Response", ResBody1),
format_attrs(Method^eAttrs, Method^eNamespaces, URIListRev, Attrs),
string__append_list(Attrs, AttrsString),
@@ -378,7 +376,7 @@
string__append(ResBody2, Result, ResBody3),
string__append(ResBody3, "\n", ResBody4),
- make_end_tag(ElementName, EndTag),
+ make_end_tag((ElementName ++ "Response"), EndTag),
string__append(ResBody4, EndTag, ResBody).
@@ -411,10 +409,6 @@
Acc0, Acc1),
call(Pred, ContentArray, Ref, Method, Result, URIs,
Acc1, Acc).
-
-% :- pred insert_last(list(T)::in, T::in, list(T)::out) is det.
-% insert_last([], T, [T]).
-% insert_last([
:- pred my_delete(list(T)::in, list(T)::out) is det.
my_delete([], []).
Index: soap_test_methods.m
===================================================================
RCS file: /cvsroot/quicksilver/webserver/server/soap_test_methods.m,v
retrieving revision 1.1
diff -u -r1.1 soap_test_methods.m
--- soap_test_methods.m 2001/01/25 06:54:42 1.1
+++ soap_test_methods.m 2001/02/08 04:19:06
@@ -21,20 +21,34 @@
:- module soap_test_methods.
:- interface.
-:- import_module io, int, list, std_util.
+:- import_module list, std_util.
-:- pred hello(state::di, state::uo) is det.
+:- pred hello(univ::out) is det.
:- pred get_sp(list(univ)::in, univ::out) is det.
:- func get_stockprice(list(univ)) = univ.
+% :- pred get_bookprice(book::in, univ::out) is det.
:- pred get_bookprice(list(univ)::in, univ::out) is det.
+:- type book
+ ---> book(
+ title :: string,
+ author :: author,
+ intro :: string
+ ).
+
+:- type author
+ ---> author(
+ surname :: string,
+ firstname :: string
+ ).
+
%---------------------------------------------------------------------%
:- implementation.
-:- import_module require.
+:- import_module int, require.
% remove_first_element(List, Elem, Rest)
% takes out first element of the List and gives back
@@ -51,7 +65,8 @@
% Hello
%---------------------------------------------------------------------%
-hello --> print("Hello, world\n").
+hello(ResultAsUniv) :-
+ ResultAsUniv = univ("<output>Hello, world</output>").
%---------------------------------------------------------------------%
% GetStockPrice
@@ -87,8 +102,22 @@
%---------------------------------------------------------------------%
% GetBookPrice
%---------------------------------------------------------------------%
-
-get_bookprice(ParamList, ResultAsUniv) :-
- ResultAsUniv = univ(100).
+get_bookprice(ParamList, ResultAsUniv) :-
+ list__index1_det(ParamList, 1, ParamAsUniv),
+ Param0 = univ_value(ParamAsUniv),
+ Param = inst_cast_book(Param0),
+ (
+ Param = book("Hello world",
+ author("Foo", "Bar"),
+ "This is a book")
+ ->
+ ResultAsUniv = univ(100)
+ ;
+ ResultAsUniv = univ(50)
+ ).
+:- func inst_cast_book(T) = book.
+:- mode inst_cast_book(in) = out is det.
+:- pragma c_code(inst_cast_book(X::in) = (Y::out),
+ [will_not_call_mercury, thread_safe], "Y = X").
Index: web_methods.m
===================================================================
RCS file: /cvsroot/quicksilver/webserver/server/web_methods.m,v
retrieving revision 1.1
diff -u -r1.1 web_methods.m
--- web_methods.m 2001/01/25 06:54:42 1.1
+++ web_methods.m 2001/02/08 04:19:06
@@ -21,7 +21,7 @@
:- module web_methods.
:- interface.
-:- import_module io, list, string, std_util.
+:- import_module bool, io, list, string, std_util.
:- import_module http.
:- import_module xml, xml:ns.
@@ -42,92 +42,25 @@
pFields :: maybe(list(parameter))
% Struct or Array
).
-/* Ignore this
- % Converts method name and parameters in xml.ns format to
- % a web request.
-:- pred make_web_request(nsElement, list(parameter), web_method_request).
-:- mode make_web_request(in, in, out) is det.
-*/
-
% Loads library, invokes method call and generates corresponding
% response.
:- pred load_dynamic_library(string::in, web_method_request::in,
- maybe(string)::out, http_code::out, io__state::di, io__state::uo)
- is det.
+ string::out, http_code::out, bool::out,
+ io__state::di, io__state::uo) is det.
:- pred search_attributes(list(nsAttribute)::in, string::out) is semidet.
%-----------------------------------------------------------------------%
:- implementation.
-:- import_module bool, int, require.
+:- import_module int, require.
:- import_module dl, name_mangle, soap_test_methods.
-
- % XXX change that to command line argument
-:- func soap_library_file = string.
-soap_library_file = "soap_test_methods".
-
-/* Ignore this. Not used anymore
-
- % Generates a web request using method and parameters
-make_web_request(Proc, Params, Request) :-
- Request^name = Proc^eName^localName,
- Request^uri = Proc^eName^nsURI,
- Request^params = Params.
-
-make_web_request(Proc, Params, Request) :-
- Request^name = Proc^eName^localName,
- Request^uri = Proc^eName^nsURI,
- form_pair(Params, ParamsPair),
- list__map(retrieve_params, ParamsPair, Request^params).
-
- % Transform parameter list from [parameter, data, parameter, data ..]
- % to [(parameter - data)] to distinguish elements
-:- pred form_pair(list(nsContent), list(pair(nsContent, nsContent))).
-:- mode form_pair(in, out) is det.
-
-form_pair(ParamList , PairList) :-
- (
- ParamList = []
- ->
- PairList = []
- ;
- ParamList = [Param, Data | Tail]
- % list__split_list(2, ParamList, Start, End),
- % Start = [Param, Data]
- ->
- PairList = [(Param - Data) | PairList0],
- form_pair(Tail, PairList0)
- ;
- error("Incorrect Data Format")
- ).
+% :- func soap_library_file = string.
+% soap_library_file = "soap_test_methods".
- % Retrieve parameter name, uri, type if defined and data value.
-:- pred retrieve_params(pair(nsContent, nsContent), parameter).
-:- mode retrieve_params(in, out) is det.
-retrieve_params((Param0 - Data), Parameter) :-
- (
- Param0 = nsElement(Param),
- Data = data(Value)
- ->
- Name = Param^eName^localName,
- URI = Param^eName^nsURI,
- (
- search_attributes(Param^eAttrs, Type0)
- ->
- Type = yes(Type0)
- ;
- Type = no
- ),
- Parameter = parameter(Name, Type, Value, URI)
- ;
- error("Incorrect Data Format")
- ).
-*/
-
% Types in XML can be defined either by using xsi:type attribute
% or by using schema. This predicate is used to search if
% any attribute contains `xsi:type'.
@@ -172,12 +105,17 @@
% Opens library file, invokes desire function, and gets back
% corresponding response and http code.
-load_dynamic_library(L, Request, Response, HttpCode) -->
- dl__open(L, lazy, local, MaybeHandle),
+ %
+ % LibFile format = "./libfilename.so"
+ %
+load_dynamic_library(LibFile, Request, Response, HttpCode, ErrorFlag) -->
+ dl__open(LibFile, lazy, local, MaybeHandle),
+ { get_filename(LibFile, Filename) },
(
{ MaybeHandle = error(OpenMsg) },
{ string__append("dlopen failed: ", OpenMsg, OpenErrorMsg) },
- { Response = yes(OpenErrorMsg) },
+ { Response = OpenErrorMsg },
+ { ErrorFlag = yes },
{ HttpCode = 500 } % 500 Internal Server Error
;
{ MaybeHandle = ok(Handle) },
@@ -185,38 +123,46 @@
% Hello has no parameter
{ Request^name = "Hello" }
->
- call_Hello_pred(Handle, Request, Response0, HttpCode0)
+ call_Hello_pred(Handle, Filename, Request,
+ Response0, HttpCode0, ErrorFlag0)
;
% GetStockPrice has 1 parameter
{ Request^name = "GetStockPrice" }
->
- call_SP_func(Handle, Request, Response0, HttpCode0)
+ call_SP_func(Handle, Filename, Request,
+ Response0, HttpCode0, ErrorFlag0)
;
% GetBookPrice takes in a struct
{ Request^name = "GetBookPrice" }
->
- call_BP_pred(Handle, Request, Response0, HttpCode0)
+ call_BP_pred(Handle, Filename, Request,
+ Response0, HttpCode0, ErrorFlag0)
;
- { Response0 = yes("Method requested not
- implemented.") },
+ { Response0 = "Method requested not implemented." },
+ { ErrorFlag0 = yes },
{ HttpCode0 = 501 } % 501 Not Implemented
),
+/* commented out dl__close/4 so that the .so can be referred to it
+ when generating responses. If the .so file is closed, any pointers
+ referencing the .so file will become unavailable, causing
+ runtime error: segmentation violation.
+
dl__close(Handle, Result),
(
{ Result = error(CloseMsg) },
{ string__append("dlclose failed: ", CloseMsg,
CloseErrorMsg) },
- { Response1 = yes(CloseErrorMsg) },
+ { Response1 = no },
{ HttpCode1 = 500 },
- { ChangeHttpCode = yes }
+ { ChangeHttpCode = yes },
+ { error(CloseErrorMsg) }
;
{ Result = ok },
{ Response1 = Response0 },
{ HttpCode1 = HttpCode0 },
{ ChangeHttpCode = no }
),
-
(
{ ChangeHttpCode = yes }
->
@@ -226,24 +172,29 @@
{ Response = Response0 },
{ HttpCode = HttpCode0 }
)
+*/
+ { Response = Response0 },
+ { ErrorFlag = ErrorFlag0 },
+ { HttpCode = HttpCode0 }
).
%-----------------------------------------------------------------------%
% Hello
%-----------------------------------------------------------------------%
-:- pred call_Hello_pred(handle, web_method_request, maybe(string), http_code,
- io__state, io__state).
-:- mode call_Hello_pred(in, in, out, out, di, uo) is det.
-
-call_Hello_pred(Handle, _Request, Response, HttpCode) -->
- { HelloProc = mercury_proc(predicate, unqualified(soap_library_file),
- "hello", 2, 0) },
+:- pred call_Hello_pred(handle, string, web_method_request,
+ string, http_code, bool, io__state, io__state).
+:- mode call_Hello_pred(in, in, in, out, out, out, di, uo) is det.
+
+call_Hello_pred(Handle, Filename, _Request, Response, HttpCode, ErrorFlag) -->
+ { HelloProc = mercury_proc(predicate, unqualified(Filename),
+ "hello", 1, 0) },
dl__mercury_sym(Handle, HelloProc, MaybeHello),
(
{ MaybeHello = error(Msg) },
{ string__append("dlsym failed: ", Msg, ErrorMsg) },
- { Response = yes(ErrorMsg) },
+ { Response = ErrorMsg },
+ { ErrorFlag = yes },
{ HttpCode = 500 }
;
{ MaybeHello = ok(HelloPred0) },
@@ -254,9 +205,11 @@
% Call the procedure whose address
% we just obtained.
- HelloPred,
+ { HelloPred(HelloUniv) },
+ { det_univ_to_type(HelloUniv, HelloString) },
- { Response = yes("<output>Hello World</output>") },
+ { Response = HelloString },
+ { ErrorFlag = no },
{ HttpCode = 200 }
).
@@ -265,74 +218,71 @@
% `hello' procedure is `pred(di, uo) is det', before we can actually
% call it. The function inst_cast_hello/1 defined below does that.
-:- type io_pred == pred(io__state, io__state).
-:- inst io_pred == (pred(di, uo) is det).
+:- type hello_pred == pred(univ).
+:- inst hello_pred == (pred(out) is det).
-:- func inst_cast_hello(io_pred) = io_pred.
-:- mode inst_cast_hello(in) = out(io_pred) is det.
-:- pragma c_code(inst_cast_hello(X::in) = (Y::out(io_pred)),
+:- func inst_cast_hello(hello_pred) = hello_pred.
+:- mode inst_cast_hello(in) = out(hello_pred) is det.
+:- pragma c_code(inst_cast_hello(X::in) = (Y::out(hello_pred)),
[will_not_call_mercury, thread_safe], "Y = X").
%-----------------------------------------------------------------------%
% GetStockPrice
%-----------------------------------------------------------------------%
-:- pred call_SP_func(handle, web_method_request, maybe(string), http_code,
- io__state, io__state).
-:- mode call_SP_func(in, in, out, out, di, uo) is det.
+:- pred call_SP_func(handle, string, web_method_request,
+ string, http_code, bool, io__state, io__state).
+:- mode call_SP_func(in, in, in, out, out, out, di, uo) is det.
-call_SP_func(Handle, Request, Response, HttpCode) -->
- { list__length(Request^params, Arity) },
-
+call_SP_func(Handle, Filename, Request, Response, HttpCode, ErrorFlag) -->
% XXX test for function
- % { GetSPProc = mercury_proc(function, unqualified(soap_library_file),
- % "get_stockprice", Arity, 0) },
+ { list__length(Request^params, Arity) },
+ { GetSPProc = mercury_proc(function, unqualified(Filename),
+ "get_stockprice", Arity, 0) },
% XXX test for predicate
- { GetSPProc = mercury_proc(predicate, unqualified(soap_library_file),
- "get_sp", 2, 0) },
+ % { GetSPProc = mercury_proc(predicate, unqualified(Filename),
+ % "get_sp", 2, 0) },
dl__mercury_sym(Handle, GetSPProc, MaybeGetStockPrice),
(
{ MaybeGetStockPrice = error(Msg) },
{ string__append("dlsym failed: ", Msg, ErrorMsg) },
- { Response = yes(ErrorMsg) },
- { HttpCode = 500 }
+ { Response = ErrorMsg },
+ { ErrorFlag = yes },
+ { HttpCode = 500 }
;
{ MaybeGetStockPrice = ok(SPProc0) },
% Cast the higher-order term that we obtained
% to the correct higher-order inst.
% XXX test for predicate
- { SPProc = inst_cast_sp(SPProc0) },
+ % { SPProc = inst_cast_sp(SPProc0) },
% XXX test for function
- % { wrapper(SPFunc) = inst_cast_stockprice(SPProc0) },
-
- % message is parsed bottom up, therefore parameter
- % list is in reverse order
- % { list__reverse(Request^params, ParameterList) },
+ { wrapper(SPFunc) = inst_cast_stockprice(wrapper(SPProc0)) },
% Convert parameters (string) to the corresponding types
{ list__map(lookup_SP_schema, Request^params, UnivList) },
% Call the procedure whose address we just obtained
% XXX test for predicate
- { call(SPProc, UnivList, SPUniv) },
+ % { call(SPProc, UnivList, SPUniv) },
% XXX test for function
- % { SPUniv = SPFunc(UnivList) },
+ { SPUniv = SPFunc(UnivList) },
{ det_univ_to_type(SPUniv, SPInt) },
{ string__int_to_string(SPInt, SPString) },
{ string__append("<price>", SPString, SPresult0) },
{ string__append(SPresult0, "</price>", SPresult) },
- { Response = yes(SPresult) },
+ { Response = SPresult },
+ { ErrorFlag = no },
{ HttpCode = 200 }
).
% schema for GetStockPrice:
- % <element name="stocknum" type="mercury:int"/>
+ % <element name="stocknum" type="xsd:int"/>
% </element>
% Lookup element name in schema, find the corresponding type
@@ -362,13 +312,13 @@
;
% assume Type must be simple type eg. int, float
% XXX type may contain prefix
- % Eg. mercury:int, mercury:float
+ % Eg. xsd:int, xsd:float
% XXX Do I have to make sure the prefix = mercury?
- % Case 3 <stocknum xsi:type="mercury:int">1</stocknum>
+ % Case 3 <stocknum xsi:type="xsd:int">1</stocknum>
% web_method_request("GetStockPrice",
- % [parameter("stocknum", yes("mercury:int"), "",
+ % [parameter("stocknum", yes("xsd:int"), "",
% yes("1"), no)], "some uri")
Param^pType = yes(Type),
@@ -424,19 +374,20 @@
% schema for GetBookPrice:
%
% <element name="book" type="tns:book"/>
+ % <element name="author" base="tns:author"/>
+ %
% <complexType name="book">
% <sequence>
- % <element name="title" type="mercury:string"/>
+ % <element name="title" type="xsd:string"/>
% <element name="author" type="tns:author"/>
- % <element name="intro" type="mercury:string"/>
+ % <element name="intro" type="xsd:string"/>
% </sequence>
% </complexType>
%
- % <element name="author" base="tns:author"/>
% <complexType name="author">
% <sequence>
- % <element name"surname" type="mercury:string"/>
- % <element name"firstname" type="mercury:string"/>
+ % <element name"surname" type="xsd:string"/>
+ % <element name"firstname" type="xsd:string"/>
% </sequence>
% </complexType>
%
@@ -448,28 +399,27 @@
% author :: author,
% intro :: string
% ).
- %
+ %
% :- type author
% ---> author(
% surname :: string,
% firstname :: string
% ).
-:- pred call_BP_pred(handle, web_method_request, maybe(string), http_code,
- io__state, io__state).
-:- mode call_BP_pred(in, in, out, out, di, uo) is det.
-
-call_BP_pred(Handle, Request, Response, HttpCode) -->
- { list__length(Request^params, Arity0) },
- { Arity = Arity0 + 1 }, % since it is a predicate
- { GetBPProc = mercury_proc(predicate, unqualified(soap_library_file),
- "get_bookprice", Arity, 0) },
+:- pred call_BP_pred(handle, string, web_method_request,
+ string, http_code, bool, io__state, io__state).
+:- mode call_BP_pred(in, in, in, out, out, out, di, uo) is det.
+
+call_BP_pred(Handle, Filename, Request, Response, HttpCode, ErrorFlag) -->
+ { GetBPProc = mercury_proc(predicate, unqualified(Filename),
+ "get_bookprice", 2, 0) },
dl__mercury_sym(Handle, GetBPProc, MaybeGetBookPrice),
(
{ MaybeGetBookPrice = error(Msg) },
{ string__append("dlsym failed: ", Msg, ErrorMsg) },
- { Response = yes(ErrorMsg) },
- { HttpCode = 500 }
+ { Response = ErrorMsg },
+ { ErrorFlag = yes },
+ { HttpCode = 500 }
;
{ MaybeGetBookPrice = ok(BPProc0) },
@@ -478,79 +428,91 @@
{ BPProc = inst_cast_bp(BPProc0) },
% Convert parameters (string) to the corresponding types
- % { list__map(lookup_BP_schema, Request^params, UnivList) },
-
+ { list__map(lookup_BP_schema, Request^params, UnivList) },
+
% Call the procedure whose address we just obtained
- { UnivList = [univ(1)] },
{ call(BPProc, UnivList, BPUniv) },
+
{ det_univ_to_type(BPUniv, BPInt) },
{ string__int_to_string(BPInt, BPString) },
{ string__append("<price>", BPString, BPresult0) },
{ string__append(BPresult0, "</price>", BPresult) },
- { Response = yes(BPresult) },
+ { Response = BPresult },
+ { ErrorFlag = no },
{ HttpCode = 200 }
).
-/* still working
-
-:- pred searchBPList(list(parameter), string, maybe(list(parameter)),
- maybe(string)).
-:- mode searchBPList(in, in, out, out) is semidet.
-
-searchBPList(ParamList, ElemName, Struct, Value) :-
- Elem = parameter(ElemName, _, _, _, _),
- (
- list__nth_member_search(ParamList, Elem, Pos),
- list__index1(ParamList, Pos, Param)
- ->
- Struct = Param^pFields,
- Value = Param^pValue
- ;
- fail
- ).
-
:- pred lookup_BP_schema(parameter::in, univ::out) is det.
lookup_BP_schema(Param, ValueAsUniv) :-
(
Param^pName = "book",
- Param^pFields = yes(StructList),
- (
- searchBPList(StructList, "title", Child, Value0),
- Child = no,
- Value0 = yes(Value)
- ->
- type_cast_parameter("string", Value, ValueAsUniv)
- ;
- searchBPList(StructList, "author", Child, _),
- Child = yes(ChildStructList)
- ->
- (
- searchBPList(ChildStructList, "author", _, _ )
- ;
- require__error(
- "Element Structure not defined in schema.")
+ Param^pFields = yes(FieldList)
+ ->
+ get_BP_param(FieldList, "title", Title0),
+ lookup_BP_schema(Title0, TitleAsUniv),
+ det_univ_to_type(TitleAsUniv, Title),
+
+ get_BP_param(FieldList, "author", Author0),
+ lookup_BP_schema(Author0, AuthorAsUniv),
+ det_univ_to_type(AuthorAsUniv, Author),
+
+ get_BP_param(FieldList, "intro", Intro0),
+ lookup_BP_schema(Intro0, IntroAsUniv),
+ det_univ_to_type(IntroAsUniv, Intro),
- )
- ;
- searchBPList(StructList, "intro", Child, Value0),
- Child = no,
- Value0 = yes(Value)
- ->
- type_cast_parameter("string", Value, ValueAsUniv)
- ;
- require__error(
- "Element Structure not defined in schema.")
- )
+ ValueAsBook = book(Title, Author, Intro),
+ ValueAsUniv = univ(ValueAsBook)
+ ;
+ Param^pName = "title",
+ Param^pValue = yes(Value)
+ ->
+ type_cast_parameter("string", Value, ValueAsUniv)
+ ;
+ Param^pName = "author",
+ Param^pFields = yes(FieldList)
+ ->
+ get_BP_param(FieldList, "surname", Surname0),
+ lookup_BP_schema(Surname0, SurnameAsUniv),
+ det_univ_to_type(SurnameAsUniv, Surname),
+
+ get_BP_param(FieldList, "firstname", Firstname0),
+ lookup_BP_schema(Firstname0, FirstnameAsUniv),
+ det_univ_to_type(FirstnameAsUniv, Firstname),
+
+ ValueAsAuthor = author(Surname, Firstname),
+ ValueAsUniv = univ(ValueAsAuthor)
+ ;
+ Param^pName = "surname",
+ Param^pValue = yes(Value)
+ ->
+ type_cast_parameter("string", Value, ValueAsUniv)
+ ;
+ Param^pName = "firstname",
+ Param^pValue = yes(Value)
+ ->
+ type_cast_parameter("string", Value, ValueAsUniv)
;
+ Param^pName = "intro",
+ Param^pValue = yes(Value)
+ ->
+ type_cast_parameter("string", Value, ValueAsUniv)
+ ;
require__error("Element Structure not defined in schema.")
).
-*/
+:- pred get_BP_param(list(parameter)::in, string::in, parameter::out) is det.
+
+get_BP_param(ParamList, SearchString, Parameter) :-
+ list__filter((pred(X::in) is semidet :-
+ X = parameter(SearchString,_,_,_,_)), ParamList, Result),
+ list__index1_det(Result, 1, Parameter).
+
% inst cast for get_bookprice
:- type bp_pred == pred(list(univ), univ).
+% :- type bp_pred == pred(book, univ).
:- inst bp_pred == (pred(in, out) is det).
:- func i...
[truncated message content] |
|
From: Peter R. <pet...@mi...> - 2001-02-08 09:34:50
|
On Thu, Feb 08, 2001 at 03:30:09PM +1100, Ina Cheng wrote: > > Hi, > > I've addressed Peter's comments and here is the new diff. > If everything looks ok, I would like to commit the changes. > > Ina > <in...@st...> > > ======================================================================== > > Estimated hours taken: 5 > > Address Peter's comment for last diff ( the diff for adding example > to handle mercury structure). > > /server/server.m > add predicates to check request header. > change the header to request a library filename to be loaded for dl. > > /server/soap.m > clean up some code. > (Peter mentioned that I should do this in a separate change, > but I can't remember how to change it back to the original, > sorry, please bear with it now. I'll remember it next time.) > > /server/soap_test_methods.m > /server/web_methods.m > add example to handle mercury structure > You should reuse the log message from your original change, because that is the log message that was reviewed. No need to mention the review process. Otherwise that looks fine. |
Thanks for helping keep SourceForge clean.
X