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

%%%-------------------------------------------------------------------
%%% File    : ejabberd_captcha.erl
%%% Author  : Evgeniy Khramtsov <xramtsov@gmail.com>
%%% Purpose : CAPTCHA processing.
%%% Created : 26 Apr 2008 by Evgeniy Khramtsov <xramtsov@gmail.com>
%%%
%%%
%%% ejabberd, Copyright (C) 2002-2021   ProcessOne
%%%
%%% 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.,
%%% 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
%%%
%%%-------------------------------------------------------------------

-module(ejabberd_captcha).

-protocol({xep, 158, '1.0'}).

-behaviour(gen_server).

%% API
-export([start_link/0]).

%% gen_server callbacks
-export([init/1, handle_call/3, handle_cast/2,
	 handle_info/2, terminate/2, code_change/3]).

-export([create_captcha/6, build_captcha_html/2,
	 check_captcha/2, process_reply/1, process/2,
	 is_feature_available/0, create_captcha_x/5,
	 host_up/1, host_down/1,
	 config_reloaded/0, process_iq/1]).

-include_lib("xmpp/include/xmpp.hrl").
-include("logger.hrl").
-include("ejabberd_http.hrl").
-include("translate.hrl").

-define(CAPTCHA_LIFETIME, 120000).
-define(LIMIT_PERIOD, 60*1000*1000).

-type image_error() :: efbig | enodata | limit | malformed_image | timeout.
-type priority() :: neg_integer().
-type callback() :: fun((captcha_succeed | captcha_failed) -> any()).

-record(state, {limits = treap:empty() :: treap:treap(),
		enabled = false :: boolean()}).

-record(captcha, {id :: binary(),
                  pid :: pid() | undefined,
                  key :: binary(),
                  tref :: reference(),
                  args :: any()}).

start_link() ->
    gen_server:start_link({local, ?MODULE}, ?MODULE, [],
			  []).

-spec captcha_text(binary()) -> binary().
captcha_text(Lang) ->
    translate:translate(Lang, ?T("Enter the text you see")).

