Chapril/xmpp.chapril.org-ejabberd
24
1
Fork 0
mirror of https://github.com/processone/ejabberd.git synced 2024-06-30 23:02:00 +02:00
Code Releases Activity

Update to xmlrpc-rds13

Browse Source 
Cloned from
https://github.com/rds13/xmlrpc
This commit is contained in:
Badlop 2012-11-20 12:43:54 +01:00
parent 0fcaef0566
commit c9ac75474f
12 changed files with 880 additions and 599 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
src/beam_util.erl Normal file
View File

@ -0,0 +1,56 @@
%% Copyright (C) 2009 Romuald du Song <rdusong _AT_ gmail _DOT_ com>.
%% All rights reserved.
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
%% are met:
%%
%% 1. Redistributions of source code must retain the above copyright
%% notice, this list of conditions and the following disclaimer.
%% 2. Redistributions in binary form must reproduce the above
%% copyright notice, this list of conditions and the following
%% disclaimer in the documentation and/or other materials provided
%% with the distribution.
%%
%% THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
%% OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
%% WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
%% ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
%% DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
%% DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
%% GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
%% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
%% WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
%% NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
%% SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-module(beam_util).
-export([module_export_list/1, filter_arity/3]).
%% Module = string()
%% Function = atom()
module_export_list( Module ) ->
{_Module, _Binary, Filename} = code:get_object_code(Module),
case beam_lib:info( Filename ) of
{error, beam_lib, _} ->
false;
[ _ , _ , _ ] ->
case beam_lib:chunks( Filename, [exports]) of
{ok, {_, [{exports, Exports}]}} ->
Exports;
{error, beam_lib, Er} ->
false
end
end.
%% Module = string()
%% Arity = integer()
%% Exports = list()
filter_arity( Function, Arity, Exports) ->
case lists:filter(
fun( EFName ) -> {Function, Arity} == EFName end,
Exports ) of
[{_, _}] -> true;
[] -> false
end.

11
src/log.hrl
View File

@ -3,10 +3,10 @@
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
%% are met:
%% are met:
%%
%% 1. Redistributions of source code must retain the above copyright
%% notice, this list of conditions and the following disclaimer.
%% notice, this list of conditions and the following disclaimer.
%% 2. Redistributions in binary form must reproduce the above
%% copyright notice, this list of conditions and the following
%% disclaimer in the documentation and/or other materials provided
@ -31,13 +31,8 @@
error_logger:error_report({?MODULE, ?LINE, Reason})).
-ifdef(DEBUG).
-define(DEBUG_LOG(Reason),
error_logger:info_report({debug, ?MODULE, ?LINE,
Reason})).
error_logger:info_report({debug, ?MODULE, ?LINE, Reason})).
-else.
-define(DEBUG_LOG(Reason), ok).
-endif.

156
src/tcp_serv.erl
View File

