xmpp.chapril.org-ejabberd/src/jlib.erl

%%%----------------------------------------------------------------------
%%% File    : jlib.erl
%%% Author  : Alexey Shchepin <alexey@process-one.net>
%%% Purpose : General XMPP library.
%%% Created : 23 Nov 2002 by Alexey Shchepin <alexey@process-one.net>
%%%
%%%
%%% ejabberd, Copyright (C) 2002-2008   Process-one
%%%
%%% This program is free software; you can redistribute it and/or
%%% modify it under the terms of the GNU General Public License as
%%% published by the Free Software Foundation; either version 2 of the
%%% License, or (at your option) any later version.
%%%
%%% This program is distributed in the hope that it will be useful,
%%% but WITHOUT ANY WARRANTY; without even the implied warranty of
%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
%%% General Public License for more details.
%%%                         
%%% You should have received a copy of the GNU General Public License
%%% along with this program; if not, write to the Free Software
%%% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
%%% 02111-1307 USA
%%%
%%%----------------------------------------------------------------------

-module(jlib).
-author('alexey@process-one.net').

-export([make_result_iq_reply/1,
	 make_error_reply/3,
	 make_error_reply/2,
	 make_error_element/2,
	 make_correct_from_to_attrs/3,
	 replace_from_to_attrs/3,
	 replace_from_to/3,
	 remove_attr/2,
	 make_jid/3,
	 make_jid/1,
	 string_to_jid/1,
	 jid_to_string/1,
	 is_nodename/1,
	 tolower/1,
	 nodeprep/1,
	 nameprep/1,
	 resourceprep/1,
	 jid_tolower/1,
	 jid_remove_resource/1,
	 jid_replace_resource/2,
	 get_iq_namespace/1,
	 iq_query_info/1,
	 iq_query_or_response_info/1,
	 is_iq_request_type/1,
	 iq_to_xml/1,
	 parse_xdata_submit/1,
	 timestamp_to_iso/1,
	 timestamp_to_xml/1,
	 now_to_utc_string/1,
	 now_to_local_string/1,
	 datetime_string_to_timestamp/1,
	 decode_base64/1,
	 encode_base64/1]).

-include("jlib.hrl").

%send_iq(From, To, ID, SubTags) ->
%    ok.

make_result_iq_reply({xmlelement, Name, Attrs, SubTags}) ->
    NewAttrs = make_result_iq_reply_attrs(Attrs),
    {xmlelement, Name, NewAttrs, SubTags}.

make_result_iq_reply_attrs(Attrs) ->
    To = xml:get_attr("to", Attrs),
    From = xml:get_attr("from", Attrs),
    Attrs1 = lists:keydelete("to", 1, Attrs),
    Attrs2 = lists:keydelete("from", 1, Attrs1),
    Attrs3 = case To of
		 {value, ToVal} ->
		      [{"from", ToVal} | Attrs2];
		 _ ->
		     Attrs2
	     end,
    Attrs4 = case From of
		 {value, FromVal} ->
		      [{"to", FromVal} | Attrs3];
		 _ ->
		     Attrs3
	     end,
    Attrs5 = lists:keydelete("type", 1, Attrs4),
    Attrs6 = [{"type", "result"} | Attrs5],
    Attrs6.

make_error_reply({xmlelement, Name, Attrs, SubTags}, Code, Desc) ->
    NewAttrs = make_error_reply_attrs(Attrs),
    {xmlelement, Name, NewAttrs, SubTags ++ [{xmlelement, "error",
					      [{"code", Code}],
					      [{xmlcdata, Desc}]}]}.

make_error_reply({xmlelement, Name, Attrs, SubTags}, Error) ->
    NewAttrs = make_error_reply_attrs(Attrs),
    {xmlelement, Name, NewAttrs, SubTags ++ [Error]}.