-spec mk_ocr_field(binary(), binary(), binary()) -> xdata_field().
mk_ocr_field(Lang, CID, Type) ->
    URI = #media_uri{type = Type, uri = <<"cid:", CID/binary>>},
    [_, F] = captcha_form:encode([{ocr, <<>>}], Lang, [ocr]),
    xmpp:set_els(F, [#media{uri = [URI]}]).

-spec create_captcha(binary(), jid(), jid(),
                     binary(), any(),
		     callback() | term()) -> {error, image_error()} |
					     {ok, binary(), [text()], [xmpp_element()]}.
create_captcha(SID, From, To, Lang, Limiter, Args) ->
    case create_image(Limiter) of
      {ok, Type, Key, Image} ->
	    Id = <<(p1_rand:get_string())/binary>>,
	    JID = jid:encode(From),
	    CID = <<"sha1+", (str:sha(Image))/binary, "@bob.xmpp.org">>,
	    Data = #bob_data{cid = CID, 'max-age' = 0, type = Type, data = Image},
	    Fs = captcha_form:encode(
		   [{from, To}, {challenge, Id}, {sid, SID},
		    mk_ocr_field(Lang, CID, Type)],
		   Lang, [challenge]),
	    X = #xdata{type = form, fields = Fs},
	    Captcha = #xcaptcha{xdata = X},
	    BodyString = {?T("Your subscription request and/or messages to ~s have been blocked. "
			     "To unblock your subscription request, visit ~s"), [JID, get_url(Id)]},
	    Body = xmpp:mk_text(BodyString, Lang),
	    OOB = #oob_x{url = get_url(Id)},
	    Hint = #hint{type = 'no-store'},
	    Tref = erlang:send_after(?CAPTCHA_LIFETIME, ?MODULE, {remove_id, Id}),
	    ets:insert(captcha,
		       #captcha{id = Id, pid = self(), key = Key, tref = Tref,
				args = Args}),
	    {ok, Id, Body, [Hint, OOB, Captcha, Data]};
	Err -> Err
    end.

-spec create_captcha_x(binary(), jid(), binary(), any(), xdata()) ->
			      {ok, [xmpp_element()]} | {error, image_error()}.
create_captcha_x(SID, To, Lang, Limiter, #xdata{fields = Fs} = X) ->
    case create_image(Limiter) of
      {ok, Type, Key, Image} ->
	    Id = <<(p1_rand:get_string())/binary>>,
	    CID = <<"sha1+", (str:sha(Image))/binary, "@bob.xmpp.org">>,
	    Data = #bob_data{cid = CID, 'max-age' = 0, type = Type, data = Image},
	    HelpTxt = translate:translate(
			Lang, ?T("If you don't see the CAPTCHA image here, visit the web page.")),
	    Imageurl = get_url(<<Id/binary, "/image">>),
	    [H|T] = captcha_form:encode(
		      [{'captcha-fallback-text', HelpTxt},
		       {'captcha-fallback-url', Imageurl},
		       {from, To}, {challenge, Id}, {sid, SID},
		       mk_ocr_field(Lang, CID, Type)],
		      Lang, [challenge]),
	    Captcha = X#xdata{type = form, fields = [H|Fs ++ T]},
	    Tref = erlang:send_after(?CAPTCHA_LIFETIME, ?MODULE, {remove_id, Id}),
	    ets:insert(captcha, #captcha{id = Id, key = Key, tref = Tref}),
	    {ok, [Captcha, Data]};
	Err -> Err
    end.

-spec build_captcha_html(binary(), binary()) -> captcha_not_found |
                                                {xmlel(),
                                                 {xmlel(), cdata(),
                                                  xmlel(), xmlel()}}.

build_captcha_html(Id, Lang) ->
    case lookup_captcha(Id) of
      {ok, _} ->
	  ImgEl = #xmlel{name = <<"img">>,
			 attrs =
			     [{<<"src">>, get_url(<<Id/binary, "/image">>)}],
			 children = []},
	  Text = {xmlcdata, captcha_text(Lang)},
	  IdEl = #xmlel{name = <<"input">>,
			attrs =
			    [{<<"type">>, <<"hidden">>}, {<<"name">>, <<"id">>},
			     {<<"value">>, Id}],
			children = []},
	  KeyEl = #xmlel{name = <<"input">>,
			 attrs =
			     [{<<"type">>, <<"text">>}, {<<"name">>, <<"key">>},
			      {<<"size">>, <<"10">>}],
			 children = []},
	  FormEl = #xmlel{name = <<"form">>,
			  attrs =
			      [{<<"action">>, get_url(Id)},
			       {<<"name">>, <<"captcha">>},
			       {<<"method">>, <<"POST">>}],
			  children =
			      [ImgEl,
			       #xmlel{name = <<"br">>, attrs = [],
				      children = []},
			       Text,
			       #xmlel{name = <<"br">>, attrs = [],
				      children = []},
			       IdEl, KeyEl,
			       #xmlel{name = <<"br">>, attrs = [],
				      children = []},
			       #xmlel{name = <<"input">>,
				      attrs =
					  [{<<"type">>, <<"submit">>},
					   {<<"name">>, <<"enter">>},
					   {<<"value">>, ?T("OK")}],
				      children = []}]},
	  {FormEl, {ImgEl, Text, IdEl, KeyEl}};
      _ -> captcha_not_found
    end.

-spec process_reply(xmpp_element()) -> ok | {error, bad_match | not_found | malformed}.

