* src/idna.erl: Support for IDNA (RFC3490)

* src/ejabberd_s2s_out.erl: Likewise

* src/xml.erl: element_to_string/1 and crypt/1 now returns deep
list
* src/mod_muc/mod_muc_room.erl (add_message_to_history): Replaced
string:len with lists:flatlength

SVN Revision: 222

ChangeLog

@@ -1,3 +1,15 @@
+2004-04-10  Alexey Shchepin  <alexey@sevcom.net>
+
+	* src/idna.erl: Support for IDNA (RFC3490)
+	* src/ejabberd_s2s_out.erl: Likewise
+
+2004-04-03  Alexey Shchepin  <alexey@sevcom.net>
+
+	* src/xml.erl: element_to_string/1 and crypt/1 now returns deep
+	list
+	* src/mod_muc/mod_muc_room.erl (add_message_to_history): Replaced
+	string:len with lists:flatlength
+
 2004-03-21  Alexey Shchepin  <alexey@sevcom.net>
 
 	* (all): Updated win32 stuff (thanks to Sergei Golovan)

src/ejabberd_s2s_out.erl

@@ -108,14 +108,18 @@ init([From, Server, Type]) ->
 %%----------------------------------------------------------------------
 open_socket(init, StateData) ->
     {Addr, Port} = get_addr_port(StateData#state.server),
-    ?DEBUG("s2s_out: connecting to ~s:~p~n", [Addr, Port]),
+    Res = case idna:domain_utf8_to_ascii(Addr) of
-    Res = case gen_tcp:connect(Addr, Port,
+	      false -> {error, badarg};
-			       [binary, {packet, 0}]) of
+	      ASCIIAddr ->
-	      {ok, _Socket} = R -> R;
+		  ?DEBUG("s2s_out: connecting to ~s:~p~n", [ASCIIAddr, Port]),
-	      {error, Reason1} ->
+		  case gen_tcp:connect(ASCIIAddr, Port,
-		  ?DEBUG("s2s_out: connect return ~p~n", [Reason1]),
+				       [binary, {packet, 0}]) of
-		  catch gen_tcp:connect(Addr, Port,
+		      {ok, _Socket} = R -> R;
-					[binary, {packet, 0}, inet6])
+		      {error, Reason1} ->
+			  ?DEBUG("s2s_out: connect return ~p~n", [Reason1]),
+			  catch gen_tcp:connect(Addr, Port,
+						[binary, {packet, 0}, inet6])
+		  end
 	  end,
     case Res of
 	{ok, Socket} ->

src/idna.erl

@@ -0,0 +1,179 @@
+%%%----------------------------------------------------------------------
+%%% File    : idna.erl
+%%% Author  : Alexey Shchepin <alexey@sevcom.net>
+%%% Purpose : Support for IDNA (RFC3490)
+%%% Created : 10 Apr 2004 by Alexey Shchepin <alexey@sevcom.net>
+%%% Id      : $Id$
+%%%----------------------------------------------------------------------
+
+-module(idna).
+-author('alexey@sevcom.net').
+-vsn('$Revision$ ').
+
+%-compile(export_all).
+-export([domain_utf8_to_ascii/1,
+	 domain_ucs2_to_ascii/1]).
+
+
+domain_utf8_to_ascii(Domain) ->
+    domain_ucs2_to_ascii(utf8_to_ucs2(Domain)).
+
+utf8_to_ucs2(S) ->
+    utf8_to_ucs2(S, "").
+
+utf8_to_ucs2([], R) ->
+    lists:reverse(R);
+utf8_to_ucs2([C | S], R) when C < 16#80 ->
+    utf8_to_ucs2(S, [C | R]);
+utf8_to_ucs2([C1, C2 | S], R) when C1 < 16#E0 ->
+    utf8_to_ucs2(S, [((C1 band 16#1F) bsl 6) bor
+		      (C2 band 16#3F) | R]);
+utf8_to_ucs2([C1, C2, C3 | S], R) when C1 < 16#F0 ->
+    utf8_to_ucs2(S, [((C1 band 16#0F) bsl 12) bor
+		      ((C2 band 16#3F) bsl 6) bor
+		      (C3 band 16#3F) | R]).
+
+
+domain_ucs2_to_ascii(Domain) ->
+    case catch domain_ucs2_to_ascii1(Domain) of
+	{'EXIT', _Reason} ->
+	    false;
+	Res ->
+	    Res
+    end.
+
+domain_ucs2_to_ascii1(Domain) ->
+    Parts = string:tokens(Domain, [16#002E, 16#3002, 16#FF0E, 16#FF61]),
+    ASCIIParts = lists:map(fun(P) ->
+				   to_ascii(P)
+			   end, Parts),
+    string:strip(lists:flatmap(fun(P) -> [$. | P] end, ASCIIParts),
+		 left, $.).
+
+% Domain names are already nameprep'ed in ejabberd, so we skiping this step
+to_ascii(Name) ->
+    false = lists:any(
+	      fun(C) when
+			(    0 =< C) and (C =< 16#2C) or
+			(16#2E =< C) and (C =< 16#2F) or
+			(16#3A =< C) and (C =< 16#40) or
+			(16#5B =< C) and (C =< 16#60) or
+			(16#7B =< C) and (C =< 16#7F) ->
+		      true;
+		 (_) ->
+		      false
+	      end, Name),
+    case Name of
+	[H | _] when H /= $- ->
+	    true = lists:last(Name) /= $-
+    end,
+    ASCIIName = case lists:any(fun(C) -> C > 16#7F end, Name) of
+		    true ->
+			true = case Name of
+				   "xn--" ++ _ -> false;
+				   _ -> true
+			       end,
+			"xn--" ++ punycode_encode(Name);
+		    false ->
+			Name
+		end,
+    L = length(ASCIIName),
+    true = (1 =< L) and (L =< 63),
+    ASCIIName.
+
+
+%%% PUNYCODE (RFC3492)
+
+-define(BASE,         36).
+-define(TMIN,         1).
+-define(TMAX,         26).
+-define(SKEW,         38).
+-define(DAMP,         700).
+-define(INITIAL_BIAS, 72).
+-define(INITIAL_N,    128).
+
+punycode_encode(Input) ->
+    N = ?INITIAL_N,
+    Delta = 0,
+    Bias = ?INITIAL_BIAS,
+    Basic = lists:filter(fun(C) -> C =< 16#7f end, Input),
+    NonBasic = lists:filter(fun(C) -> C > 16#7f end, Input),
+    L = length(Input),
+    B = length(Basic),
+    SNonBasic = lists:usort(NonBasic),
+    Output1 = if
+		 B > 0 -> Basic ++ "-";
+		 true -> ""
+	     end,
+    Output2 = punycode_encode1(Input, SNonBasic, B, B, L, N, Delta, Bias, ""),
+    Output1 ++ Output2.
+
+
+punycode_encode1(Input, [M | SNonBasic], B, H, L, N, Delta, Bias, Out)
+  when H < L ->
+    Delta1 = Delta + (M - N) * (H + 1),
+    % let n = m
+    {NewDelta, NewBias, NewH, NewOut} =
+	lists:foldl(
+	  fun(C, {ADelta, ABias, AH, AOut}) ->
+		  if
+		      C < M ->
+			  {ADelta + 1, ABias, AH, AOut};
+		      C == M ->
+			  NewOut = punycode_encode_delta(ADelta, ABias, AOut),
+			  NewBias = adapt(ADelta, H + 1, H == B),
+			  {0, NewBias, AH + 1, NewOut};
+		      true ->
+			  {ADelta, ABias, AH, AOut}
+		  end
+	  end, {Delta1, Bias, H, Out}, Input),
+    punycode_encode1(
+      Input, SNonBasic, B, NewH, L, M + 1, NewDelta + 1, NewBias, NewOut);
+
+punycode_encode1(Input, SNonBasic, B, H, L, N, Delta, Bias, Out) ->
+    lists:reverse(Out).
+
+
+punycode_encode_delta(Delta, Bias, Out) ->
+    punycode_encode_delta(Delta, Bias, Out, ?BASE).
+
+punycode_encode_delta(Delta, Bias, Out, K) ->
+    T = if
+	    K =< Bias         -> ?TMIN;
+	    K >= Bias + ?TMAX -> ?TMAX;
+	    true              -> K - Bias
+	end,
+    if
+	Delta < T ->
+	    [codepoint(Delta) | Out];
+	true ->
+	    C = T + ((Delta - T) rem (?BASE - T)),
+	    punycode_encode_delta((Delta - T) div (?BASE - T), Bias,
+				  [codepoint(C) | Out], K + ?BASE)
+    end.
+
+
+adapt(Delta, NumPoints, FirstTime) ->
+    Delta1 = if
+		 FirstTime -> Delta div ?DAMP;
+		 true -> Delta div 2
+	     end,
+    Delta2 = Delta1 + (Delta1 div NumPoints),
+    adapt1(Delta2, 0).
+
+adapt1(Delta, K) ->
+    if
+	Delta > ((?BASE - ?TMIN) * ?TMAX) div 2 ->
+	    adapt1(Delta div (?BASE - ?TMIN), K + ?BASE);
+	true ->
+	    K + (((?BASE - ?TMIN + 1) * Delta) div (Delta + ?SKEW))
+    end.
+	
+
+codepoint(C) ->
+    if
+	(0 =< C) and (C =< 25) ->
+	    C + 97;
+	(26 =< C) and (C =< 35) ->
+	    C + 22
+    end.

src/mod_muc/mod_muc_room.erl

@@ -1383,7 +1383,7 @@ add_message_to_history(FromNick, Packet, StateData) ->
 		jlib:jid_replace_resource(StateData#state.jid, FromNick),
 		StateData#state.jid,
 		TSPacket),
-    Size = string:len(xml:element_to_string(SPacket)),
+    Size = lists:flatlength(xml:element_to_string(SPacket)),
     Q1 = lqueue_in({FromNick, TSPacket, HaveSubject, TimeStamp, Size},
 		   StateData#state.history),
     StateData#state{history = Q1}.

src/xml.erl

@@ -20,26 +20,26 @@
 	 get_path_s/2,
 	 replace_tag_attr/3]).
 
-element_to_string(El) ->
+%element_to_string(El) ->
-    case El of
+%    case El of
-	{xmlelement, Name, Attrs, Els} ->
+%	{xmlelement, Name, Attrs, Els} ->
-	    if length(Els) > 0 ->
+%	    if length(Els) > 0 ->
-		    "<" ++ Name ++ attrs_to_string(Attrs) ++ ">" ++
+%		    "<" ++ Name ++ attrs_to_string(Attrs) ++ ">" ++
-			lists:append(
+%			lists:append(
-			  lists:map(fun(E) -> element_to_string(E) end, Els))
+%			  lists:map(fun(E) -> element_to_string(E) end, Els))
-			++ "</" ++ Name ++ ">";
+%			++ "</" ++ Name ++ ">";
-	       true ->
+%	       true ->
-		    "<" ++ Name ++ attrs_to_string(Attrs) ++ "/>"
+%		    "<" ++ Name ++ attrs_to_string(Attrs) ++ "/>"
-	       end;
+%	       end;
-	{xmlcdata, CData} -> crypt(CData)
+%	{xmlcdata, CData} -> crypt(CData)
-    end.
+%    end.
-
+%
-
+%
-attrs_to_string(Attrs) ->
+%attrs_to_string(Attrs) ->
-    lists:append(lists:map(fun(A) -> attr_to_string(A) end, Attrs)).
+%    lists:append(lists:map(fun(A) -> attr_to_string(A) end, Attrs)).
-
+%
-attr_to_string({Name, Value}) ->
+%attr_to_string({Name, Value}) ->
-    " " ++ crypt(Name) ++ "='" ++ crypt(Value) ++ "'".
+%    " " ++ crypt(Name) ++ "='" ++ crypt(Value) ++ "'".
 
 
 %element_to_string2(El) ->
@@ -64,25 +64,56 @@ attr_to_string({Name, Value}) ->
 %attr_to_list({Name, Value}) ->
 %    [" ", crypt(Name), "='", crypt(Value), "'"].
 
+element_to_string(El) ->
+    case El of
+	{xmlelement, Name, Attrs, Els} ->
+	    if
+		Els /= [] ->
+		    [$<, Name, attrs_to_list(Attrs), $>,
+		     [element_to_string(E) || E <- Els],
+		     $<, $/, Name, $>];
+	       true ->
+		    [$<, Name, attrs_to_list(Attrs), $/, $>]
+	       end;
+	{xmlcdata, CData} ->
+	    crypt(CData)
+    end.
 
+attrs_to_list(Attrs) ->
+    [attr_to_list(A) || A <- Attrs].
+
+attr_to_list({Name, Value}) ->
+    [$\s, crypt(Name), $=, $', crypt(Value), $'].
+
+
+
+%crypt(S) ->
+%    lists:reverse(crypt(S, "")).
+%
+%crypt([$& | S], R) ->
+%    crypt(S, [$;, $p, $m, $a, $& | R]);
+%crypt([$< | S], R) ->
+%    crypt(S, [$;, $t, $l, $& | R]);
+%crypt([$> | S], R) ->
+%    crypt(S, [$;, $t, $g, $& | R]);
+%crypt([$" | S], R) ->
+%    crypt(S, [$;, $t, $o, $u, $q, $& | R]);
+%crypt([$' | S], R) ->
+%    crypt(S, [$;, $s, $o, $p, $a, $& | R]);
+%crypt([C | S], R) ->
+%    crypt(S, [C | R]);
+%crypt([], R) ->
+%    R.
 
 crypt(S) ->
-    lists:reverse(crypt(S, "")).
+    [case C of
-
+	 $& -> "&amp;";
-crypt([$& | S], R) ->
+	 $< -> "&lt;";
-    crypt(S, [$;, $p, $m, $a, $& | R]);
+	 $> -> "&gt;";
-crypt([$< | S], R) ->
+	 $" -> "&quot;";
-    crypt(S, [$;, $t, $l, $& | R]);
+	 $' -> "&apos;";
-crypt([$> | S], R) ->
+	 _ -> C
-    crypt(S, [$;, $t, $g, $& | R]);
+     end || C <- S].
-crypt([$" | S], R) ->
-    crypt(S, [$;, $t, $o, $u, $q, $& | R]);
-crypt([$' | S], R) ->
-    crypt(S, [$;, $s, $o, $p, $a, $& | R]);
-crypt([C | S], R) ->
-    crypt(S, [C | R]);
-crypt([], R) ->
-    R.
 
 %crypt1(S) ->
 %    lists:flatten([case C of