Menu
▾
▴
Re: [qs-dev] for review: add example to support structure
|
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
|