process_reply(#xdata{} = X) ->
    Required = [<<"challenge">>, <<"ocr">>],
    Fs = lists:filter(
	   fun(#xdata_field{var = Var}) ->
		   lists:member(Var, [<<"FORM_TYPE">>|Required])
	   end, X#xdata.fields),
    try captcha_form:decode(Fs, [?NS_CAPTCHA], Required) of
	Props ->
	    Id = proplists:get_value(challenge, Props),
	    OCR = proplists:get_value(ocr, Props),
	    case check_captcha(Id, OCR) of
		captcha_valid -> ok;
		captcha_non_valid -> {error, bad_match};
		captcha_not_found -> {error, not_found}
	    end
    catch _:{captcha_form, Why} ->
	    ?WARNING_MSG("Malformed CAPTCHA form: ~ts",
			 [captcha_form:format_error(Why)]),
	    {error, malformed}
    end;
process_reply(#xcaptcha{xdata = #xdata{} = X}) ->
    process_reply(X);
process_reply(_) ->
    {error, malformed}.

-spec process_iq(iq()) -> iq().
process_iq(#iq{type = set, lang = Lang, sub_els = [#xcaptcha{} = El]} = IQ) ->
    case process_reply(El) of
	ok ->
	    xmpp:make_iq_result(IQ);
	{error, malformed} ->
	    Txt = ?T("Incorrect CAPTCHA submit"),
	    xmpp:make_error(IQ, xmpp:err_bad_request(Txt, Lang));
	{error, _} ->
	    Txt = ?T("The CAPTCHA verification has failed"),
	    xmpp:make_error(IQ, xmpp:err_not_allowed(Txt, Lang))
    end;
process_iq(#iq{type = get, lang = Lang} = IQ) ->
    Txt = ?T("Value 'get' of 'type' attribute is not allowed"),
    xmpp:make_error(IQ, xmpp:err_not_allowed(Txt, Lang));
process_iq(#iq{lang = Lang} = IQ) ->
    Txt = ?T("No module is handling this query"),
    xmpp:make_error(IQ, xmpp:err_service_unavailable(Txt, Lang)).

process(_Handlers,
	#request{method = 'GET', lang = Lang,
		 path = [_, Id]}) ->
    case build_captcha_html(Id, Lang) of
      {FormEl, _} ->
	  Form = #xmlel{name = <<"div">>,
			attrs = [{<<"align">>, <<"center">>}],
			children = [FormEl]},
	  ejabberd_web:make_xhtml([Form]);
      captcha_not_found -> ejabberd_web:error(not_found)
    end;
process(_Handlers,
	#request{method = 'GET', path = [_, Id, <<"image">>],
		 ip = IP}) ->
    {Addr, _Port} = IP,
    case lookup_captcha(Id) of
      {ok, #captcha{key = Key}} ->
	  case create_image(Addr, Key) of
	    {ok, Type, _, Img} ->
		{200,
		 [{<<"Content-Type">>, Type},
		  {<<"Cache-Control">>, <<"no-cache">>},
		  {<<"Last-Modified">>, list_to_binary(httpd_util:rfc1123_date())}],
		 Img};
	    {error, limit} -> ejabberd_web:error(not_allowed);
	    _ -> ejabberd_web:error(not_found)
	  end;
      _ -> ejabberd_web:error(not_found)
    end;
process(_Handlers,
	#request{method = 'POST', q = Q, lang = Lang,
		 path = [_, Id]}) ->
    ProvidedKey = proplists:get_value(<<"key">>, Q, none),
    case check_captcha(Id, ProvidedKey) of
      captcha_valid ->
	  Form = #xmlel{name = <<"p">>, attrs = [],
			children =
			    [{xmlcdata,
			      translate:translate(Lang,
						  ?T("The CAPTCHA is valid."))}]},
	  ejabberd_web:make_xhtml([Form]);
      captcha_non_valid -> ejabberd_web:error(not_allowed);
      captcha_not_found -> ejabberd_web:error(not_found)
    end;
process(_Handlers, _Request) ->
    ejabberd_web:error(not_found).

host_up(Host) ->
    gen_iq_handler:add_iq_handler(ejabberd_sm, Host, ?NS_CAPTCHA,
				  ?MODULE, process_iq).

host_down(Host) ->
    gen_iq_handler:remove_iq_handler(ejabberd_sm, Host, ?NS_CAPTCHA).

config_reloaded() ->
    gen_server:call(?MODULE, config_reloaded, timer:minutes(1)).

init([]) ->
    _ = mnesia:delete_table(captcha),
    _ = ets:new(captcha, [named_table, public, {keypos, #captcha.id}]),
    case check_captcha_setup() of
	true ->
	    register_handlers(),
	    ejabberd_hooks:add(config_reloaded, ?MODULE, config_reloaded, 50),
	    {ok, #state{enabled = true}};
	false ->
	    {ok, #state{enabled = false}};
	{error, Reason} ->
	    {stop, Reason}
    end.

handle_call({is_limited, Limiter, RateLimit}, _From,
	    State) ->
    NowPriority = now_priority(),
    CleanPriority = NowPriority + (?LIMIT_PERIOD),
    Limits = clean_treap(State#state.limits, CleanPriority),
    case treap:lookup(Limiter, Limits) of
      {ok, _, Rate} when Rate >= RateLimit ->
	  {reply, true, State#state{limits = Limits}};
      {ok, Priority, Rate} ->
	  NewLimits = treap:insert(Limiter, Priority, Rate + 1,
				   Limits),
	  {reply, false, State#state{limits = NewLimits}};
      _ ->
	  NewLimits = treap:insert(Limiter, NowPriority, 1,
				   Limits),
	  {reply, false, State#state{limits = NewLimits}}
    end;
handle_call(config_reloaded, _From, #state{enabled = Enabled} = State) ->
    State1 = case is_feature_available() of
		 true when not Enabled ->
		     case check_captcha_setup() of
			 true ->
			     register_handlers(),
			     State#state{enabled = true};
			 _ ->
			     State
		     end;
		 false when Enabled ->
		     unregister_handlers(),
		     State#state{enabled = false};
		 _ ->
		     State
	     end,
    {reply, ok, State1};
handle_call(Request, From, State) ->
    ?WARNING_MSG("Unexpected call from ~p: ~p", [From, Request]),
    {noreply, State}.

handle_cast(Msg, State) ->
    ?WARNING_MSG("Unexpected cast: ~p", [Msg]),
    {noreply, State}.

handle_info({remove_id, Id}, State) ->
    ?DEBUG("CAPTCHA ~p timed out", [Id]),
    case ets:lookup(captcha, Id) of
	[#captcha{args = Args, pid = Pid}] ->
	    callback(captcha_failed, Pid, Args),
	    ets:delete(captcha, Id);
	_ -> ok
    end,
    {noreply, State};
handle_info(Info, State) ->
    ?WARNING_MSG("Unexpected info: ~p", [Info]),
    {noreply, State}.

terminate(_Reason, #state{enabled = Enabled}) ->
    if Enabled -> unregister_handlers();
       true -> ok
    end,
    ejabberd_hooks:delete(config_reloaded, ?MODULE, config_reloaded, 50).

register_handlers() ->
    ejabberd_hooks:add(host_up, ?MODULE, host_up, 50),
    ejabberd_hooks:add(host_down, ?MODULE, host_down, 50),
    lists:foreach(fun host_up/1, ejabberd_option:hosts()).

unregister_handlers() ->
    ejabberd_hooks:delete(host_up, ?MODULE, host_up, 50),
    ejabberd_hooks:delete(host_down, ?MODULE, host_down, 50),
    lists:foreach(fun host_down/1, ejabberd_option:hosts()).

code_change(_OldVsn, State, _Extra) -> {ok, State}.

-spec create_image() -> {ok, binary(), binary(), binary()} |
			{error, image_error()}.
create_image() ->
    create_image(undefined).

-spec create_image(term()) -> {ok, binary(), binary(), binary()} |
			      {error, image_error()}.
create_image(Limiter) ->
    Key = str:substr(p1_rand:get_string(), 1, 6),
    create_image(Limiter, Key).

-spec create_image(term(), binary()) -> {ok, binary(), binary(), binary()} |
					{error, image_error()}.
create_image(Limiter, Key) ->
    case is_limited(Limiter) of
	true -> {error, limit};
	false -> do_create_image(Key)
    end.

-spec do_create_image(binary()) -> {ok, binary(), binary(), binary()} |
				   {error, image_error()}.
do_create_image(Key) ->
    FileName = get_prog_name(),
    Cmd = lists:flatten(io_lib:format("~ts ~ts", [FileName, Key])),
    case cmd(Cmd) of
      {ok,
       <<137, $P, $N, $G, $\r, $\n, 26, $\n, _/binary>> =
	   Img} ->
	  {ok, <<"image/png">>, Key, Img};
      {ok, <<255, 216, _/binary>> = Img} ->
	  {ok, <<"image/jpeg">>, Key, Img};
      {ok, <<$G, $I, $F, $8, X, $a, _/binary>> = Img}
	  when X == $7; X == $9 ->
	  {ok, <<"image/gif">>, Key, Img};
      {error, enodata = Reason} ->
	  ?ERROR_MSG("Failed to process output from \"~ts\". "
		     "Maybe ImageMagick's Convert program "
		     "is not installed.",
		     [Cmd]),
	  {error, Reason};
      {error, Reason} ->
	  ?ERROR_MSG("Failed to process an output from \"~ts\": ~p",
		     [Cmd, Reason]),
	  {error, Reason};
      _ ->
	  Reason = malformed_image,
	  ?ERROR_MSG("Failed to process an output from \"~ts\": ~p",
		     [Cmd, Reason]),
	  {error, Reason}
    end.

get_prog_name() ->
    case ejabberd_option:captcha_cmd() of
        undefined ->
            ?DEBUG("The option captcha_cmd is not configured, "
                   "but some module wants to use the CAPTCHA "
                   "feature.",
                   []),
            false;
        FileName ->
            FileName
    end.

-spec get_url(binary()) -> binary().
get_url(Str) ->
    case ejabberd_option:captcha_url() of
	undefined ->
	    URL = parse_captcha_host(),
	    <<URL/binary, "/captcha/", Str/binary>>;
	URL ->
	    <<URL/binary, $/, Str/binary>>
    end.

-spec parse_captcha_host() -> binary().
parse_captcha_host() ->
    CaptchaHost = ejabberd_option:captcha_host(),
    case str:tokens(CaptchaHost, <<":">>) of
	[Host] ->
	    <<"http://", Host/binary>>;
	[<<"http", _/binary>> = TransferProt, Host] ->
	    <<TransferProt/binary, ":", Host/binary>>;
	[Host, PortString] ->
	    TransferProt = atom_to_binary(get_transfer_protocol(PortString), latin1),
	    <<TransferProt/binary, "://", Host/binary, ":", PortString/binary>>;
	[TransferProt, Host, PortString] ->
	    <<TransferProt/binary, ":", Host/binary, ":", PortString/binary>>;
      _ ->
	    <<"http://", (ejabberd_config:get_myname())/binary>>
    end.

get_transfer_protocol(PortString) ->
    PortNumber = binary_to_integer(PortString),
    PortListeners = get_port_listeners(PortNumber),
    get_captcha_transfer_protocol(PortListeners).

get_port_listeners(PortNumber) ->
    AllListeners = ejabberd_option:listen(),
    lists:filter(
      fun({{Port, _IP, _Transport}, _Module, _Opts}) ->
	      Port == PortNumber
      end, AllListeners).

get_captcha_transfer_protocol([]) ->
    throw(<<"The port number mentioned in captcha_host "
	    "is not a ejabberd_http listener with "
	    "'captcha' option. Change the port number "
	    "or specify http:// in that option.">>);
get_captcha_transfer_protocol([{_, ejabberd_http, Opts} | Listeners]) ->
    Handlers = maps:get(request_handlers, Opts, []),
    case lists:any(
	   fun({_, ?MODULE}) -> true;
	      ({_, _}) -> false
	   end, Handlers) of
	true ->
	    case maps:get(tls, Opts) of
		true -> https;
		false -> http
	    end;
	false ->
	    get_captcha_transfer_protocol(Listeners)
    end;
get_captcha_transfer_protocol([_ | Listeners]) ->
    get_captcha_transfer_protocol(Listeners).

is_limited(undefined) -> false;
is_limited(Limiter) ->
    case ejabberd_option:captcha_limit() of
      infinity -> false;
      Int ->
	  case catch gen_server:call(?MODULE,
				     {is_limited, Limiter, Int}, 5000)
	      of
	    true -> true;
	    false -> false;
	    Err -> ?ERROR_MSG("Call failed: ~p", [Err]), false
	  end
    end.

-define(CMD_TIMEOUT, 5000).

-define(MAX_FILE_SIZE, 64 * 1024).

-spec cmd(string()) -> {ok, binary()} | {error, image_error()}.
cmd(Cmd) ->
    Port = open_port({spawn, Cmd}, [stream, eof, binary]),
    TRef = erlang:start_timer(?CMD_TIMEOUT, self(),
			      timeout),
    recv_data(Port, TRef, <<>>).

-spec recv_data(port(), reference(), binary()) -> {ok, binary()} | {error, image_error()}.
recv_data(Port, TRef, Buf) ->
    receive
      {Port, {data, Bytes}} ->
	  NewBuf = <<Buf/binary, Bytes/binary>>,
	  if byte_size(NewBuf) > (?MAX_FILE_SIZE) ->
		 return(Port, TRef, {error, efbig});
	     true -> recv_data(Port, TRef, NewBuf)
	  end;
      {Port, {data, _}} -> return(Port, TRef, {error, efbig});
      {Port, eof} when Buf /= <<>> ->
	  return(Port, TRef, {ok, Buf});
      {Port, eof} -> return(Port, TRef, {error, enodata});
      {timeout, TRef, _} ->
	  return(Port, TRef, {error, timeout})
    end.

-spec return(port(), reference(), {ok, binary()} | {error, image_error()}) ->
		    {ok, binary()} | {error, image_error()}.
return(Port, TRef, Result) ->
    misc:cancel_timer(TRef),
    catch port_close(Port),
    Result.

is_feature_available() ->
    case get_prog_name() of
      Prog when is_binary(Prog) -> true;
      false -> false
    end.

check_captcha_setup() ->
    case is_feature_available() of
	true ->
	    case create_image() of
		{ok, _, _, _} ->
		    true;
		Err ->
		    ?CRITICAL_MSG("Captcha is enabled in the option captcha_cmd, "
				  "but it can't generate images.",
				  []),
		    Err
	    end;
	false ->
	    false
    end.

-spec lookup_captcha(binary()) -> {ok, #captcha{}} | {error, enoent}.
lookup_captcha(Id) ->
    case ets:lookup(captcha, Id) of
	[C] -> {ok, C};
	[] -> {error, enoent}
    end.

-spec check_captcha(binary(), binary()) -> captcha_not_found |
                                           captcha_valid |
                                           captcha_non_valid.

check_captcha(Id, ProvidedKey) ->
    case lookup_captcha(Id) of
	{ok, #captcha{pid = Pid, args = Args, key = ValidKey, tref = Tref}} ->
	    ets:delete(captcha, Id),
	    misc:cancel_timer(Tref),
	    if ValidKey == ProvidedKey ->
		    callback(captcha_succeed, Pid, Args),
		    captcha_valid;
	       true ->
		    callback(captcha_failed, Pid, Args),
		    captcha_non_valid
	    end;
	{error, _} ->
	    captcha_not_found
    end.

-spec clean_treap(treap:treap(), priority()) -> treap:treap().
clean_treap(Treap, CleanPriority) ->
    case treap:is_empty(Treap) of
      true -> Treap;
      false ->
	  {_Key, Priority, _Value} = treap:get_root(Treap),
	  if Priority > CleanPriority ->
		 clean_treap(treap:delete_root(Treap), CleanPriority);
	     true -> Treap
	  end
    end.

-spec callback(captcha_succeed | captcha_failed,
	       pid() | undefined,
	       callback() | term()) -> any().
callback(Result, _Pid, F) when is_function(F) ->
    F(Result);
callback(Result, Pid, Args) when is_pid(Pid) ->
    Pid ! {Result, Args};
callback(_, _, _) ->
    ok.

-spec now_priority() -> priority().
now_priority() ->
    -erlang:system_time(microsecond).