@ -3,10 +3,10 @@
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
%% are met:
%% are met:
%%
%% 1. Redistributions of source code must retain the above copyright
%% notice, this list of conditions and the following disclaimer.
%% notice, this list of conditions and the following disclaimer.
%% 2. Redistributions in binary form must reproduce the above
%% copyright notice, this list of conditions and the following
%% disclaimer in the documentation and/or other materials provided
@ -25,34 +25,41 @@
%% SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-module(tcp_serv).
-vsn("1.13").
-author('jocke@gleipnir.com').
-export([start_link/1, start_link/2, stop/1, stop/2]).
-export([init/2, start_session/3]).
-export([system_continue/3, system_terminate/4]).
-include("log.hrl").
-record(state,
{max_sessions, session_handler, session_list,
listen_socket, parent, debug_info}).
-record(state, {
%% int()
max_sessions,
%% {M, F, A}
%% M = F = atom()
%% A = [term()]
session_handler,
%% [pid()]
session_list,
%% socket()
listen_socket,
%% pid()
parent,
%% term()
debug_info
}).
%% Exported: start_link/{1,2}
start_link(Args) -> start_link(Args, 60000).
start_link(Args, Timeout) ->
Pid = proc_lib:spawn_link(?MODULE, init,
[self(), Args]),
Pid = proc_lib:spawn_link(?MODULE, init, [self(), Args]),
receive
{Pid, started} -> {ok, Pid};
{Pid, Reason} -> {error, Reason}
after Timeout -> {error, timeout}
{Pid, started} -> {ok, Pid};
{Pid, Reason} -> {error, Reason}
after Timeout -> {error, timeout}
end.
%% Exported: stop/{1,2}
@ -60,83 +67,90 @@ start_link(Args, Timeout) ->
stop(Pid) -> stop(Pid, 15000).
stop(Pid, Timeout) ->
Pid ! {self(), stop},
Pid ! {self(), stop},
receive
{Pid, Reply} -> Reply after Timeout -> {error, timeout}
{Pid, Reply} -> Reply
after
Timeout -> {error, timeout}
end.
%% Exported: init/2
init(Parent,
[Port, MaxSessions, OptionList, SessionHandler]) ->
init(Parent, [Port, MaxSessions, OptionList, SessionHandler]) ->
process_flag(trap_exit, true),
case gen_tcp:listen(Port, OptionList) of
{ok, ListenSocket} ->
self() ! start_session,
Parent ! {self(), started},
loop(#state{max_sessions = MaxSessions,
session_handler = SessionHandler, session_list = [],
listen_socket = ListenSocket, parent = Parent});
Reason -> Parent ! {self(), {not_started, Reason}}
{ok, ListenSocket} ->
self() ! start_session,
Parent ! {self(), started},
loop(#state{max_sessions = MaxSessions,
session_handler = SessionHandler,
session_list = [],
listen_socket = ListenSocket,
parent = Parent});
Reason -> Parent ! {self(), {not_started, Reason}}
end.
loop(#state{session_list = SessionList,
listen_socket = ListenSocket, parent = Parent} =
State) ->
loop(#state{session_list = SessionList, listen_socket = ListenSocket,
parent = Parent} = State) ->
receive
{From, stop} -> cleanup(State), From ! {self(), ok};
start_session
when length(SessionList) > State#state.max_sessions ->
timer:sleep(5000), self() ! start_session, loop(State);
start_session ->
A = [self(), State#state.session_handler, ListenSocket],
Pid = proc_lib:spawn_link(?MODULE, start_session, A),
loop(State#state{session_list = [Pid | SessionList]});
{'EXIT', Parent, Reason} ->
cleanup(State), exit(Reason);
{'EXIT', Pid, Reason} ->
case lists:member(Pid, SessionList) of
true ->
PurgedSessionList = lists:delete(Pid, SessionList),
loop(State#state{session_list = PurgedSessionList});
false ->
?ERROR_LOG({ignoring, {'EXIT', Pid, Reason}}),
loop(State)
end;
{system, From, Request} ->
sys:handle_system_msg(Request, From, Parent, ?MODULE,
State#state.debug_info, State);
UnknownMessage ->
?ERROR_LOG({unknown_message, UnknownMessage}),
loop(State)
{From, stop} ->
cleanup(State),
From ! {self(), ok};
start_session when length(SessionList) > State#state.max_sessions ->
timer:sleep(5000),
self() ! start_session,
loop(State);
start_session ->
A = [self(), State#state.session_handler, ListenSocket],
Pid = proc_lib:spawn_link(?MODULE, start_session, A),
loop(State#state{session_list = [Pid|SessionList]});
{'EXIT', Parent, Reason} ->
cleanup(State),
exit(Reason);
{'EXIT', Pid, Reason} ->
case lists:member(Pid, SessionList) of
true ->
PurgedSessionList = lists:delete(Pid, SessionList),
loop(State#state{session_list = PurgedSessionList});
false ->
?ERROR_LOG({ignoring, {'EXIT', Pid, Reason}}),
loop(State)
end;
{system, From, Request} ->
sys:handle_system_msg(Request, From, Parent, ?MODULE,
State#state.debug_info, State);
UnknownMessage ->
?ERROR_LOG({unknown_message, UnknownMessage}),
loop(State)
end.
cleanup(State) ->
gen_tcp:close(State#state.listen_socket).
cleanup(State) -> gen_tcp:close(State#state.listen_socket).
%% Exported: start_seesion/3
start_session(Parent, {M, F, A}, ListenSocket) ->
case gen_tcp:accept(ListenSocket) of
{ok, Socket} ->
Parent ! start_session,
case apply(M, F, [Socket | A]) of
ok -> gen_tcp:close(Socket);
{error, closed} -> ok;
{error, Reason} ->
?ERROR_LOG({M, F, Reason}), gen_tcp:close(Socket)
end;
{error, _Reason} ->
timer:sleep(5000), Parent ! start_session
{ok, Socket} ->
Parent ! start_session,
case apply(M, F, [Socket|A]) of
ok -> gen_tcp:close(Socket);
{error, closed} -> ok;
{error, Reason} ->
?ERROR_LOG({M, F, Reason}),
gen_tcp:close(Socket)
end;
{error, Reason} ->
timer:sleep(5000),
Parent ! start_session
end.
%% Exported: system_continue/3
system_continue(Parent, DebugInfo, State) ->
loop(State#state{parent = Parent,
debug_info = DebugInfo}).
loop(State#state{parent = Parent, debug_info = DebugInfo}).
%% Exported: system_terminate/3
system_terminate(Reason, _Parent, _DebugInfo, State) ->
cleanup(State), exit(Reason).
system_terminate(Reason, Parent, DebugInfo, State) ->
cleanup(State),
exit(Reason).

65
src/url_util.erl Normal file
View File

@ -0,0 +1,65 @@
%% Author: Romuald du Song
%% Created: 9 oct. 2009
%% Description:
%% Hacked from Joe Armtrong http://www.erlang.org/examples/small_examples/urlget.erl
-module(url_util).
%%
%% Include files
%%
%%
%% Exported Functions
%%
-export([parse/1]).
%%
%% API Functions
%%
%%----------------------------------------------------------------------
%% parse(URL) -> {http, Site, Port, File} |
%% {file, File} | {error,Why}
%% (primitive)
parse([$h,$t,$t,$p,$:,$/,$/|T]) -> parse_http(T, http);
parse([$h,$t,$t,$p,$s,$:,$/,$/|T]) -> parse_http(T, https);
parse([$f,$t,$p,$:,$/,$/|_T]) -> {error, no_ftp};
parse([$f,$i,$l,$e,$:,$/,$/|F]) -> {file, F};
parse(_X) -> {error, unknown_url_type}.
%%
%% Local Functions
%%
parse_http(X, Protocol) ->
case string:chr(X, $/) of
0 ->
%% not terminated by "/" (sigh)
%% try again
parse_http(X ++ "/", Protocol);
N ->
%% The Host is up to the first "/"
%% The file is everything else
Host = string:substr(X, 1, N-1),
File = string:substr(X, N, length(X)),
%% Now check to see if the host name contains a colon
%% i.e. there is an explicit port address in the hostname
case string:chr(Host, $:) of
0 ->
%% no colon
Port = 80,
{Protocol, Host, Port, File};
M ->
Site = string:substr(Host,1,M-1),
case (catch list_to_integer(
string:substr(Host, M+1, length(Host)))) of
{'EXIT', _} ->
{Protocol, Site, 80, File};
Port ->
{Protocol, Site, Port, File}
end
end
end.

9
src/xmlrpc.app Normal file
View File

@ -0,0 +1,9 @@
{application,xmlrpc,
[{description,[]},
{vsn,"80389e7"},
{registered,[]},
{applications,[]},
{env,[]},
{modules,[beam_util,example_serv,tcp_serv,url_util,xmlrpc,
xmlrpc_decode,xmlrpc_encode,xmlrpc_http,
xmlrpc_util]}]}.

8
src/xmlrpc.app.src Normal file
View File

@ -0,0 +1,8 @@
{application, xmlrpc,
[
{description, ""},
{vsn, git},
{registered, []},
{applications, []},
{env, []}
]}.

359
src/xmlrpc.erl
View File

@ -1,12 +1,14 @@
%% Hacked by Romuald du Song
%%
%% Copyright (C) 2003 Joakim Grebenö <jocke@gleipnir.com>.
%% All rights reserved.
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
%% are met:
%% are met:
%%
%% 1. Redistributions of source code must retain the above copyright
%% notice, this list of conditions and the following disclaimer.
%% notice, this list of conditions and the following disclaimer.
%% 2. Redistributions in binary form must reproduce the above
%% copyright notice, this list of conditions and the following
%% disclaimer in the documentation and/or other materials provided
@ -25,163 +27,244 @@
%% SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-module(xmlrpc).
-author('jocke@gleipnir.com').
-export([call/3, call/4, call/5, call/6]).
-export([start_link/1, start_link/5, start_link/6,
stop/1]).
-export([call/3, call/4, call/5, call/6, call/7, call/8, call2/7]).
-export([start_link/1, start_link/5, start_link/6, stop/1]).
-include("log.hrl").
-record(header, {content_length :: non_neg_integer(),
connection :: close}).
-include("xmlrpc.hrl").
%% Exported: call/{3,4,5,6}
call(Host, Port, URI, Payload) ->
call(Host, Port, URI, Payload, false, 60000).
call(Host, Port, URI, Payload, KeepAlive, Timeout) ->
case gen_tcp:connect(Host, Port, [binary, {active, false}]) of
{ok, Socket} ->
call(Socket, URI, Payload, KeepAlive, Timeout);
{error, Reason} when KeepAlive == false ->
{error, Reason};
{error, Reason} -> {error, undefined, Reason}
end.
%% Exported: call/{3,4,5,6,7,8}
call(Socket, URI, Payload) ->
call(Socket, URI, Payload, false, 60000).
call2(Socket, URI, Payload, false, 60000, "", [{ssl, false}, {header, false}]).
call(Host, Port, URI, Payload, Options) when is_number(Port) ->
call(Host, Port, URI, Payload, false, 60000, "", Options);
call(Socket, URI, Payload, KeepAlive, Timeout) ->
?DEBUG_LOG({decoded_call, Payload}),
EncodedPayload = xmlrpc_encode:payload(Payload),
?DEBUG_LOG({encoded_call, EncodedPayload}),
case send(Socket, URI, KeepAlive, EncodedPayload) of
ok ->
case parse_response(Socket, Timeout) of
{ok, Header} ->
handle_payload(Socket, KeepAlive, Timeout, Header);
{error, Reason} when KeepAlive == false ->
gen_tcp:close(Socket), {error, Reason};
{error, Reason} -> {error, Socket, Reason}
end;
{error, Reason} when KeepAlive == false ->
gen_tcp:close(Socket), {error, Reason};
{error, Reason} -> {error, Socket, Reason}
call2(Socket, URI, Payload, KeepAlive, Timeout, "", [{ssl, false}, {header, false}]).
call(Host, Port, URI, Payload) when is_number(Port) ->
call(Host, Port, URI, Payload, false, 60000, "", [{ssl, false}, {header, false}]);
call(Socket, URI, Payload, Options) ->
call2(Socket, URI, Payload, false, 60000, "", Options).
call(Host, Port, URI, Payload, KeepAlive, Timeout) when is_number(Port) ->
call(Host, Port, URI, Payload, KeepAlive, Timeout, "", [{ssl, false}, {header, false}]);
call(Socket, URI, Payload, KeepAlive, Timeout, Options) ->
call2(Socket, URI, Payload, KeepAlive, Timeout, "", Options).
call(Host, Port, URI, Payload, KeepAlive, Timeout, Options) when is_number(Port) ->
call(Host, Port, URI, Payload, KeepAlive, Timeout, "", Options);
call(Socket, URI, Payload, KeepAlive, Timeout, ExtraHeader, Options) ->
call2(Socket, URI, Payload, KeepAlive, Timeout, ExtraHeader, Options).
call(Host, Port, URI, Payload, KeepAlive, Timeout, ExtraHeaders, Options) when is_number(Port) ->
case open_socket(Host, Port, Options) of
{ok, Socket} -> call2(Socket, URI, Payload, KeepAlive, Timeout, ExtraHeaders, Options);
{error, Reason} when KeepAlive == false -> {error, Reason};
{error, Reason} -> {error, undefined, Reason}
end.
send(Socket, URI, false, Payload) ->
send(Socket, URI, <<"Connection: close\r\n">>, Payload);
send(Socket, URI, true, Payload) ->
send(Socket, URI, <<"">>, Payload);
send(Socket, URI, Header, Payload) ->
Request = [<<"POST ">>, URI, <<" HTTP/1.1\r\n">>,
<<"Content-Length: ">>,
jlib:integer_to_binary(byte_size(Payload)),
<<"\r\n">>,
<<"User-Agent: Erlang XML-RPC Client 1.13\r\n">>,
<<"Content-Type: text/xml\r\n">>, Header, <<"\r\n">>,
Payload],
gen_tcp:send(Socket, Request).
parse_response(Socket, Timeout) ->
inet:setopts(Socket, [binary, {packet, line}]),
case gen_tcp:recv(Socket, 0, Timeout) of
{ok, <<"HTTP/1.1 200 OK\r\n">>} ->
parse_header(Socket, Timeout);
{ok, StatusLine} -> {error, StatusLine};
{error, Reason} -> {error, Reason}
open_socket(Host, Port, Options) ->
case fetch_comm_module(Options) of
ssl ->
%% Start ssl application
application:start(ssl),
%% Always seed
ssl:seed("wheredoyouthinkitcanbefound"),
%% new ssl implementation does not seem to work as of R13B01
%%{ok, SslSocket} = ssl:connect(Host, Port, [{ssl_imp, new}, {active, false}, {verify, verify_none}]),
ssl:connect(Host, Port, [{verify, 0}, {active, false}]);
_ ->
gen_tcp:connect(Host, Port, [{active, false}])
end.
call2(Socket, URI, Payload, KeepAlive, Timeout, ExtraHeader, Options) ->
?DEBUG_LOG({decoded_call, Payload}),
case xmlrpc_encode:payload(Payload) of
{ok, EncodedPayload} ->
?DEBUG_LOG({encoded_call, EncodedPayload}),
case send(Socket, URI, KeepAlive, EncodedPayload, ExtraHeader, Options) of
ok ->
case parse_response(Socket, Timeout, Options) of
{ok, Header} ->
handle_payload(Socket, KeepAlive, Timeout, Options, Header);
{error, Reason} when KeepAlive == false ->
comm_close(Options, Socket),
{error, Reason};
{error, Reason} -> {error, Socket, Reason}
end;
{error, Reason} when KeepAlive == false ->
comm_close(Options, Socket),
{error, Reason};
{error, Reason} -> {error, Socket, Reason}
end;
{error, Reason} when KeepAlive == false ->
comm_close(Options, Socket),
{error, Reason};
{error, Reason} -> {error, Socket, Reason}
end.
send(Socket, URI, false, Payload, ExtraHeader, SslOption) ->
send(Socket, URI, lists:flatten(["Connection: close\r\n" | ExtraHeader]), Payload, SslOption);
send(Socket, URI, true, Payload, ExtraHeader, SslOption) ->
send(Socket, URI, ExtraHeader, Payload, SslOption).
send(Socket, URI, Header, Payload, SslOption) ->
Request =
["POST ", URI, " HTTP/1.1\r\n",
"Content-Length: ", integer_to_list(lists:flatlength(Payload)),
"\r\n",
"User-Agent: Erlang XML-RPC Client 1.13\r\n",
"Content-Type: text/xml\r\n",
Header, "\r\n",
Payload],
M = fetch_comm_module(SslOption),
apply(M, send, [Socket, Request]).
parse_response(Socket, Timeout, SslOption) ->
M = fetch_comm_module(SslOption),
S = fetch_sets_module(SslOption),
apply(S, setopts, [Socket, [{packet, line}]]),
case apply(M, recv, [Socket, 0, Timeout]) of
{ok, "HTTP/1.1 200 OK\r\n"} -> parse_header(Socket, Timeout, SslOption);
{ok, StatusLine} -> {error, StatusLine};
{error, Reason} -> {error, Reason}
end.
fetch_comm_module(Options) ->
case lists:keysearch(ssl, 1, Options) of
{value, {ssl, true}} -> ssl;
_ -> gen_tcp
end.
has_header_option(Options) ->
case lists:keysearch(header, 1, Options) of
{value, {_, true}} -> true;
_ -> false
end.
fetch_sets_module(Options) ->
case lists:keysearch(ssl, 1, Options) of
{value, {ssl, true}} -> ssl;
_ -> inet
end.
comm_close(Options, Socket) ->
M = fetch_comm_module(Options),
apply(M, close, [ Socket ]).
parse_header(Socket, Timeout, SslOption) -> parse_header(Socket, Timeout, SslOption, #header{}).
parse_header(Socket, Timeout, SslOption, Header) ->
M = fetch_comm_module(SslOption),
case apply(M, recv, [Socket, 0, Timeout]) of
{ok, "\r\n"} when Header#header.content_length == undefined ->
{error, missing_content_length};
{ok, "\r\n"} -> {ok, Header};
{ok, HeaderField} ->
case string:tokens(HeaderField, " \r\n") of
["Content-Length:", ContentLength] ->
case catch list_to_integer(ContentLength) of
badarg ->
{error, {invalid_content_length, ContentLength}};
Value ->
parse_header(Socket, Timeout, SslOption,
Header#header{content_length =
Value})
end;
["Connection:", "close"] ->
parse_header(Socket, Timeout, SslOption,
Header#header{connection = close});
["Authorization:", Authorization] ->
parse_header(Socket, Timeout, SslOption,
Header#header{authorization = Authorization});
["Cookie:", Cookie] ->
Cookies = [ Cookie | Header#header.cookies ],
parse_header(Socket, Timeout, SslOption,
Header#header{cookies = Cookies});
_ ->
parse_header(Socket, Timeout, SslOption, Header)
end;
{error, Reason} -> {error, Reason}
end.
parse_header(Socket, Timeout) ->
parse_header(Socket, Timeout, #header{}).
parse_header(Socket, Timeout, Header) ->
case gen_tcp:recv(Socket, 0, Timeout) of
{ok, <<"\r\n">>}
when Header#header.content_length == undefined ->
{error, missing_content_length};
{ok, <<"\r\n">>} -> {ok, Header};
{ok, HeaderField} ->
case str:tokens(HeaderField, <<" \r\n">>) of
[<<"Content-Length:">>, ContentLength] ->
case catch jlib:binary_to_integer(ContentLength) of
Value when is_integer(Value), Value>=0 ->
parse_header(Socket, Timeout,
Header#header{content_length = Value});
_ ->
{error, {invalid_content_length, ContentLength}}
end;
[<<"Connection:">>, <<"close">>] ->
parse_header(Socket, Timeout,
Header#header{connection = close});
_ -> parse_header(Socket, Timeout, Header)
end;
{error, Reason} -> {error, Reason}
handle_payload(Socket, KeepAlive, Timeout, Options, Header) ->
case get_payload(Socket, Timeout, Options, Header#header.content_length) of
{ok, Payload} ->
?DEBUG_LOG({encoded_response, Payload}),
case xmlrpc_decode:payload(Payload) of
{ok, {response, DecodedPayload}} when KeepAlive == false ->
?DEBUG_LOG({decoded_response, DecodedPayload}),
comm_close(Options, Socket),
case has_header_option(Options) of
true ->
{ok, {response, DecodedPayload, Header}};
_ ->
{ok, {response, DecodedPayload}}
end;
{ok, {response, DecodedPayload}} when KeepAlive == true,
Header#header.connection == close ->
?DEBUG_LOG({decoded_response, DecodedPayload}),
comm_close(Options, Socket),
case has_header_option(Options) of
true ->
{ok, Socket, {response, DecodedPayload, Header}};
_ ->
{ok, Socket, {response, DecodedPayload}}
end;
{ok, {response, DecodedPayload}} ->
?DEBUG_LOG({decoded_response, DecodedPayload}),
case has_header_option(Options) of
true ->
{ok, Socket, {response, DecodedPayload, Header}};
_ ->
{ok, Socket, {response, DecodedPayload}}
end;
{error, Reason} when KeepAlive == false ->
comm_close(Options, Socket),
{error, Reason};
{error, Reason} when KeepAlive == true,
Header#header.connection == close ->
comm_close(Options, Socket),
{error, Socket, Reason};
{error, Reason} ->
{error, Socket, Reason}
end;
{error, Reason} when KeepAlive == false ->
gen_tcp:close(Socket),
{error, Reason};
{error, Reason} when KeepAlive == true,
Header#header.connection == close ->
comm_close(Options, Socket),
{error, Socket, Reason};
{error, Reason} -> {error, Socket, Reason}
end.
handle_payload(Socket, KeepAlive, Timeout, Header) ->
case get_payload(Socket, Timeout,
Header#header.content_length)
of
{ok, Payload} ->
?DEBUG_LOG({encoded_response, Payload}),
case xmlrpc_decode:payload(Payload) of
{ok, DecodedPayload} when KeepAlive == false ->
?DEBUG_LOG({decoded_response, DecodedPayload}),
gen_tcp:close(Socket),
{ok, DecodedPayload};
{ok, DecodedPayload}
when KeepAlive == true,
Header#header.connection == close ->
?DEBUG_LOG({decoded_response, DecodedPayload}),
gen_tcp:close(Socket),
{ok, Socket, DecodedPayload};
{ok, DecodedPayload} ->
?DEBUG_LOG({decoded_response, DecodedPayload}),
{ok, Socket, DecodedPayload};
{error, Reason} when KeepAlive == false ->
gen_tcp:close(Socket), {error, Reason};
{error, Reason}
when KeepAlive == true,
Header#header.connection == close ->
gen_tcp:close(Socket), {error, Socket, Reason};
{error, Reason} -> {error, Socket, Reason}
end;
{error, Reason} when KeepAlive == false ->
gen_tcp:close(Socket), {error, Reason};
{error, Reason}
when KeepAlive == true,
Header#header.connection == close ->
gen_tcp:close(Socket), {error, Socket, Reason};
{error, Reason} -> {error, Socket, Reason}
end.
get_payload(Socket, Timeout, ContentLength) ->
inet:setopts(Socket, [binary, {packet, raw}]),
gen_tcp:recv(Socket, ContentLength, Timeout).
get_payload(Socket, Timeout, SslOption, ContentLength) ->
M = fetch_comm_module(SslOption),
apply(fetch_sets_module(SslOption), setopts, [Socket, [{packet, raw}]]),
apply(M, recv, [Socket, ContentLength, Timeout]).
%% Exported: start_link/{1,5,6}
start_link(Handler) ->
start_link(4567, 1000, 60000, Handler, undefined).
start_link(Handler) -> start_link(4567, 1000, 60000, Handler, undefined).
start_link(Port, MaxSessions, Timeout, Handler,
State) ->
start_link(all, Port, MaxSessions, Timeout, Handler,
State).
start_link(Port, MaxSessions, Timeout, Handler, State) ->
start_link(all, Port, MaxSessions, Timeout, Handler, State).
start_link(IP, Port, MaxSessions, Timeout, Handler,
State) ->
OptionList = [{active, false}, {reuseaddr, true}] ++
ip(IP),
SessionHandler = {xmlrpc_http, handler,
[Timeout, Handler, State]},
tcp_serv:start_link([Port, MaxSessions, OptionList,
SessionHandler]).
start_link(IP, Port, MaxSessions, Timeout, Handler, State) ->
OptionList = [{active, false}, {reuseaddr, true}] ++ ip(IP),
SessionHandler = {xmlrpc_http, handler, [Timeout, Handler, State]},
tcp_serv:start_link([Port, MaxSessions, OptionList, SessionHandler]).
ip(all) -> [];
ip(IP) when is_tuple(IP) -> [{ip, IP}].

41
src/xmlrpc.hrl Normal file
View File

@ -0,0 +1,41 @@
%% Copyright (C) 2003 Joakim Grebenö <jocke@gleipnir.com>.
%% All rights reserved.
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
%% are met:
%%
%% 1. Redistributions of source code must retain the above copyright
%% notice, this list of conditions and the following disclaimer.
%% 2. Redistributions in binary form must reproduce the above
%% copyright notice, this list of conditions and the following
%% disclaimer in the documentation and/or other materials provided
%% with the distribution.
%%
%% THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
%% OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
%% WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
%% ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
%% DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
%% DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
%% GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
%% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
%% WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
%% NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
%% SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-record(header, {
%% int()
content_length,
%% string()
content_type,
%% string()
user_agent,
%% close | undefined
connection,
%% string()
authorization,
%% list()
cookies
}).

259
src/xmlrpc_decode.erl
View File

@ -3,10 +3,10 @@
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
%% are met:
%% are met:
%%
%% 1. Redistributions of source code must retain the above copyright
%% notice, this list of conditions and the following disclaimer.
%% notice, this list of conditions and the following disclaimer.
%% 2. Redistributions in binary form must reproduce the above
%% copyright notice, this list of conditions and the following
%% disclaimer in the documentation and/or other materials provided
@ -25,217 +25,200 @@
%% SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-module(xmlrpc_decode).
-author('jocke@gleipnir.com').
-export([payload/1]).
-include("log.hrl").
-include_lib("xmerl/include/xmerl.hrl").
payload(Payload) ->
?DEBUG_LOG({scanning_payload, Payload}),
case xmerl_scan:string(Payload) of
{error, Reason} ->
?DEBUG_LOG({error_scanning, Payload, Reason}),
{error, Reason};
{E, _} ->
?DEBUG_LOG({decoding_element, E}),
case catch decode_element(E) of
{'EXIT', Reason} ->
?DEBUG_LOG({error_deconding, E, Reason}), exit(Reason);
Result ->
?DEBUG_LOG({result_deconding, E, Result}), Result
end
case catch xmerl_scan:string(Payload, [{encoding, latin1}]) of
{'EXIT', Reason} -> {error, Reason};
{E, _} ->
case catch decode_element(E) of
{'EXIT', Reason} -> {error, Reason};
Result -> Result
end
end.
decode_element(#xmlElement{name = methodCall} =
MethodCall)
when is_record(MethodCall, xmlElement) ->
{MethodName, Rest} = match_element([methodName],
MethodCall#xmlElement.content),
TextValue =
get_text_value(MethodName#xmlElement.content),
decode_element(#xmlElement{name = methodCall} = MethodCall)
when record(MethodCall, xmlElement) ->
{MethodName, Rest} =
match_element([methodName], MethodCall#xmlElement.content),
TextValue = get_text_value(MethodName#xmlElement.content),
case match_element(normal, [params], Rest) of
{error, {missing_element, _}} ->
{ok, {call, jlib:binary_to_atom(TextValue), []}};
{Params, _} ->
DecodedParams =
decode_params(Params#xmlElement.content),
{ok,
{call, jlib:binary_to_atom(TextValue), DecodedParams}}
{error, {missing_element, _}} ->
{ok, {call, list_to_atom(TextValue), []}};
{Params, _} ->
DecodedParams = decode_params(Params#xmlElement.content),
{ok, {call, list_to_atom(TextValue), DecodedParams}}
end;
decode_element(#xmlElement{name = methodResponse} =
MethodResponse)
when is_record(MethodResponse, xmlElement) ->
case match_element([fault, params],
MethodResponse#xmlElement.content)
of
{Fault, _} when Fault#xmlElement.name == fault ->
{Value, _} = match_element([value],
Fault#xmlElement.content),
case decode(Value#xmlElement.content) of
{struct, [{faultCode, Code}, {faultString, String}]}
when is_integer(Code) ->
case xmlrpc_util:is_string(String) of
yes -> {ok, {response, {fault, Code, String}}};
no -> {error, {bad_string, String}}
end;
_ -> {error, {bad_element, MethodResponse}}
end;
{Params, _} ->
case decode_params(Params#xmlElement.content) of
[DecodedParam] -> {ok, {response, [DecodedParam]}};
DecodedParams ->
{error, {to_many_params, DecodedParams}}
end
decode_element(#xmlElement{name = methodResponse} = MethodResponse)
when record(MethodResponse, xmlElement) ->
case match_element([fault, params], MethodResponse#xmlElement.content) of
{Fault, _} when Fault#xmlElement.name == fault ->
{Value, _} = match_element([value], Fault#xmlElement.content),
case decode(Value#xmlElement.content) of
{struct, [{faultCode, Code},
{faultString, String}]} when integer(Code) ->
case xmlrpc_util:is_string(String) of
yes -> {ok, {response, {fault, Code, String}}};
no -> {error, {bad_string, String}}
end;
{struct, [{faultString, String},
{faultCode, Code}]} when integer(Code) ->
%% This case has been found in java xmlrpc
case xmlrpc_util:is_string(String) of
yes -> {ok, {response, {fault, Code, String}}};
no -> {error, {bad_string, String}}
end;
_ ->
{error, {bad_element, MethodResponse}}
end;
{Params, _} ->
case decode_params(Params#xmlElement.content) of
[DecodedParam] -> {ok, {response, [DecodedParam]}};
DecodedParams -> {error, {to_many_params, DecodedParams}}
end
end;
decode_element(E) -> {error, {bad_element, E}}.
match_element(NameList, Content) ->
match_element(throw, NameList, Content).
match_element(NameList, Content) -> match_element(throw, NameList, Content).
match_element(Type, NameList, []) ->
return(Type, {error, {missing_element, NameList}});
match_element(Type, NameList, [E | Rest])
when is_record(E, xmlElement) ->
match_element(Type, NameList, [E|Rest]) when record(E, xmlElement) ->
case lists:member(E#xmlElement.name, NameList) of
true -> {E, Rest};
false ->
return(Type,
{error, {unexpected_element, E#xmlElement.name}})
true -> {E, Rest};
false -> return(Type, {error, {unexpected_element, E#xmlElement.name}})
end;
match_element(Type, NameList, [T | Rest])
when is_record(T, xmlText) ->
match_element(Type, NameList, [T|Rest]) when record(T, xmlText) ->
case only_whitespace(T#xmlText.value) of
yes -> match_element(Type, NameList, Rest);
no ->
return(Type,
{error, {unexpected_text, T#xmlText.value, NameList}})
yes -> match_element(Type, NameList, Rest);
no ->
return(Type, {error, {unexpected_text, T#xmlText.value, NameList}})
end.
return(throw, Result) -> throw(Result);
return(normal, Result) -> Result.
only_whitespace(<<>>) -> yes;
only_whitespace(<<$\s, Rest/binary>>) ->
only_whitespace(Rest);
only_whitespace(<<$\n, Rest/binary>>) ->
only_whitespace(Rest);
only_whitespace(<<$\t, Rest/binary>>) ->
only_whitespace(Rest);
only_whitespace([]) -> yes;
only_whitespace([$ |Rest]) -> only_whitespace(Rest);
only_whitespace([$\n|Rest]) -> only_whitespace(Rest);
only_whitespace([$\t|Rest]) -> only_whitespace(Rest);
only_whitespace(_) -> no.
get_text_value([]) -> <<>>;
get_text_value([T | Rest]) when is_record(T, xmlText) ->
<<(list_to_binary(T#xmlText.value))/binary, (get_text_value(Rest))/binary>>;
get_text_value([]) -> [];
get_text_value([T|Rest]) when record(T, xmlText) ->
T#xmlText.value++get_text_value(Rest);
get_text_value(_) -> throw({error, missing_text}).
decode_params([]) -> [];
decode_params(Content) ->
case match_element(normal, [param], Content) of
{error, {missing_element, _}} -> [];
{Param, Rest} ->
{Value, _} = match_element([value],
Param#xmlElement.content),
[decode(Value#xmlElement.content) | decode_params(Rest)]
{error, {missing_element, _}} -> [];
{Param, Rest} ->
{Value, _} = match_element([value], Param#xmlElement.content),
[decode(Value#xmlElement.content)|decode_params(Rest)]
end.
decode(Content) when is_list(Content) ->
decode(Content) when list(Content) ->
case get_value(Content) of
{text_value, TextValue} -> TextValue;
E -> decode(E)
{text_value, TextValue} -> TextValue;
E -> decode(E)
end;
decode(String) when is_record(String, xmlText) ->
String#xmlText.value;
decode(String) when record(String, xmlText) -> String#xmlText.value;
decode(Struct) when Struct#xmlElement.name == struct ->
{struct, decode_members(Struct#xmlElement.content)};
decode(Array) when Array#xmlElement.name == array ->
{Data, _} = match_element([data],
Array#xmlElement.content),
{Data, _} = match_element([data], Array#xmlElement.content),
{array, decode_values(Data#xmlElement.content)};
decode(Int)
when Int#xmlElement.name == int;
Int#xmlElement.name == i4 ->
decode(Int) when Int#xmlElement.name == int; Int#xmlElement.name == i4 ->
TextValue = get_text_value(Int#xmlElement.content),
make_integer(TextValue);
decode(Boolean)
when Boolean#xmlElement.name == boolean ->
decode(Boolean) when Boolean#xmlElement.name == boolean ->
case get_text_value(Boolean#xmlElement.content) of
<<"1">> -> true;
<<"0">> -> false;
TextValue ->
throw({error, {invalid_boolean, TextValue}})
"1" -> true;
"0" -> false;
TextValue -> throw({error, {invalid_boolean, TextValue}})
end;
decode(String) when String#xmlElement.name == string ->
get_text_value(String#xmlElement.content);
decode(Double) when Double#xmlElement.name == double ->
TextValue = get_text_value(Double#xmlElement.content),
make_double(TextValue);
decode(Date)
when Date#xmlElement.name == 'dateTime.iso8601' ->
decode(Date) when Date#xmlElement.name == 'dateTime.iso8601' ->
TextValue = get_text_value(Date#xmlElement.content),
{date, ensure_iso8601_date(TextValue)};
% {date, ensure_iso8601_date(TextValue)}; % FIXME
{date, TextValue};
decode(Base64) when Base64#xmlElement.name == base64 ->
TextValue = get_text_value(Base64#xmlElement.content),
{base64, ensure_base64(TextValue)};
% {base64, ensure_base64(TextValue)}; % FIXME
{base64, TextValue};
decode(Value) -> throw({error, {bad_value, Value}}).
get_value(Content) ->
case any_element(Content) of
false -> {text_value, get_text_value(Content)};
true -> get_element(Content)
false -> {text_value, get_text_value(Content)};
true -> get_element(Content)
end.
any_element([]) -> false;
any_element([E | _]) when is_record(E, xmlElement) -> true;
any_element([_ | Rest]) -> any_element(Rest).
any_element([E|_]) when record(E, xmlElement) -> true;
any_element([_|Rest]) -> any_element(Rest).
get_element([]) -> throw({error, missing_element});
get_element([E | _]) when is_record(E, xmlElement) -> E;
get_element([T | Rest]) when is_record(T, xmlText) ->
get_element([E|_]) when record(E, xmlElement) -> E;
get_element([T|Rest]) when record(T, xmlText) ->
case only_whitespace(T#xmlText.value) of
yes -> get_element(Rest);
no -> throw({error, {unexpected_text, T#xmlText.value}})
yes -> get_element(Rest);
no -> throw({error, {unexpected_text, T#xmlText.value}})
end.
decode_members(Content) ->
case match_element(normal, [member], Content) of
{error, {missing_element, _}} -> [];
{Member, Rest} ->
{Name, Rest2} = match_element([name],
Member#xmlElement.content),
TextValue = get_text_value(Name#xmlElement.content),
{Value, _} = match_element([value], Rest2),
[{jlib:binary_to_atom(TextValue),
decode(Value#xmlElement.content)}
| decode_members(Rest)]
{error, {missing_element, _}} -> [];
{Member, Rest} ->
{Name, Rest2} = match_element([name], Member#xmlElement.content),
TextValue = get_text_value(Name#xmlElement.content),
{Value, _} = match_element([value], Rest2),
[{list_to_atom(TextValue),
decode(Value#xmlElement.content)}|decode_members(Rest)]
end.
decode_values([]) -> [];
decode_values(Content) ->
case match_element(normal, [value], Content) of
{error, {missing_element, _}} -> [];
{Value, Rest} ->
[decode(Value#xmlElement.content) | decode_values(Rest)]
{error, {missing_element, _}} -> [];
{Value, Rest} ->
[decode(Value#xmlElement.content)|decode_values(Rest)]
end.
make_integer(Integer) ->
case catch jlib:binary_to_integer(Integer) of
{'EXIT', _Reason} ->
throw({error, {not_integer, Integer}});
Value -> Value
case catch list_to_integer(Integer) of
{'EXIT', _Reason} -> throw({error, {not_integer, Integer}});
Value -> Value
end.
make_double(Double) ->
case catch list_to_float(binary_to_list(Double)) of
{'EXIT', _} -> throw({error, {not_double, Double}});
Value -> Value
case catch list_to_float(Double) of
{'EXIT', _} ->
case catch list_to_integer(Double) of
{'EXIT', _} ->
throw({error, {not_double, Double}});
Value -> float(Value)
end;
Value -> Value
end.
ensure_iso8601_date(Date) ->
xmlrpc_util:is_iso8601_date(Date).
ensure_base64(Base64) ->
xmlrpc_util:is_base64(Base64).
% FIXME
%ensure_iso8601_date(Date) ->
% case xmlrpc_util:is_iso8601_date(Date) of
% no -> throw({error, {not_iso8601_date, Date}});
% yes -> Date
% end.
%
%ensure_base64(Base64) ->
% case xmlrpc_util:is_base64(Base64) of
% no -> throw({error, {not_base64, Base64}});
% yes -> Base64
% end.

184
src/xmlrpc_encode.erl
View File

@ -3,10 +3,10 @@
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
%% are met:
%% are met:
%%
%% 1. Redistributions of source code must retain the above copyright
%% notice, this list of conditions and the following disclaimer.
%% notice, this list of conditions and the following disclaimer.
%% 2. Redistributions in binary form must reproduce the above
%% copyright notice, this list of conditions and the following
%% disclaimer in the documentation and/or other materials provided
@ -25,103 +25,121 @@
%% SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-module(xmlrpc_encode).
-author('jocke@gleipnir.com').
-export([payload/1]).
%% Exported: payload/1
-type xmlrpc() :: number() | boolean() | binary() |
{base64, binary()} | {date, binary()} |
{array, [xmlrpc()]} | {struct, [{atom(), xmlrpc()}]}.
payload({call, Name, Params}) when atom(Name), list(Params) ->
case encode_params(Params) of
{error, Reason} -> {error, Reason};
EncodedParams ->
EncodedPayload =
["<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?><methodCall><methodName>",
atom_to_list(Name), "</methodName>", EncodedParams,
"</methodCall>"],
{ok, EncodedPayload}
end;
payload({response, {fault, Code, String}}) when integer(Code) ->
case xmlrpc_util:is_string(String) of
yes ->
EncodedPayload =
["<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?><methodResponse><fault>"
"<value><struct><member><name>faultCode</name><value><int>",
integer_to_list(Code), "</int></value></member><member><name>"
"faultString</name><value><string>", escape_string(String),
"</string></value></member></struct></value></fault>",
"</methodResponse>"],
{ok, EncodedPayload};
no -> {error, {bad_string, String}}
end;
payload({response, []} = Payload) ->
{ok, ["<?xml version=\"1.0\"?><methodResponse></methodResponse>"]};
payload({response, [Param]} = Payload) ->
case encode_params([Param]) of
{error, Reason} -> {error, Reason};
EncodedParam ->
{ok, ["<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?><methodResponse>", EncodedParam,
"</methodResponse>"]}
end;
payload(Payload) -> {error, {bad_payload, Payload}}.
-spec payload({call, atom(), [xmlrpc()]} |
{response, {fault, integer(), binary()} | [xmlrpc()]}) ->
binary().
encode_params(Params) -> encode_params(Params, []).
payload({call, Name, Params}) ->
<<"<?xml version=\"1.0\"?><methodCall><methodName>",
(jlib:atom_to_binary(Name))/binary,
"</methodName>",
(encode_params(Params))/binary,
"</methodCall>">>;
payload({response, {fault, Code, String}}) ->
<<"<?xml version=\"1.0\"?><methodResponse><fault"
"><value><struct><member><name>faultCode</name"
"><value><int>",
(jlib:integer_to_binary(Code))/binary,
"</int></value></member><member><name>faultStr"
"ing</name><value><string>",
(escape_string(String))/binary,
"</string></value></member></struct></value></"
"fault></methodResponse>">>;
payload({response, []}) ->
<<"<?xml version=\"1.0\"?><methodResponse></methodResponse>">>;
payload({response, [Param]}) ->
<<"<?xml version=\"1.0\"?><methodResponse>",
(encode_params([Param]))/binary,
"</methodResponse>">>.
encode_params(Params) -> encode_params(Params, <<>>).
encode_params([], <<>>) -> <<>>;
encode_params([], Acc) ->
<<"<params>", Acc/binary, "</params>">>;
encode_params([Param | Rest], Acc) ->
EncodedParam = encode(Param),
NewAcc = <<Acc/binary, "<param><value>",
EncodedParam/binary, "</value></param>">>,
encode_params(Rest, NewAcc).
encode_params([], []) -> [];
encode_params([], Acc) -> ["<params>", Acc, "</params>"];
encode_params([Param|Rest], Acc) ->
case encode(Param) of
{error, Reason} -> {error, Reason};
EncodedParam ->
NewAcc = Acc++["<param><value>", EncodedParam, "</value></param>"],
encode_params(Rest, NewAcc)
end.
encode({struct, Struct}) ->
Members = encode_members(Struct),
<<"<struct>", Members/binary, "</struct>">>;
encode({array, Array}) ->
Values = encode_values(Array),
<<"<array><data>", Values/binary, "</data></array>">>;
encode(Integer) when is_integer(Integer) ->
<<"<int>", (jlib:integer_to_binary(Integer))/binary, "</int>">>;
encode(true) -> <<"<boolean>1</boolean>">>; % duh!
encode(false) -> <<"<boolean>0</boolean>">>; % duh!
encode(Double) when is_float(Double) ->
list_to_binary(
[<<"<double>">>, io_lib:format("~p", [Double]),
<<"</double>">>]);
case encode_members(Struct) of
{error, Reason} -> {error, Reason};
Members -> ["<struct>", Members, "</struct>"]
end;
encode({array, Array}) when list(Array) ->
case encode_values(Array)of
{error, Reason} -> {error, Reason};
Values -> ["<array><data>", Values, "</data></array>"]
end;
encode(Integer) when integer(Integer) ->
["<int>", integer_to_list(Integer), "</int>"];
encode(true) -> "<boolean>1</boolean>"; % duh!
encode(false) -> "<boolean>0</boolean>"; % duh!
encode(Double) when float(Double) ->
["<double>", io_lib:format("~p", [Double]), "</double>"];
encode({date, Date}) ->
<<"<dateTime.iso8601>", Date/binary, "</dateTime.iso8601>">>;
case xmlrpc_util:is_iso8601_date(Date) of
yes -> ["<dateTime.iso8601>", Date, "</dateTime.iso8601>"];
no -> {error, {bad_date, Date}}
end;
encode({base64, Base64}) ->
<<"<base64>", Base64/binary, "</base64>">>;
case xmlrpc_util:is_base64(Base64) of
yes -> ["<base64>", Base64, "</base64>"];
no -> {error, {bad_base64, Base64}}
end;
encode(Value) ->
escape_string(Value).
case xmlrpc_util:is_string(Value) of
yes -> ["<string>", escape_string(Value), "</string>"];
no -> {error, {bad_value, Value}}
end.
escape_string(<<>>) -> <<>>;
escape_string(<<$<, Rest/binary>>) ->
<<"&lt;", (escape_string(Rest))/binary>>;
escape_string(<<$>, Rest/binary>>) ->
<<"&gt;", (escape_string(Rest))/binary>>;
escape_string(<<$&, Rest/binary>>) ->
<<"&amp;", (escape_string(Rest))/binary>>;
escape_string(<<C, Rest/binary>>) -> <<C, (escape_string(Rest))/binary>>.
escape_string([]) -> [];
escape_string([$<|Rest]) -> ["&lt;", escape_string(Rest)];
escape_string([$>|Rest]) -> ["&gt;", escape_string(Rest)];
escape_string([$&|Rest]) -> ["&amp;", escape_string(Rest)];
escape_string([C|Rest]) -> [C|escape_string(Rest)].
encode_members(Struct) -> encode_members(Struct, <<>>).
encode_members(Struct) -> encode_members(Struct, []).
encode_members([], Acc) -> Acc;
encode_members([{Name, Value} | Rest], Acc) ->
NewAcc = <<Acc/binary,
"<member><name>",
(jlib:atom_to_binary(Name))/binary,
"</name><value>",
(encode(Value))/binary,
"</value></member>">>,
encode_members(Rest, NewAcc).
encode_members([{Name, Value}|Rest], Acc) when atom(Name) ->
case encode(Value) of
{error, Reason} -> {error, Reason};
EncodedValue ->
NewAcc =
Acc++["<member><name>", atom_to_list(Name), "</name><value>",
EncodedValue, "</value></member>"],
encode_members(Rest, NewAcc)
end;
encode_members([{Name, Value}|Rest], Acc) -> {error, {invalid_name, Name}};
encode_members(UnknownMember, Acc) ->
{error, {unknown_member, UnknownMember}}.
encode_values(Array) -> encode_values(Array, <<>>).
encode_values(Array) -> encode_values(Array, []).
encode_values([], Acc) -> Acc;
encode_values([Value | Rest], Acc) ->
NewAcc = <<Acc/binary,
"<value>",
(encode(Value))/binary,
"</value>">>,
encode_values(Rest, NewAcc).
encode_values([Value|Rest], Acc) ->
case encode(Value) of
{error, Reason} -> {error, Reason};
EncodedValue ->
NewAcc = Acc++["<value>", EncodedValue, "</value>"],
encode_values(Rest, NewAcc)
end;
encode_values([{Name, Value}|Rest], Acc) -> {error, {invalid_name, Name}};
encode_values(UnknownMember, Acc) ->
{error, {unknown_member, UnknownMember}}.

314
src/xmlrpc_http.erl
View File

@ -3,10 +3,10 @@
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
%% are met:
%% are met:
%%
%% 1. Redistributions of source code must retain the above copyright
%% notice, this list of conditions and the following disclaimer.
%% notice, this list of conditions and the following disclaimer.
%% 2. Redistributions in binary form must reproduce the above
%% copyright notice, this list of conditions and the following
%% disclaimer in the documentation and/or other materials provided
@ -25,192 +25,206 @@
%% SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-module(xmlrpc_http).
-author('jocke@gleipnir.com').
-export([handler/4]).
-include("log.hrl").
-record(header,
{content_length :: non_neg_integer(),
content_type :: binary(),
user_agent :: binary(),
connection :: close}).
-include("xmlrpc.hrl").
%% Exported: handler/3
%% Exported: handler/4
handler(Socket, Timeout, Handler, State) ->
case parse_request(Socket, Timeout) of
{ok, Header} ->
?DEBUG_LOG({header, Header}),
handle_payload(Socket, Timeout, Handler, State, Header);
{status, StatusCode} ->
send(Socket, StatusCode),
handler(Socket, Timeout, Handler, State);
{error, Reason} -> {error, Reason}
{ok, Header} ->
?DEBUG_LOG({header, Header}),
handle_payload(Socket, Timeout, Handler, State, Header);
{status, StatusCode} ->
send(Socket, StatusCode),
handler(Socket, Timeout, Handler, State);
{error, Reason} -> {error, Reason}
end.
parse_request(Socket, Timeout) ->
inet:setopts(Socket, [{packet, line}]),
case gen_tcp:recv(Socket, 0, Timeout) of
{ok, RequestLine} ->
case str:tokens(RequestLine, <<" \r\n">>) of
[<<"POST">>, _, <<"HTTP/1.0">>] ->
?DEBUG_LOG({http_version, <<"1.0">>}),
parse_header(Socket, Timeout,
#header{connection = close});
[<<"POST">>, _, <<"HTTP/1.1">>] ->
?DEBUG_LOG({http_version, <<"1.1">>}),
parse_header(Socket, Timeout);
[_Method, _, <<"HTTP/1.1">>] -> {status, 501};
[<<"POST">>, _, _HTTPVersion] -> {status, 505};
_ -> {status, 400}
end;
{error, Reason} -> {error, Reason}
{ok, RequestLine} ->
case string:tokens(RequestLine, " \r\n") of
["POST", _, "HTTP/1.0"] ->
?DEBUG_LOG({http_version, "1.0"}),
parse_header(Socket, Timeout, #header{connection = close});
["POST", _, "HTTP/1.1"] ->
?DEBUG_LOG({http_version, "1.1"}),
parse_header(Socket, Timeout);
[_Method, _, "HTTP/1.1"] -> {status, 501};
["POST", _, _HTTPVersion] -> {status, 505};
_ -> {status, 400}
end;
{error, Reason} -> {error, Reason}
end.
parse_header(Socket, Timeout) ->
parse_header(Socket, Timeout, #header{}).
parse_header(Socket, Timeout) -> parse_header(Socket, Timeout, #header{}).
parse_header(Socket, Timeout, Header) ->
case gen_tcp:recv(Socket, 0, Timeout) of
{ok, <<"\r\n">>}
when Header#header.content_length == undefined ->
{status, 411};
{ok, <<"\r\n">>}
when Header#header.content_type == undefined ->
{status, 400};
{ok, <<"\r\n">>}
when Header#header.user_agent == undefined ->
{status, 400};
{ok, <<"\r\n">>} -> {ok, Header};
{ok, HeaderField} ->
case split_header_field(HeaderField) of
{<<"Content-", _, "ength:">>, ContentLength} ->
case catch jlib:binary_to_integer(ContentLength) of
N when is_integer(N), N>=0 ->
parse_header(Socket, Timeout,
Header#header{content_length = N});
_ -> {status, 400}
end;
{<<"Content-Type:">>, <<"text/xml">>} ->
parse_header(Socket, Timeout,
Header#header{content_type = <<"text/xml">>});
{<<"Content-Type:">>, <<"text/xml; charset=utf-8">>} ->
parse_header(Socket, Timeout,
Header#header{content_type =
<<"text/xml; charset=utf-8">>});
{<<"Content-Type:">>, _ContentType} -> {status, 415};
{<<"User-Agent:">>, UserAgent} ->
parse_header(Socket, Timeout,
Header#header{user_agent = UserAgent});
{<<"Connection:">>, <<"close">>} ->
parse_header(Socket, Timeout,
Header#header{connection = close});
{<<"Connection:">>, <<_, "eep-", _, "live">>} ->
parse_header(Socket, Timeout,
Header#header{connection = undefined});
_ ->
?DEBUG_LOG({skipped_header, HeaderField}),
parse_header(Socket, Timeout, Header)
end;
{error, Reason} -> {error, Reason}
{ok, "\r\n"} when Header#header.content_length == undefined ->
{status, 411};
{ok, "\r\n"} when Header#header.content_type == undefined ->
{status, 400};
{ok, "\r\n"} when Header#header.user_agent == undefined ->
{status, 400};
{ok, "\r\n"} -> {ok, Header};
{ok, HeaderField} ->
case split_header_field(HeaderField) of
{[$C,$o,$n,$t,$e,$n,$t,$-,_,$e,$n,$g,$t,$h,$:],
ContentLength} ->
case catch list_to_integer(ContentLength) of
N ->
parse_header(Socket, Timeout,
Header#header{content_length = N});
_ -> {status, 400}
end;
{"Content-Type:", "text/xml"} ->
parse_header(Socket, Timeout,
Header#header{content_type = "text/xml"});
{"Content-Type:", "text/xml; charset=utf-8"} ->
parse_header(Socket, Timeout,
Header#header{content_type = "text/xml; charset=utf-8"});
{"Content-Type:", _ContentType} -> {status, 415};
{"User-Agent:", UserAgent} ->
parse_header(Socket, Timeout,
Header#header{user_agent = UserAgent});
{"Connection:", "close"} ->
parse_header(Socket, Timeout,
Header#header{connection = close});
{"Connection:", [_,$e,$e,$p,$-,_,$l,$i,$v,$e]} ->
parse_header(Socket, Timeout,
Header#header{connection = undefined});
{"Authorization:", Authorization} ->
parse_header(Socket, Timeout,
Header#header{authorization = Authorization});
{"Cookie:", Cookie} ->
Cookies = [ Cookie | Header#header.cookies ],
parse_header(Socket, Timeout,
Header#header{cookies = Cookies});
_ ->
?DEBUG_LOG({skipped_header, HeaderField}),
parse_header(Socket, Timeout, Header)
end;
{error, Reason} -> {error, Reason}
end.
split_header_field(HeaderField) ->
split_header_field(binary_to_list(HeaderField), []).
split_header_field(HeaderField) -> split_header_field(HeaderField, []).
split_header_field([], Name) -> {list_to_binary(Name), <<"">>};
split_header_field([$\s | Rest], Name) ->
{list_to_binary(lists:reverse(Name)),
list_to_binary(Rest -- "\r\n")};
split_header_field([C | Rest], Name) ->
split_header_field(Rest, [C | Name]).
split_header_field([], Name) -> {Name, ""};
split_header_field([$ |Rest], Name) -> {lists:reverse(Name), Rest -- "\r\n"};
split_header_field([C|Rest], Name) -> split_header_field(Rest, [C|Name]).
handle_payload(Socket, Timeout, Handler, State,
#header{connection = Connection} = Header) ->
case get_payload(Socket, Timeout,
Header#header.content_length)
of
{ok, Payload} ->
?DEBUG_LOG({encoded_call, Payload}),
case xmlrpc_decode:payload(Payload) of
{ok, DecodedPayload} ->
?DEBUG_LOG({decoded_call, DecodedPayload}),
eval_payload(Socket, Timeout, Handler, State,
Connection, DecodedPayload);
{error, Reason} when Connection == close ->
?ERROR_LOG({xmlrpc_decode, payload, Payload, Reason}),
send(Socket, 400);
{error, Reason} ->
?ERROR_LOG({xmlrpc_decode, payload, Payload, Reason}),
send(Socket, 400),
handler(Socket, Timeout, Handler, State)
end;
{error, Reason} -> {error, Reason}
case get_payload(Socket, Timeout, Header#header.content_length) of
{ok, Payload} ->
?DEBUG_LOG({encoded_call, Payload}),
case xmlrpc_decode:payload(Payload) of
{ok, DecodedPayload} ->
?DEBUG_LOG({decoded_call, DecodedPayload}),
eval_payload(Socket, Timeout, Handler, State, Connection,
DecodedPayload, Header);
{error, Reason} when Connection == close ->
?ERROR_LOG({xmlrpc_decode, payload, Payload, Reason}),
send(Socket, 400);
{error, Reason} ->
?ERROR_LOG({xmlrpc_decode, payload, Payload, Reason}),
send(Socket, 400),
handler(Socket, Timeout, Handler, State)
end;
{error, Reason} -> {error, Reason}
end.
get_payload(Socket, Timeout, ContentLength) ->
inet:setopts(Socket, [binary, {packet, raw}]),
inet:setopts(Socket, [{packet, raw}]),
gen_tcp:recv(Socket, ContentLength, Timeout).
eval_payload(Socket, Timeout, {M, F} = Handler, State,
Connection, Payload) ->
case catch M:F(State, Payload) of
{'EXIT', Reason} when Connection == close ->
?ERROR_LOG({M, F, {'EXIT', Reason}}),
send(Socket, 500, <<"Connection: close\r\n">>);
{'EXIT', Reason} ->
?ERROR_LOG({M, F, {'EXIT', Reason}}),
send(Socket, 500),
handler(Socket, Timeout, Handler, State);
{error, Reason} when Connection == close ->
?ERROR_LOG({M, F, Reason}),
send(Socket, 500, <<"Connection: close\r\n">>);
{error, Reason} ->
?ERROR_LOG({M, F, Reason}),
send(Socket, 500),
handler(Socket, Timeout, Handler, State);
{false, ResponsePayload} ->
encode_send(Socket, 200, <<"Connection: close\r\n">>,
ResponsePayload);
{true, _NewTimeout, _NewState, ResponsePayload}
when Connection == close ->
encode_send(Socket, 200, <<"Connection: close\r\n">>,
ResponsePayload);
{true, NewTimeout, NewState, ResponsePayload} ->
encode_send(Socket, 200, <<"">>, ResponsePayload),
handler(Socket, NewTimeout, Handler, NewState)
%% Check whether module has defined new function
%% M:F(State, Payload, Header)
has_newcall(M, F) ->
erlang:function_exported(M, F, 3).
%% Handle module call
do_call({M, F} = _Handler, State, Payload, Header) ->
case has_newcall(M, F) of
true ->
M:F(State, Payload, Header);
false ->
M:F(State, Payload)
end.
eval_payload(Socket, Timeout, {M, F} = Handler, State, Connection, Payload, Header) ->
case catch do_call(Handler, State, Payload, Header) of
{'EXIT', Reason} when Connection == close ->
?ERROR_LOG({M, F, {'EXIT', Reason}}),
send(Socket, 500, "Connection: close\r\n");
{'EXIT', Reason} ->
?ERROR_LOG({M, F, {'EXIT', Reason}}),
send(Socket, 500),
handler(Socket, Timeout, Handler, State);
{error, Reason} when Connection == close ->
?ERROR_LOG({M, F, Reason}),
send(Socket, 500, "Connection: close\r\n");
{error, Reason} ->
?ERROR_LOG({M, F, Reason}),
send(Socket, 500),
handler(Socket, Timeout, Handler, State);
{false, ResponsePayload} ->
encode_send(Socket, 200, "Connection: close\r\n", ResponsePayload);
{false, ResponsePayload, ExtraHeaders} ->
encode_send(Socket, 200, [ExtraHeaders, "Connection: close\r\n"], ResponsePayload);
{true, _NewTimeout, _NewState, ResponsePayload} when
Connection == close ->
encode_send(Socket, 200, "Connection: close\r\n", ResponsePayload);
{true, NewTimeout, NewState, ResponsePayload} ->
encode_send(Socket, 200, "", ResponsePayload),
handler(Socket, NewTimeout, Handler, NewState);
{true, _NewTimeout, _NewState, ResponsePayload, ExtraHeaders} when
Connection == close ->
encode_send(Socket, 200, [ExtraHeaders, "Connection: close\r\n"], ResponsePayload);
{true, NewTimeout, NewState, ResponsePayload, ExtraHeaders} ->
encode_send(Socket, 200, ExtraHeaders, ResponsePayload),
handler(Socket, NewTimeout, Handler, NewState)
end.
encode_send(Socket, StatusCode, ExtraHeader, Payload) ->
?DEBUG_LOG({decoded_response, Payload}),
EncodedPayload = xmlrpc_encode:payload(Payload),
?DEBUG_LOG({encoded_response, EncodedPayload}),
send(Socket, StatusCode, ExtraHeader, EncodedPayload).
case xmlrpc_encode:payload(Payload) of
{ok, EncodedPayload} ->
?DEBUG_LOG({encoded_response, lists:flatten(EncodedPayload)}),
send(Socket, StatusCode, ExtraHeader, EncodedPayload);
{error, Reason} ->
?ERROR_LOG({xmlrpc_encode, payload, Payload, Reason}),
send(Socket, 500)
end.
send(Socket, StatusCode) ->
send(Socket, StatusCode, <<"">>, <<"">>).
send(Socket, StatusCode) -> send(Socket, StatusCode, "", "").
send(Socket, StatusCode, ExtraHeader) ->
send(Socket, StatusCode, ExtraHeader, <<"">>).
send(Socket, StatusCode, ExtraHeader, "").
send(Socket, StatusCode, ExtraHeader, Payload) ->
Response = [<<"HTTP/1.1 ">>,
jlib:integer_to_binary(StatusCode), <<" ">>,
reason_phrase(StatusCode), <<"\r\n">>,
<<"Content-Length: ">>,
jlib:integer_to_binary(byte_size(Payload)),
<<"\r\n">>, <<"Server: Erlang/1.13\r\n">>,
<<"Content-Type: text/xml\r\n">>, ExtraHeader,
<<"\r\n">>, Payload],
Response =
["HTTP/1.1 ", integer_to_list(StatusCode), " ",
reason_phrase(StatusCode), "\r\n",
"Content-Length: ", integer_to_list(lists:flatlength(Payload)),
"\r\n",
"Server: Erlang/1.13\r\n",
"Content-Type: text/xml\r\n",
ExtraHeader, "\r\n",
Payload],
gen_tcp:send(Socket, Response).
reason_phrase(200) -> <<"OK">>;
reason_phrase(400) -> <<"Bad Request">>;
reason_phrase(411) -> <<"Length required">>;
reason_phrase(415) -> <<"Unsupported Media Type">>;
reason_phrase(500) -> <<"Internal Server Error">>;
reason_phrase(501) -> <<"Not Implemented">>;
reason_phrase(505) -> <<"HTTP Version not supported">>.
reason_phrase(200) -> "OK";
reason_phrase(400) -> "Bad Request";
reason_phrase(411) -> "Length required";
reason_phrase(415) -> "Unsupported Media Type";
reason_phrase(500) -> "Internal Server Error";
reason_phrase(501) -> "Not Implemented";
reason_phrase(505) -> "HTTP Version not supported".

17
src/xmlrpc_util.erl
View File

@ -3,10 +3,10 @@
%%
%% Redistribution and use in source and binary forms, with or without
%% modification, are permitted provided that the following conditions
%% are met:
%% are met:
%%
%% 1. Redistributions of source code must retain the above copyright
%% notice, this list of conditions and the following disclaimer.
%% notice, this list of conditions and the following disclaimer.
%% 2. Redistributions in binary form must reproduce the above
%% copyright notice, this list of conditions and the following
%% disclaimer in the documentation and/or other materials provided
@ -25,18 +25,13 @@
%% SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-module(xmlrpc_util).
-author('jocke@gleipnir.com').
-export([is_string/1, is_iso8601_date/1, is_base64/1]).
is_string(String) when is_binary(String) -> yes;
is_string([C|Rest]) when C >= 0, C =< 255 -> is_string(Rest);
is_string([]) -> yes;
is_string(_) -> no.
-spec is_iso8601_date(binary()) -> yes.
is_iso8601_date(_) -> yes. % FIXME
is_iso8601_date(_) -> yes.
-spec is_base64(binary()) -> yes.
is_base64(_) -> yes.
is_base64(_) -> yes. % FIXME