make_error_reply_attrs(Attrs) ->
    To = xml:get_attr("to", Attrs),
    From = xml:get_attr("from", Attrs),
    Attrs1 = lists:keydelete("to", 1, Attrs),
    Attrs2 = lists:keydelete("from", 1, Attrs1),
    Attrs3 = case To of
		 {value, ToVal} ->
		      [{"from", ToVal} | Attrs2];
		 _ ->
		     Attrs2
	     end,
    Attrs4 = case From of
		 {value, FromVal} ->
		      [{"to", FromVal} | Attrs3];
		 _ ->
		     Attrs3
	     end,
    Attrs5 = lists:keydelete("type", 1, Attrs4),
    Attrs6 = [{"type", "error"} | Attrs5],
    Attrs6.

make_error_element(Code, Desc) ->
    {xmlelement, "error",
     [{"code", Code}],
     [{xmlcdata, Desc}]}.

make_correct_from_to_attrs(From, To, Attrs) ->
    Attrs1 = lists:keydelete("from", 1, Attrs),
    Attrs2 = case xml:get_attr("to", Attrs) of
		 {value, _} ->
		     Attrs1;
		 _ ->
		     [{"to", To} | Attrs1]
	     end,
    Attrs3 = [{"from", From} | Attrs2],
    Attrs3.


replace_from_to_attrs(From, To, Attrs) ->
    Attrs1 = lists:keydelete("to", 1, Attrs),
    Attrs2 = lists:keydelete("from", 1, Attrs1),
    Attrs3 = [{"to", To} | Attrs2],
    Attrs4 = [{"from", From} | Attrs3],
    Attrs4.

replace_from_to(From, To, {xmlelement, Name, Attrs, Els}) ->
    NewAttrs = replace_from_to_attrs(jlib:jid_to_string(From),
				     jlib:jid_to_string(To),
				     Attrs),
    {xmlelement, Name, NewAttrs, Els}.


remove_attr(Attr, {xmlelement, Name, Attrs, Els}) ->
    NewAttrs = lists:keydelete(Attr, 1, Attrs),
    {xmlelement, Name, NewAttrs, Els}.


make_jid(User, Server, Resource) ->
    case nodeprep(User) of
	error -> error;
	LUser ->
	    case nameprep(Server) of
		error -> error;
		LServer ->
		    case resourceprep(Resource) of
			error -> error;
			LResource ->
			    #jid{user = User,
				 server = Server,
				 resource = Resource,
				 luser = LUser,
				 lserver = LServer,
				 lresource = LResource}
		    end
	    end
    end.

make_jid({User, Server, Resource}) ->
    make_jid(User, Server, Resource).

string_to_jid(J) ->
    string_to_jid1(J, "").

string_to_jid1([$@ | _J], "") ->
    error;
string_to_jid1([$@ | J], N) ->
    string_to_jid2(J, lists:reverse(N), "");
string_to_jid1([$/ | _J], "") ->
    error;
string_to_jid1([$/ | J], N) ->
    string_to_jid3(J, "", lists:reverse(N), "");
string_to_jid1([C | J], N) ->
    string_to_jid1(J, [C | N]);
string_to_jid1([], "") ->
    error;
string_to_jid1([], N) ->
    make_jid("", lists:reverse(N), "").

%% Only one "@" is admitted per JID
string_to_jid2([$@ | _J], _N, _S) ->
    error;
string_to_jid2([$/ | _J], _N, "") ->
    error;
string_to_jid2([$/ | J], N, S) ->
    string_to_jid3(J, N, lists:reverse(S), "");
string_to_jid2([C | J], N, S) ->
    string_to_jid2(J, N, [C | S]);
string_to_jid2([], _N, "") ->
    error;
string_to_jid2([], N, S) ->
    make_jid(N, lists:reverse(S), "").

string_to_jid3([C | J], N, S, R) ->
    string_to_jid3(J, N, S, [C | R]);
string_to_jid3([], N, S, R) ->
    make_jid(N, S, lists:reverse(R)).

