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