jid_to_string(#jid{user = User, server = Server, resource = Resource}) ->
    jid_to_string({User, Server, Resource});
jid_to_string({Node, Server, Resource}) ->
    S1 = case Node of
	     "" ->
		 "";
	     _ ->
		 Node ++ "@"
	 end,
    S2 = S1 ++ Server,
    S3 = case Resource of
	     "" ->
		 S2;
	     _ ->
		 S2 ++ "/" ++ Resource
	 end,
    S3.


is_nodename([]) ->
    false;
is_nodename(J) ->
    nodeprep(J) /= error.


%tolower_c(C) when C >= $A, C =< $Z ->
%    C + 32;
%tolower_c(C) ->
%    C.

-define(LOWER(Char),
        if
            Char >= $A, Char =< $Z ->
                Char + 32;
            true ->
                Char
        end).

%tolower(S) ->
%    lists:map(fun tolower_c/1, S).

%tolower(S) ->
%    [?LOWER(Char) || Char <- S].

% Not tail-recursive but it seems works faster than variants above
tolower([C | Cs]) ->
    if
	C >= $A, C =< $Z ->
	    [C + 32 | tolower(Cs)];
	true ->
	    [C | tolower(Cs)]
    end;
tolower([]) ->
    [].

%tolower([C | Cs]) when C >= $A, C =< $Z ->
%    [C + 32 | tolower(Cs)];
%tolower([C | Cs]) ->
%    [C | tolower(Cs)];
%tolower([]) ->
%    [].


nodeprep(S) when length(S) < 1024 ->
    R = stringprep:nodeprep(S),
    if
	length(R) < 1024 -> R;
	true -> error
    end;
nodeprep(_) ->
    error.

nameprep(S) when length(S) < 1024 ->
    R = stringprep:nameprep(S),
    if
	length(R) < 1024 -> R;
	true -> error
    end;
nameprep(_) ->
    error.

resourceprep(S) when length(S) < 1024 ->
    R = stringprep:resourceprep(S),
    if
	length(R) < 1024 -> R;
	true -> error
    end;
resourceprep(_) ->
    error.


jid_tolower(#jid{luser = U, lserver = S, lresource = R}) ->
    {U, S, R};
jid_tolower({U, S, R}) ->
    case nodeprep(U) of
	error -> error;
	LUser ->
	    case nameprep(S) of
		error -> error;
		LServer ->
		    case resourceprep(R) of
			error -> error;
			LResource ->
			    {LUser, LServer, LResource}
		    end
	    end
    end.

jid_remove_resource(#jid{} = JID) ->
    JID#jid{resource = "", lresource = ""};
jid_remove_resource({U, S, _R}) ->
    {U, S, ""}.

jid_replace_resource(JID, Resource) ->
    case resourceprep(Resource) of
	error -> error;
	LResource ->
	    JID#jid{resource = Resource, lresource = LResource}
    end.


get_iq_namespace({xmlelement, Name, _Attrs, Els}) when Name == "iq" ->
    case xml:remove_cdata(Els) of
	[{xmlelement, _Name2, Attrs2, _Els2}] ->
	    xml:get_attr_s("xmlns", Attrs2);
	_ ->
	    ""
    end;
get_iq_namespace(_) ->
    "".

iq_query_info(El) ->
    iq_info_internal(El, request).

iq_query_or_response_info(El) ->
    iq_info_internal(El, any).

iq_info_internal({xmlelement, Name, Attrs, Els}, Filter) when Name == "iq" ->
    %% Filter is either request or any.  If it is request, any replies
    %% are converted to the atom reply.
    ID = xml:get_attr_s("id", Attrs),
    Type = xml:get_attr_s("type", Attrs),
    Lang = xml:get_attr_s("xml:lang", Attrs),
    {Type1, Class} = case Type of
			 "set" -> {set, request};
			 "get" -> {get, request};
			 "result" -> {result, reply};
			 "error" -> {error, reply};
			 _ -> {invalid, invalid}
	    end,
    if
	Type1 == invalid ->
	    invalid;
	Class == request; Filter == any ->
	    %% The iq record is a bit strange.  The sub_el field is an
	    %% XML tuple for requests, but a list of XML tuples for
	    %% responses.
	    FilteredEls = xml:remove_cdata(Els),
	    {XMLNS, SubEl} =
		case {Class, FilteredEls} of
		    {request, [{xmlelement, _Name2, Attrs2, _Els2}]} ->
			{xml:get_attr_s("xmlns", Attrs2),
			 hd(FilteredEls)};
		    {reply, _} ->
			%% Find the namespace of the first non-error
			%% element, if there is one.
			NonErrorEls = [El || 
					  {xmlelement, SubName, _, _} = El
					      <- FilteredEls, 
					  SubName /= "error"],
			{case NonErrorEls of
			     [NonErrorEl] -> xml:get_tag_attr_s("xmlns", NonErrorEl);
			     _ -> invalid
			 end,
			 FilteredEls};
		    _ ->
			{invalid, invalid}
		end,
	    if XMLNS == "", Class == request ->
		    invalid;
	       true ->
			    #iq{id = ID,
				type = Type1,
				xmlns = XMLNS,
				lang = Lang,
			sub_el = SubEl}
		    end;
	Class == reply, Filter /= any ->
	    reply
    end;
iq_info_internal(_, _) ->
    not_iq.

is_iq_request_type(set) -> true;
is_iq_request_type(get) -> true;
is_iq_request_type(_) -> false.

iq_type_to_string(set) -> "set";
iq_type_to_string(get) -> "get";
iq_type_to_string(result) -> "result";
iq_type_to_string(error) -> "error";
iq_type_to_string(_) -> invalid.


iq_to_xml(#iq{id = ID, type = Type, sub_el = SubEl}) ->
    if
	ID /= "" ->
	    {xmlelement, "iq",
	     [{"id", ID}, {"type", iq_type_to_string(Type)}], SubEl};
	true ->
	    {xmlelement, "iq",
	     [{"type", iq_type_to_string(Type)}], SubEl}
    end.


parse_xdata_submit(El) ->
    {xmlelement, _Name, Attrs, Els} = El,
    case xml:get_attr_s("type", Attrs) of
	"submit" ->
	    lists:reverse(parse_xdata_fields(Els, []));
	_ ->
	    invalid
    end.

parse_xdata_fields([], Res) ->
    Res;
parse_xdata_fields([{xmlelement, Name, Attrs, SubEls} | Els], Res) ->
    case Name of
	"field" ->
	    case xml:get_attr_s("var", Attrs) of
		"" ->
		    parse_xdata_fields(Els, Res);
		Var ->
		    Field =
			{Var, lists:reverse(parse_xdata_values(SubEls, []))},
		    parse_xdata_fields(Els, [Field | Res])
	    end;
	_ ->
	    parse_xdata_fields(Els, Res)
    end;
parse_xdata_fields([_ | Els], Res) ->
    parse_xdata_fields(Els, Res).

parse_xdata_values([], Res) ->
    Res;
parse_xdata_values([{xmlelement, Name, _Attrs, SubEls} | Els], Res) ->
    case Name of
	"value" ->
	    Val = xml:get_cdata(SubEls),
	    parse_xdata_values(Els, [Val | Res]);
	_ ->
	    parse_xdata_values(Els, Res)
    end;
parse_xdata_values([_ | Els], Res) ->
    parse_xdata_values(Els, Res).


timestamp_to_iso({{Year, Month, Day}, {Hour, Minute, Second}}) ->
    lists:flatten(
      io_lib:format("~4..0w~2..0w~2..0wT~2..0w:~2..0w:~2..0w",
		    [Year, Month, Day, Hour, Minute, Second])).

timestamp_to_xml({{Year, Month, Day}, {Hour, Minute, Second}}) ->
    {xmlelement, "x",
     [{"xmlns", ?NS_DELAY},
      {"stamp", lists:flatten(
		  io_lib:format("~4..0w~2..0w~2..0wT~2..0w:~2..0w:~2..0w",
				[Year, Month, Day, Hour, Minute, Second]))}],
     []}.

now_to_utc_string({MegaSecs, Secs, MicroSecs}) ->
    {{Year, Month, Day}, {Hour, Minute, Second}} =
	calendar:now_to_universal_time({MegaSecs, Secs, MicroSecs}),
    lists:flatten(
      io_lib:format("~4..0w-~2..0w-~2..0wT~2..0w:~2..0w:~2..0w.~6..0wZ",
		    [Year, Month, Day, Hour, Minute, Second, MicroSecs])).

now_to_local_string({MegaSecs, Secs, MicroSecs}) ->
    LocalTime = calendar:now_to_local_time({MegaSecs, Secs, MicroSecs}),
    UTCTime = calendar:now_to_universal_time({MegaSecs, Secs, MicroSecs}),
    Seconds = calendar:datetime_to_gregorian_seconds(LocalTime) -
            calendar:datetime_to_gregorian_seconds(UTCTime),
    {{H, M, _}, Sign} = if
			    Seconds < 0 ->
				{calendar:seconds_to_time(-Seconds), "-"};
			    true ->
				{calendar:seconds_to_time(Seconds), "+"}
    end,
    {{Year, Month, Day}, {Hour, Minute, Second}} = LocalTime,
    lists:flatten(
      io_lib:format("~4..0w-~2..0w-~2..0wT~2..0w:~2..0w:~2..0w.~6..0w~s~2..0w:~2..0w",
		    [Year, Month, Day, Hour, Minute, Second, MicroSecs, Sign, H, M])).


% yyyy-mm-ddThh:mm:ss[.sss]{Z|{+|-}hh:mm} -> {MegaSecs, Secs, MicroSecs}
datetime_string_to_timestamp(TimeStr) ->
    case catch parse_datetime(TimeStr) of
	{'EXIT', _Err} ->
	    undefined;
	TimeStamp ->
	    TimeStamp
    end.

parse_datetime(TimeStr) ->
    [Date, Time] = string:tokens(TimeStr, "T"),
    D = parse_date(Date),
    {T, MS, TZH, TZM} = parse_time(Time),
    S = calendar:datetime_to_gregorian_seconds({D, T}),
    S1 = calendar:datetime_to_gregorian_seconds({{1970, 1, 1}, {0, 0, 0}}),
    Seconds = (S - S1) - TZH * 60 * 60 - TZM * 60,
    {Seconds div 1000000, Seconds rem 1000000, MS}.

% yyyy-mm-dd
parse_date(Date) ->
    [Y, M, D] = string:tokens(Date, "-"),
    Date1 = {list_to_integer(Y), list_to_integer(M), list_to_integer(D)},
    case calendar:valid_date(Date1) of
	true ->
	    Date1;
	_ ->
	    false
    end.

% hh:mm:ss[.sss]TZD
parse_time(Time) ->
    case string:str(Time, "Z") of
	0 ->
	    parse_time_with_timezone(Time);
	_ ->
	    [T | _] = string:tokens(Time, "Z"),
	    {TT, MS} = parse_time1(T),
	    {TT, MS, 0, 0}
    end.

parse_time_with_timezone(Time) ->
    case string:str(Time, "+") of
	0 ->
	    case string:str(Time, "-") of
		0 ->
		    false;
		_ ->
		    parse_time_with_timezone(Time, "-")
	    end;
	_ ->
	    parse_time_with_timezone(Time, "+")
    end.

parse_time_with_timezone(Time, Delim) ->
    [T, TZ] = string:tokens(Time, Delim),
    {TZH, TZM} = parse_timezone(TZ),
    {TT, MS} = parse_time1(T),
    case Delim of
	"-" ->
	    {TT, MS, -TZH, -TZM};
	"+" ->
	    {TT, MS, TZH, TZM}
    end.

parse_timezone(TZ) ->
    [H, M] = string:tokens(TZ, ":"),
    {[H1, M1], true} = check_list([{H, 12}, {M, 60}]),
    {H1, M1}.

parse_time1(Time) ->
    [HMS | T] =  string:tokens(Time, "."),
    MS = case T of
	     [] ->
		 0;
	     [Val] ->
		 list_to_integer(string:left(Val, 6, $0))
	 end,
    [H, M, S] = string:tokens(HMS, ":"),
    {[H1, M1, S1], true} = check_list([{H, 24}, {M, 60}, {S, 60}]),
    {{H1, M1, S1}, MS}.

check_list(List) ->
    lists:mapfoldl(
      fun({L, N}, B)->
	  V = list_to_integer(L),
	  if
	      (V >= 0) and (V =< N) ->
		  {V, B};
	      true ->
		  {false, false}
	  end
      end, true, List).


%
% Base64 stuff (based on httpd_util.erl)
%

decode_base64(S) ->
    decode1_base64([C || C <- S,
			 C /= $ ,
			 C /= $\t,
			 C /= $\n,
			 C /= $\r]).

decode1_base64([]) ->
    [];
decode1_base64([Sextet1,Sextet2,$=,$=|Rest]) ->
    Bits2x6=
	(d(Sextet1) bsl 18) bor
	(d(Sextet2) bsl 12),
    Octet1=Bits2x6 bsr 16,
    [Octet1|decode_base64(Rest)];
decode1_base64([Sextet1,Sextet2,Sextet3,$=|Rest]) ->
    Bits3x6=
	(d(Sextet1) bsl 18) bor
	(d(Sextet2) bsl 12) bor
	(d(Sextet3) bsl 6),
    Octet1=Bits3x6 bsr 16,
    Octet2=(Bits3x6 bsr 8) band 16#ff,
    [Octet1,Octet2|decode_base64(Rest)];
decode1_base64([Sextet1,Sextet2,Sextet3,Sextet4|Rest]) ->
    Bits4x6=
	(d(Sextet1) bsl 18) bor
	(d(Sextet2) bsl 12) bor
	(d(Sextet3) bsl 6) bor
	d(Sextet4),
    Octet1=Bits4x6 bsr 16,
    Octet2=(Bits4x6 bsr 8) band 16#ff,
    Octet3=Bits4x6 band 16#ff,
    [Octet1,Octet2,Octet3|decode_base64(Rest)];
decode1_base64(_CatchAll) ->
    "".

d(X) when X >= $A, X =<$Z ->
    X-65;
d(X) when X >= $a, X =<$z ->
    X-71;
d(X) when X >= $0, X =<$9 ->
    X+4;
d($+) -> 62;
d($/) -> 63;
d(_) -> 63.


encode_base64([]) ->
    [];
encode_base64([A]) ->
    [e(A bsr 2), e((A band 3) bsl 4), $=, $=];
encode_base64([A,B]) ->
    [e(A bsr 2), e(((A band 3) bsl 4) bor (B bsr 4)), e((B band 15) bsl 2), $=];
encode_base64([A,B,C|Ls]) ->
    encode_base64_do(A,B,C, Ls).
encode_base64_do(A,B,C, Rest) ->
    BB = (A bsl 16) bor (B bsl 8) bor C,
    [e(BB bsr 18), e((BB bsr 12) band 63), 
     e((BB bsr 6) band 63), e(BB band 63)|encode_base64(Rest)].

e(X) when X >= 0, X < 26 -> X+65;
e(X) when X>25, X<52 ->     X+71;
e(X) when X>51, X<62 ->     X-4;
e(62) ->                    $+;
e(63) ->                    $/;
e(X) ->                     exit({bad_encode_base64_token, X}).