diff options
Diffstat (limited to 'lib/dialyzer/test/r9c_SUITE_data/src/inets')
52 files changed, 19699 insertions, 0 deletions
diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/Makefile b/lib/dialyzer/test/r9c_SUITE_data/src/inets/Makefile new file mode 100644 index 0000000000..be63eb73b2 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/Makefile @@ -0,0 +1,178 @@ +# ``The contents of this file are subject to the Erlang Public License, +# Version 1.1, (the "License"); you may not use this file except in +# compliance with the License. You should have received a copy of the +# Erlang Public License along with this software. If not, it can be +# retrieved via the world wide web at http://www.erlang.org/. +# +# Software distributed under the License is distributed on an "AS IS" +# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +# the License for the specific language governing rights and limitations +# under the License. +# +# The Initial Developer of the Original Code is Ericsson Utvecklings AB. +# Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +# AB. All Rights Reserved.'' +# +# $Id: Makefile,v 1.1 2008/12/17 09:53:33 mikpe Exp $ +# +include $(ERL_TOP)/make/target.mk +include $(ERL_TOP)/make/$(TARGET)/otp.mk + +# ---------------------------------------------------- +# Application version +# ---------------------------------------------------- +include ../vsn.mk + +VSN = $(INETS_VSN) +APP_VSN = "inets-$(VSN)" + + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- +RELSYSDIR = $(RELEASE_PATH)/lib/inets-$(VSN) + +# ---------------------------------------------------- +# Target Specs +# ---------------------------------------------------- +MODULES = \ + ftp \ + http \ + http_lib \ + httpc_handler \ + httpc_manager \ + uri \ + httpd \ + httpd_acceptor \ + httpd_acceptor_sup \ + httpd_conf \ + httpd_example \ + httpd_manager \ + httpd_misc_sup \ + httpd_parse \ + httpd_request_handler \ + httpd_response \ + httpd_socket \ + httpd_sup \ + httpd_util \ + httpd_verbosity \ + inets_sup \ + mod_actions \ + mod_alias \ + mod_auth \ + mod_auth_plain \ + mod_auth_dets \ + mod_auth_mnesia \ + mod_auth_server \ + mod_browser \ + mod_cgi \ + mod_dir \ + mod_disk_log \ + mod_esi \ + mod_get \ + mod_head \ + mod_htaccess \ + mod_include \ + mod_log \ + mod_range \ + mod_responsecontrol \ + mod_trace \ + mod_security \ + mod_security_server + +HRL_FILES = httpd.hrl httpd_verbosity.hrl mod_auth.hrl \ + http.hrl jnets_httpd.hrl + +ERL_FILES = $(MODULES:%=%.erl) + +TARGET_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR)) $(APP_TARGET) $(APPUP_TARGET) + +APP_FILE= inets.app +APPUP_FILE= inets.appup + +APP_SRC= $(APP_FILE).src +APP_TARGET= $(EBIN)/$(APP_FILE) + +APPUP_SRC= $(APPUP_FILE).src +APPUP_TARGET= $(EBIN)/$(APPUP_FILE) + +# ---------------------------------------------------- +# INETS FLAGS +# ---------------------------------------------------- +# DONT_USE_VERBOSITY = -Ddont_use_verbosity=true +INETS_FLAGS = -D'SERVER_SOFTWARE="inets/$(VSN)"' \ + -Ddefault_verbosity=silence \ + $(DONT_USE_VERBOSITY) + +# INETS_DEBUG_DEFAULT = d +ifeq ($(INETS_DEBUG),) + INETS_DEBUG = $(INETS_DEBUG_DEFAULT) +endif + +ifeq ($(INETS_DEBUG),c) + INETS_FLAGS += -Dinets_cdebug -Dinets_debug -Dinets_log -Dinets_error +endif +ifeq ($(INETS_DEBUG),d) + INETS_FLAGS += -Dinets_debug -Dinets_log -Dinets_error +endif +ifeq ($(INETS_DEBUG),l) + INETS_FLAGS += -Dinets_log -Dinets_error +endif +ifeq ($(INETS_DEBUG),e) + INETS_FLAGS += -Dinets_error +endif + + +# ---------------------------------------------------- +# FLAGS +# ---------------------------------------------------- +ERL_FLAGS += + +ifeq ($(WARN_UNUSED_WARS),true) +ERL_COMPILE_FLAGS += +warn_unused_vars +endif + +ERL_COMPILE_FLAGS += $(INETS_FLAGS) \ + +'{parse_transform,sys_pre_attributes}' \ + +'{attribute,insert,app_vsn,$(APP_VSN)}' + + +# ---------------------------------------------------- +# Targets +# ---------------------------------------------------- + +debug opt: $(TARGET_FILES) + +clean: + rm -f $(TARGET_FILES) + rm -f core + +docs: + +# ---------------------------------------------------- +# Special Build Targets +# ---------------------------------------------------- + +$(APP_TARGET): $(APP_SRC) ../vsn.mk + sed -e 's;%VSN%;$(VSN);' $< > $@ + +$(APPUP_TARGET): $(APPUP_SRC) ../vsn.mk + sed -e 's;%VSN%;$(VSN);' $< > $@ + +# ---------------------------------------------------- +# Release Target +# ---------------------------------------------------- +include $(ERL_TOP)/make/otp_release_targets.mk + +release_spec: opt + $(INSTALL_DIR) $(RELSYSDIR)/src + $(INSTALL_DATA) $(HRL_FILES) $(ERL_FILES) $(RELSYSDIR)/src + $(INSTALL_DIR) $(RELSYSDIR)/ebin + $(INSTALL_DATA) $(TARGET_FILES) $(RELSYSDIR)/ebin + +release_docs_spec: + +info: + @echo "INETS_DEBUG = $(INETS_DEBUG)" + @echo "INETS_FLAGS = $(INETS_FLAGS)" + @echo "ERL_COMPILE_FLAGS = $(ERL_COMPILE_FLAGS)" diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/ftp.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/ftp.erl new file mode 100644 index 0000000000..312bb3a5c8 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/ftp.erl @@ -0,0 +1,1582 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: ftp.erl,v 1.2 2009/03/03 01:55:01 kostis Exp $ +%% +-module(ftp). + +-behaviour(gen_server). + +%% This module implements an ftp client based on socket(3)/gen_tcp(3), +%% file(3) and filename(3). +%% + + +-define(OPEN_TIMEOUT, 60*1000). +-define(BYTE_TIMEOUT, 1000). % Timeout for _ONE_ byte to arrive. (ms) +-define(OPER_TIMEOUT, 300). % Operation timeout (seconds) +-define(FTP_PORT, 21). + +%% Client interface +-export([cd/2, close/1, delete/2, formaterror/1, help/0, + lcd/2, lpwd/1, ls/1, ls/2, + mkdir/2, nlist/1, nlist/2, + open/1, open/2, open/3, + pwd/1, + recv/2, recv/3, recv_bin/2, + recv_chunk_start/2, recv_chunk/1, + rename/3, rmdir/2, + send/2, send/3, send_bin/3, + send_chunk_start/2, send_chunk/2, send_chunk_end/1, + type/2, user/3,user/4,account/2, + append/3, append/2, append_bin/3, + append_chunk/2, append_chunk_end/1, append_chunk_start/2]). + +%% Internal +-export([init/1, handle_call/3, handle_cast/2, + handle_info/2, terminate/2,code_change/3]). + + +%% +%% CLIENT FUNCTIONS +%% + +%% open(Host) +%% open(Host, Flags) +%% +%% Purpose: Start an ftp client and connect to a host. +%% Args: Host = string(), +%% Port = integer(), +%% Flags = [Flag], +%% Flag = verbose | debug +%% Returns: {ok, Pid} | {error, ehost} + +%%Tho only option was the host in textual form +open({option_list,Option_list})-> + %% Dbg = {debug,[trace,log,statistics]}, + %% Options = [Dbg], + Options = [], + {ok,Pid1}=case lists:keysearch(flags,1,Option_list) of + {value,{flags,Flags}}-> + {ok, Pid} = gen_server:start_link(?MODULE, [Flags], Options); + false -> + {ok, Pid} = gen_server:start_link(?MODULE, [], Options) + end, + gen_server:call(Pid1, {open, ip_comm,Option_list}, infinity); + + +%%The only option was the tuple form of the ip-number +open(Host)when tuple(Host) -> + open(Host, ?FTP_PORT, []); + +%%Host is the string form of the hostname +open(Host)-> + open(Host,?FTP_PORT,[]). + + + +open(Host, Port) when integer(Port) -> + open(Host,Port,[]); + +open(Host, Flags) when list(Flags) -> + open(Host,?FTP_PORT, Flags). + +open(Host,Port,Flags) when integer(Port), list(Flags) -> + %% Dbg = {debug,[trace,log,statistics]}, + %% Options = [Dbg], + Options = [], + {ok, Pid} = gen_server:start_link(?MODULE, [Flags], Options), + gen_server:call(Pid, {open, ip_comm, Host, Port}, infinity). + +%% user(Pid, User, Pass) +%% Purpose: Login. +%% Args: Pid = pid(), User = Pass = string() +%% Returns: ok | {error, euser} | {error, econn} +user(Pid, User, Pass) -> + gen_server:call(Pid, {user, User, Pass}, infinity). + +%% user(Pid, User, Pass,Acc) +%% Purpose: Login whith a supplied account name +%% Args: Pid = pid(), User = Pass = Acc = string() +%% Returns: ok | {error, euser} | {error, econn} | {error, eacct} +user(Pid, User, Pass,Acc) -> + gen_server:call(Pid, {user, User, Pass,Acc}, infinity). + +%% account(Pid,Acc) +%% Purpose: Set a user Account. +%% Args: Pid = pid(), Acc= string() +%% Returns: ok | {error, eacct} +account(Pid,Acc) -> + gen_server:call(Pid, {account,Acc}, infinity). + +%% pwd(Pid) +%% +%% Purpose: Get the current working directory at remote server. +%% Args: Pid = pid() +%% Returns: {ok, Dir} | {error, elogin} | {error, econn} +pwd(Pid) -> + gen_server:call(Pid, pwd, infinity). + +%% lpwd(Pid) +%% +%% Purpose: Get the current working directory at local server. +%% Args: Pid = pid() +%% Returns: {ok, Dir} | {error, elogin} +lpwd(Pid) -> + gen_server:call(Pid, lpwd, infinity). + +%% cd(Pid, Dir) +%% +%% Purpose: Change current working directory at remote server. +%% Args: Pid = pid(), Dir = string() +%% Returns: ok | {error, epath} | {error, elogin} | {error, econn} +cd(Pid, Dir) -> + gen_server:call(Pid, {cd, Dir}, infinity). + +%% lcd(Pid, Dir) +%% +%% Purpose: Change current working directory for the local client. +%% Args: Pid = pid(), Dir = string() +%% Returns: ok | {error, epath} +lcd(Pid, Dir) -> + gen_server:call(Pid, {lcd, Dir}, infinity). + +%% ls(Pid) +%% ls(Pid, Dir) +%% +%% Purpose: List the contents of current directory (ls/1) or directory +%% Dir (ls/2) at remote server. +%% Args: Pid = pid(), Dir = string() +%% Returns: {ok, Listing} | {error, epath} | {error, elogin} | {error, econn} +ls(Pid) -> + ls(Pid, ""). +ls(Pid, Dir) -> + gen_server:call(Pid, {dir, long, Dir}, infinity). + +%% nlist(Pid) +%% nlist(Pid, Dir) +%% +%% Purpose: List the contents of current directory (ls/1) or directory +%% Dir (ls/2) at remote server. The returned list is a stream +%% of file names. +%% Args: Pid = pid(), Dir = string() +%% Returns: {ok, Listing} | {error, epath} | {error, elogin} | {error, econn} +nlist(Pid) -> + nlist(Pid, ""). +nlist(Pid, Dir) -> + gen_server:call(Pid, {dir, short, Dir}, infinity). + +%% rename(Pid, CurrFile, NewFile) +%% +%% Purpose: Rename a file at remote server. +%% Args: Pid = pid(), CurrFile = NewFile = string() +%% Returns: ok | {error, epath} | {error, elogin} | {error, econn} +rename(Pid, CurrFile, NewFile) -> + gen_server:call(Pid, {rename, CurrFile, NewFile}, infinity). + +%% delete(Pid, File) +%% +%% Purpose: Remove file at remote server. +%% Args: Pid = pid(), File = string() +%% Returns: ok | {error, epath} | {error, elogin} | {error, econn} +delete(Pid, File) -> + gen_server:call(Pid, {delete, File}, infinity). + +%% mkdir(Pid, Dir) +%% +%% Purpose: Make directory at remote server. +%% Args: Pid = pid(), Dir = string() +%% Returns: ok | {error, epath} | {error, elogin} | {error, econn} +mkdir(Pid, Dir) -> + gen_server:call(Pid, {mkdir, Dir}, infinity). + +%% rmdir(Pid, Dir) +%% +%% Purpose: Remove directory at remote server. +%% Args: Pid = pid(), Dir = string() +%% Returns: ok | {error, epath} | {error, elogin} | {error, econn} +rmdir(Pid, Dir) -> + gen_server:call(Pid, {rmdir, Dir}, infinity). + +%% type(Pid, Type) +%% +%% Purpose: Set transfer type. +%% Args: Pid = pid(), Type = ascii | binary +%% Returns: ok | {error, etype} | {error, elogin} | {error, econn} +type(Pid, Type) -> + gen_server:call(Pid, {type, Type}, infinity). + +%% recv(Pid, RFile [, LFile]) +%% +%% Purpose: Transfer file from remote server. +%% Args: Pid = pid(), RFile = LFile = string() +%% Returns: ok | {error, epath} | {error, elogin} | {error, econn} +recv(Pid, RFile) -> + recv(Pid, RFile, ""). + +recv(Pid, RFile, LFile) -> + gen_server:call(Pid, {recv, RFile, LFile}, infinity). + +%% recv_bin(Pid, RFile) +%% +%% Purpose: Transfer file from remote server into binary. +%% Args: Pid = pid(), RFile = string() +%% Returns: {ok, Bin} | {error, epath} | {error, elogin} | {error, econn} +recv_bin(Pid, RFile) -> + gen_server:call(Pid, {recv_bin, RFile}, infinity). + +%% recv_chunk_start(Pid, RFile) +%% +%% Purpose: Start receive of chunks of remote file. +%% Args: Pid = pid(), RFile = string(). +%% Returns: ok | {error, elogin} | {error, epath} | {error, econn} +recv_chunk_start(Pid, RFile) -> + gen_server:call(Pid, {recv_chunk_start, RFile}, infinity). + + +%% recv_chunk(Pid, RFile) +%% +%% Purpose: Transfer file from remote server into binary in chunks +%% Args: Pid = pid(), RFile = string() +%% Returns: Reference +recv_chunk(Pid) -> + gen_server:call(Pid, recv_chunk, infinity). + +%% send(Pid, LFile [, RFile]) +%% +%% Purpose: Transfer file to remote server. +%% Args: Pid = pid(), LFile = RFile = string() +%% Returns: ok | {error, epath} | {error, elogin} | {error, econn} +send(Pid, LFile) -> + send(Pid, LFile, ""). + +send(Pid, LFile, RFile) -> + gen_server:call(Pid, {send, LFile, RFile}, infinity). + +%% send_bin(Pid, Bin, RFile) +%% +%% Purpose: Transfer a binary to a remote file. +%% Args: Pid = pid(), Bin = binary(), RFile = string() +%% Returns: ok | {error, epath} | {error, elogin} | {error, enotbinary} +%% | {error, econn} +send_bin(Pid, Bin, RFile) when binary(Bin) -> + gen_server:call(Pid, {send_bin, Bin, RFile}, infinity); +send_bin(Pid, Bin, RFile) -> + {error, enotbinary}. + +%% send_chunk_start(Pid, RFile) +%% +%% Purpose: Start transfer of chunks to remote file. +%% Args: Pid = pid(), RFile = string(). +%% Returns: ok | {error, elogin} | {error, epath} | {error, econn} +send_chunk_start(Pid, RFile) -> + gen_server:call(Pid, {send_chunk_start, RFile}, infinity). + + +%% append_chunk_start(Pid, RFile) +%% +%% Purpose: Start append chunks of data to remote file. +%% Args: Pid = pid(), RFile = string(). +%% Returns: ok | {error, elogin} | {error, epath} | {error, econn} +append_chunk_start(Pid, RFile) -> + gen_server:call(Pid, {append_chunk_start, RFile}, infinity). + + +%% send_chunk(Pid, Bin) +%% +%% Purpose: Send chunk to remote file. +%% Args: Pid = pid(), Bin = binary(). +%% Returns: ok | {error, elogin} | {error, enotbinary} | {error, echunk} +%% | {error, econn} +send_chunk(Pid, Bin) when binary(Bin) -> + gen_server:call(Pid, {send_chunk, Bin}, infinity); +send_chunk(Pid, Bin) -> + {error, enotbinary}. + +%%append_chunk(Pid, Bin) +%% +%% Purpose: Append chunk to remote file. +%% Args: Pid = pid(), Bin = binary(). +%% Returns: ok | {error, elogin} | {error, enotbinary} | {error, echunk} +%% | {error, econn} +append_chunk(Pid, Bin) when binary(Bin) -> + gen_server:call(Pid, {append_chunk, Bin}, infinity); +append_chunk(Pid, Bin) -> + {error, enotbinary}. + +%% send_chunk_end(Pid) +%% +%% Purpose: End sending of chunks to remote file. +%% Args: Pid = pid(). +%% Returns: ok | {error, elogin} | {error, echunk} | {error, econn} +send_chunk_end(Pid) -> + gen_server:call(Pid, send_chunk_end, infinity). + +%% append_chunk_end(Pid) +%% +%% Purpose: End appending of chunks to remote file. +%% Args: Pid = pid(). +%% Returns: ok | {error, elogin} | {error, echunk} | {error, econn} +append_chunk_end(Pid) -> + gen_server:call(Pid, append_chunk_end, infinity). + +%% append(Pid, LFile,RFile) +%% +%% Purpose: Append the local file to the remote file +%% Args: Pid = pid(), LFile = RFile = string() +%% Returns: ok | {error, epath} | {error, elogin} | {error, econn} +append(Pid, LFile) -> + append(Pid, LFile, ""). + +append(Pid, LFile, RFile) -> + gen_server:call(Pid, {append, LFile, RFile}, infinity). + +%% append_bin(Pid, Bin, RFile) +%% +%% Purpose: Append a binary to a remote file. +%% Args: Pid = pid(), Bin = binary(), RFile = string() +%% Returns: ok | {error, epath} | {error, elogin} | {error, enotbinary} +%% | {error, econn} +append_bin(Pid, Bin, RFile) when binary(Bin) -> + gen_server:call(Pid, {append_bin, Bin, RFile}, infinity); +append_bin(Pid, Bin, RFile) -> + {error, enotbinary}. + + +%% close(Pid) +%% +%% Purpose: End the ftp session. +%% Args: Pid = pid() +%% Returns: ok +close(Pid) -> + case (catch gen_server:call(Pid, close, 30000)) of + ok -> + ok; + {'EXIT',{noproc,_}} -> + %% Already gone... + ok; + Res -> + Res + end. + +%% formaterror(Tag) +%% +%% Purpose: Return diagnostics. +%% Args: Tag = atom() | {error, atom()} +%% Returns: string(). +formaterror(Tag) -> + errstr(Tag). + +%% help() +%% +%% Purpose: Print list of valid commands. +%% +%% Undocumented. +%% +help() -> + io:format("\n Commands:\n" + " ---------\n" + " cd(Pid, Dir)\n" + " close(Pid)\n" + " delete(Pid, File)\n" + " formaterror(Tag)\n" + " help()\n" + " lcd(Pid, Dir)\n" + " lpwd(Pid)\n" + " ls(Pid [, Dir])\n" + " mkdir(Pid, Dir)\n" + " nlist(Pid [, Dir])\n" + " open(Host [Port, Flags])\n" + " pwd(Pid)\n" + " recv(Pid, RFile [, LFile])\n" + " recv_bin(Pid, RFile)\n" + " recv_chunk_start(Pid, RFile)\n" + " recv_chunk(Pid)\n" + " rename(Pid, CurrFile, NewFile)\n" + " rmdir(Pid, Dir)\n" + " send(Pid, LFile [, RFile])\n" + " send_chunk(Pid, Bin)\n" + " send_chunk_start(Pid, RFile)\n" + " send_chunk_end(Pid)\n" + " send_bin(Pid, Bin, RFile)\n" + " append(Pid, LFile [, RFile])\n" + " append_chunk(Pid, Bin)\n" + " append_chunk_start(Pid, RFile)\n" + " append_chunk_end(Pid)\n" + " append_bin(Pid, Bin, RFile)\n" + " type(Pid, Type)\n" + " account(Pid,Account)\n" + " user(Pid, User, Pass)\n" + " user(Pid, User, Pass,Account)\n"). + +%% +%% INIT +%% + +-record(state, {csock = undefined, dsock = undefined, flags = undefined, + ldir = undefined, type = undefined, chunk = false, + pending = undefined}). + +init([Flags]) -> + sock_start(), + put(debug,get_debug(Flags)), + put(verbose,get_verbose(Flags)), + process_flag(priority, low), + {ok, LDir} = file:get_cwd(), + {ok, #state{flags = Flags, ldir = LDir}}. + +%% +%% HANDLERS +%% + +%% First group of reply code digits +-define(POS_PREL, 1). +-define(POS_COMPL, 2). +-define(POS_INTERM, 3). +-define(TRANS_NEG_COMPL, 4). +-define(PERM_NEG_COMPL, 5). + +%% Second group of reply code digits +-define(SYNTAX,0). +-define(INFORMATION,1). +-define(CONNECTION,2). +-define(AUTH_ACC,3). +-define(UNSPEC,4). +-define(FILE_SYSTEM,5). + + +-define(STOP_RET(E),{stop, normal, {error, E}, + State#state{csock = undefined}}). + + +rescode(?POS_PREL,_,_) -> pos_prel; %%Positive Preleminary Reply +rescode(?POS_COMPL,_,_) -> pos_compl; %%Positive Completion Reply +rescode(?POS_INTERM,?AUTH_ACC,2) -> pos_interm_acct; %%Positive Intermediate Reply nedd account +rescode(?POS_INTERM,_,_) -> pos_interm; %%Positive Intermediate Reply +rescode(?TRANS_NEG_COMPL,?FILE_SYSTEM,2) -> trans_no_space; %%No storage area no action taken +rescode(?TRANS_NEG_COMPL,_,_) -> trans_neg_compl;%%Temporary Error, no action taken +rescode(?PERM_NEG_COMPL,?FILE_SYSTEM,2) -> perm_no_space; %%Permanent disk space error, the user shall not try again +rescode(?PERM_NEG_COMPL,?FILE_SYSTEM,3) -> perm_fname_not_allowed; +rescode(?PERM_NEG_COMPL,_,_) -> perm_neg_compl. + +retcode(trans_no_space,_) -> etnospc; +retcode(perm_no_space,_) -> epnospc; +retcode(perm_fname_not_allowed,_) -> efnamena; +retcode(_,Otherwise) -> Otherwise. + +handle_call({open,ip_comm,Conn_data},From,State) -> + case lists:keysearch(host,1,Conn_data) of + {value,{host,Host}}-> + Port=get_key1(port,Conn_data,?FTP_PORT), + Timeout=get_key1(timeout,Conn_data,?OPEN_TIMEOUT), + open(Host,Port,Timeout,State); + false -> + ehost + end; + +handle_call({open,ip_comm,Host,Port},From,State) -> + open(Host,Port,?OPEN_TIMEOUT,State); + +handle_call({user, User, Pass}, _From, State) -> + #state{csock = CSock} = State, + case ctrl_cmd(CSock, "USER ~s", [User]) of + pos_interm -> + case ctrl_cmd(CSock, "PASS ~s", [Pass]) of + pos_compl -> + set_type(binary, CSock), + {reply, ok, State#state{type = binary}}; + {error,enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, euser}, State} + end; + pos_compl -> + set_type(binary, CSock), + {reply, ok, State#state{type = binary}}; + {error, enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, euser}, State} + end; + +handle_call({user, User, Pass,Acc}, _From, State) -> + #state{csock = CSock} = State, + case ctrl_cmd(CSock, "USER ~s", [User]) of + pos_interm -> + case ctrl_cmd(CSock, "PASS ~s", [Pass]) of + pos_compl -> + set_type(binary, CSock), + {reply, ok, State#state{type = binary}}; + pos_interm_acct-> + case ctrl_cmd(CSock,"ACCT ~s",[Acc]) of + pos_compl-> + set_type(binary, CSock), + {reply, ok, State#state{type = binary}}; + {error,enotconn}-> + ?STOP_RET(econn); + _ -> + {reply, {error, eacct}, State} + end; + {error,enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, euser}, State} + end; + pos_compl -> + set_type(binary, CSock), + {reply, ok, State#state{type = binary}}; + {error, enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, euser}, State} + end; + +%%set_account(Acc,State)->Reply +%%Reply={reply, {error, euser}, State} | {error,enotconn}-> +handle_call({account,Acc},_From,State)-> + #state{csock = CSock} = State, + case ctrl_cmd(CSock,"ACCT ~s",[Acc]) of + pos_compl-> + {reply, ok,State}; + {error,enotconn}-> + ?STOP_RET(econn); + Error -> + debug(" error: ~p",[Error]), + {reply, {error, eacct}, State} + end; + +handle_call(pwd, _From, State) when State#state.chunk == false -> + #state{csock = CSock} = State, + %% + %% NOTE: The directory string comes over the control connection. + case sock_write(CSock, mk_cmd("PWD", [])) of + ok -> + {_, Line} = result_line(CSock), + {_, Cs} = split($", Line), % XXX Ugly + {Dir0, _} = split($", Cs), + Dir = lists:delete($", Dir0), + {reply, {ok, Dir}, State}; + {error, enotconn} -> + ?STOP_RET(econn) + end; + +handle_call(lpwd, _From, State) -> + #state{csock = CSock, ldir = LDir} = State, + {reply, {ok, LDir}, State}; + +handle_call({cd, Dir}, _From, State) when State#state.chunk == false -> + #state{csock = CSock} = State, + case ctrl_cmd(CSock, "CWD ~s", [Dir]) of + pos_compl -> + {reply, ok, State}; + {error, enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, epath}, State} + end; + +handle_call({lcd, Dir}, _From, State) -> + #state{csock = CSock, ldir = LDir0} = State, + LDir = absname(LDir0, Dir), + case file:read_file_info(LDir) of + {ok, _ } -> + {reply, ok, State#state{ldir = LDir}}; + _ -> + {reply, {error, epath}, State} + end; + +handle_call({dir, Len, Dir}, _From, State) when State#state.chunk == false -> + debug(" dir : ~p: ~s~n",[Len,Dir]), + #state{csock = CSock, type = Type} = State, + set_type(ascii, Type, CSock), + LSock = listen_data(CSock, raw), + Cmd = case Len of + short -> "NLST"; + long -> "LIST" + end, + Result = case Dir of + "" -> + ctrl_cmd(CSock, Cmd, ""); + _ -> + ctrl_cmd(CSock, Cmd ++ " ~s", [Dir]) + end, + debug(" ctrl : command result: ~p~n",[Result]), + case Result of + pos_prel -> + debug(" dbg : await the data connection", []), + DSock = accept_data(LSock), + debug(" dbg : await the data", []), + Reply0 = + case recv_data(DSock) of + {ok, DirData} -> + debug(" data : DirData: ~p~n",[DirData]), + case result(CSock) of + pos_compl -> + {ok, DirData}; + _ -> + {error, epath} + end; + {error, Reason} -> + sock_close(DSock), + verbose(" data : error: ~p, ~p~n",[Reason, result(CSock)]), + {error, epath} + end, + + debug(" ctrl : reply: ~p~n",[Reply0]), + reset_type(ascii, Type, CSock), + {reply, Reply0, State}; + {closed, _Why} -> + ?STOP_RET(econn); + _ -> + sock_close(LSock), + {reply, {error, epath}, State} + end; + + +handle_call({rename, CurrFile, NewFile}, _From, State) when State#state.chunk == false -> + #state{csock = CSock} = State, + case ctrl_cmd(CSock, "RNFR ~s", [CurrFile]) of + pos_interm -> + case ctrl_cmd(CSock, "RNTO ~s", [NewFile]) of + pos_compl -> + {reply, ok, State}; + _ -> + {reply, {error, epath}, State} + end; + {error, enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, epath}, State} + end; + +handle_call({delete, File}, _From, State) when State#state.chunk == false -> + #state{csock = CSock} = State, + case ctrl_cmd(CSock, "DELE ~s", [File]) of + pos_compl -> + {reply, ok, State}; + {error, enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, epath}, State} + end; + +handle_call({mkdir, Dir}, _From, State) when State#state.chunk == false -> + #state{csock = CSock} = State, + case ctrl_cmd(CSock, "MKD ~s", [Dir]) of + pos_compl -> + {reply, ok, State}; + {error, enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, epath}, State} + end; + +handle_call({rmdir, Dir}, _From, State) when State#state.chunk == false -> + #state{csock = CSock} = State, + case ctrl_cmd(CSock, "RMD ~s", [Dir]) of + pos_compl -> + {reply, ok, State}; + {error, enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, epath}, State} + end; + +handle_call({type, Type}, _From, State) when State#state.chunk == false -> + #state{csock = CSock} = State, + case Type of + ascii -> + set_type(ascii, CSock), + {reply, ok, State#state{type = ascii}}; + binary -> + set_type(binary, CSock), + {reply, ok, State#state{type = binary}}; + _ -> + {reply, {error, etype}, State} + end; + +handle_call({recv, RFile, LFile}, _From, State) when State#state.chunk == false -> + #state{csock = CSock, ldir = LDir} = State, + ALFile = case LFile of + "" -> + absname(LDir, RFile); + _ -> + absname(LDir, LFile) + end, + case file_open(ALFile, write) of + {ok, Fd} -> + LSock = listen_data(CSock, binary), + Ret = case ctrl_cmd(CSock, "RETR ~s", [RFile]) of + pos_prel -> + DSock = accept_data(LSock), + recv_file(DSock, Fd), + Reply0 = case result(CSock) of + pos_compl -> + ok; + _ -> + {error, epath} + end, + sock_close(DSock), + {reply, Reply0, State}; + {error, enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, epath}, State} + end, + file_close(Fd), + Ret; + {error, _What} -> + {reply, {error, epath}, State} + end; + +handle_call({recv_bin, RFile}, _From, State) when State#state.chunk == false -> + #state{csock = CSock, ldir = LDir} = State, + LSock = listen_data(CSock, binary), + case ctrl_cmd(CSock, "RETR ~s", [RFile]) of + pos_prel -> + DSock = accept_data(LSock), + Reply = recv_binary(DSock,CSock), + sock_close(DSock), + {reply, Reply, State}; + {error, enotconn} -> + ?STOP_RET(econn); + _ -> + {reply, {error, epath}, State} + end; + + +handle_call({recv_chunk_start, RFile}, _From, State) + when State#state.chunk == false -> + start_chunk_transfer("RETR",RFile,State); + +handle_call(recv_chunk, _From, State) + when State#state.chunk == true -> + do_recv_chunk(State); + + +handle_call({send, LFile, RFile}, _From, State) + when State#state.chunk == false -> + transfer_file("STOR",LFile,RFile,State); + +handle_call({append, LFile, RFile}, _From, State) + when State#state.chunk == false -> + transfer_file("APPE",LFile,RFile,State); + + +handle_call({send_bin, Bin, RFile}, _From, State) + when State#state.chunk == false -> + transfer_data("STOR",Bin,RFile,State); + +handle_call({append_bin, Bin, RFile}, _From, State) + when State#state.chunk == false -> + transfer_data("APPE",Bin,RFile,State); + + + +handle_call({send_chunk_start, RFile}, _From, State) + when State#state.chunk == false -> + start_chunk_transfer("STOR",RFile,State); + +handle_call({append_chunk_start,RFile},_From,State) + when State#state.chunk==false-> + start_chunk_transfer("APPE",RFile,State); + +handle_call({send_chunk, Bin}, _From, State) + when State#state.chunk == true -> + chunk_transfer(Bin,State); + +handle_call({append_chunk, Bin}, _From, State) + when State#state.chunk == true -> + chunk_transfer(Bin,State); + +handle_call(append_chunk_end, _From, State) + when State#state.chunk == true -> + end_chunk_transfer(State); + +handle_call(send_chunk_end, _From, State) + when State#state.chunk == true -> + end_chunk_transfer(State); + + + +handle_call(close, _From, State) when State#state.chunk == false -> + #state{csock = CSock} = State, + ctrl_cmd(CSock, "QUIT", []), + sock_close(CSock), + {stop, normal, ok, State}; + +handle_call(_, _From, State) when State#state.chunk == true -> + {reply, {error, echunk}, State}. + + +handle_cast(Msg, State) -> + {noreply, State}. + + +handle_info({Sock, {fromsocket, Bytes}}, State) when Sock == State#state.csock -> + put(leftovers, Bytes ++ leftovers()), + {noreply, State}; + +%% Data connection closed (during chunk sending) +handle_info({Sock, {socket_closed, _Reason}}, State) when Sock == State#state.dsock -> + {noreply, State#state{dsock = undefined}}; + +%% Control connection closed. +handle_info({Sock, {socket_closed, _Reason}}, State) when Sock == State#state.csock -> + debug(" sc : ~s~n",[leftovers()]), + {stop, ftp_server_close, State#state{csock = undefined}}; + +handle_info(Info, State) -> + error_logger:info_msg("ftp : ~w : Unexpected message: ~w\n", [self(),Info]), + {noreply, State}. + +code_change(OldVsn,State,Extra)-> + {ok,State}. + +terminate(Reason, State) -> + ok. +%% +%% OPEN CONNECTION +%% +open(Host,Port,Timeout,State)-> + case sock_connect(Host,Port,Timeout) of + {error, What} -> + {stop, normal, {error, What}, State}; + CSock -> + case result(CSock, State#state.flags) of + {error,Reason} -> + sock_close(CSock), + {stop,normal,{error,Reason},State}; + _ -> % We should really check this... + {reply, {ok, self()}, State#state{csock = CSock}} + end + end. + + + +%% +%% CONTROL CONNECTION +%% + +ctrl_cmd(CSock, Fmt, Args) -> + Cmd = mk_cmd(Fmt, Args), + case sock_write(CSock, Cmd) of + ok -> + debug(" cmd : ~s",[Cmd]), + result(CSock); + {error, enotconn} -> + {error, enotconn}; + Other -> + Other + end. + +mk_cmd(Fmt, Args) -> + [io_lib:format(Fmt, Args)| "\r\n"]. % Deep list ok. + +%% +%% TRANSFER TYPE +%% + +%% +%% set_type(NewType, CurrType, CSock) +%% reset_type(NewType, CurrType, CSock) +%% +set_type(Type, Type, CSock) -> + ok; +set_type(NewType, _OldType, CSock) -> + set_type(NewType, CSock). + +reset_type(Type, Type, CSock) -> + ok; +reset_type(_NewType, OldType, CSock) -> + set_type(OldType, CSock). + +set_type(ascii, CSock) -> + ctrl_cmd(CSock, "TYPE A", []); +set_type(binary, CSock) -> + ctrl_cmd(CSock, "TYPE I", []). + +%% +%% DATA CONNECTION +%% + +%% Create a listen socket for a data connection and send a PORT command +%% containing the IP address and port number. Mode is binary or raw. +%% +listen_data(CSock, Mode) -> + {IP, _} = sock_name(CSock), % IP address of control conn. + LSock = sock_listen(Mode, IP), + Port = sock_listen_port(LSock), + {A1, A2, A3, A4} = IP, + {P1, P2} = {Port div 256, Port rem 256}, + ctrl_cmd(CSock, "PORT ~w,~w,~w,~w,~w,~w", [A1, A2, A3, A4, P1, P2]), + LSock. + +%% +%% Accept the data connection and close the listen socket. +%% +accept_data(LSock) -> + Sock = sock_accept(LSock), + sock_close(LSock), + Sock. + +%% +%% DATA COLLECTION (ls, dir) +%% +%% Socket is a byte stream in ASCII mode. +%% + +%% Receive data (from data connection). +recv_data(Sock) -> + recv_data(Sock, [], 0). +recv_data(Sock, Sofar, ?OPER_TIMEOUT) -> + sock_close(Sock), + {ok, lists:flatten(lists:reverse(Sofar))}; +recv_data(Sock, Sofar, Retry) -> + case sock_read(Sock) of + {ok, Data} -> + debug(" dbg : received some data: ~n~s", [Data]), + recv_data(Sock, [Data| Sofar], 0); + {error, timeout} -> + %% Retry.. + recv_data(Sock, Sofar, Retry+1); + {error, Reason} -> + SoFar1 = lists:flatten(lists:reverse(Sofar)), + {error, {socket_error, Reason, SoFar1, Retry}}; + {closed, _} -> + {ok, lists:flatten(lists:reverse(Sofar))} + end. + +%% +%% BINARY TRANSFER +%% + +%% -------------------------------------------------- + +%% recv_binary(DSock,CSock) = {ok,Bin} | {error,Reason} +%% +recv_binary(DSock,CSock) -> + recv_binary1(recv_binary2(DSock,[],0),CSock). + +recv_binary1(Reply,Sock) -> + case result(Sock) of + pos_compl -> Reply; + _ -> {error, epath} + end. + +recv_binary2(Sock, _Bs, ?OPER_TIMEOUT) -> + sock_close(Sock), + {error,eclosed}; +recv_binary2(Sock, Bs, Retry) -> + case sock_read(Sock) of + {ok, Bin} -> + recv_binary2(Sock, [Bs, Bin], 0); + {error, timeout} -> + recv_binary2(Sock, Bs, Retry+1); + {closed, _Why} -> + {ok,list_to_binary(Bs)} + end. + +%% -------------------------------------------------- + +%% +%% recv_chunk +%% + +do_recv_chunk(#state{dsock = undefined} = State) -> + {reply, {error,econn}, State}; +do_recv_chunk(State) -> + recv_chunk1(recv_chunk2(State, 0), State). + +recv_chunk1({ok, _Bin} = Reply, State) -> + {reply, Reply, State}; +%% Reply = ok | {error, Reason} +recv_chunk1(Reply, #state{csock = CSock} = State) -> + State1 = State#state{dsock = undefined, chunk = false}, + case result(CSock) of + pos_compl -> + {reply, Reply, State1}; + _ -> + {reply, {error, epath}, State1} + end. + +recv_chunk2(#state{dsock = DSock} = State, ?OPER_TIMEOUT) -> + sock_close(DSock), + {error, eclosed}; +recv_chunk2(#state{dsock = DSock} = State, Retry) -> + case sock_read(DSock) of + {ok, Bin} -> + {ok, Bin}; + {error, timeout} -> + recv_chunk2(State, Retry+1); + {closed, Reason} -> + debug(" dbg : socket closed: ~p", [Reason]), + ok + end. + + +%% -------------------------------------------------- + +%% +%% FILE TRANSFER +%% + +recv_file(Sock, Fd) -> + recv_file(Sock, Fd, 0). + +recv_file(Sock, Fd, ?OPER_TIMEOUT) -> + sock_close(Sock), + {closed, timeout}; +recv_file(Sock, Fd, Retry) -> + case sock_read(Sock) of + {ok, Bin} -> + file_write(Fd, Bin), + recv_file(Sock, Fd); + {error, timeout} -> + recv_file(Sock, Fd, Retry+1); +% {error, Reason} -> +% SoFar1 = lists:flatten(lists:reverse(Sofar)), +% exit({socket_error, Reason, Sock, SoFar1, Retry}); + {closed, How} -> + {closed, How} + end. + +%% +%% send_file(Fd, Sock) = ok | {error, Why} +%% + +send_file(Fd, Sock) -> + {N, Bin} = file_read(Fd), + if + N > 0 -> + case sock_write(Sock, Bin) of + ok -> + send_file(Fd, Sock); + {error, Reason} -> + {error, Reason} + end; + true -> + ok + end. + + + +%% +%% PARSING OF RESULT LINES +%% + +%% Excerpt from RFC 959: +%% +%% "A reply is defined to contain the 3-digit code, followed by Space +%% <SP>, followed by one line of text (where some maximum line length +%% has been specified), and terminated by the Telnet end-of-line +%% code. There will be cases however, where the text is longer than +%% a single line. In these cases the complete text must be bracketed +%% so the User-process knows when it may stop reading the reply (i.e. +%% stop processing input on the control connection) and go do other +%% things. This requires a special format on the first line to +%% indicate that more than one line is coming, and another on the +%% last line to designate it as the last. At least one of these must +%% contain the appropriate reply code to indicate the state of the +%% transaction. To satisfy all factions, it was decided that both +%% the first and last line codes should be the same. +%% +%% Thus the format for multi-line replies is that the first line +%% will begin with the exact required reply code, followed +%% immediately by a Hyphen, "-" (also known as Minus), followed by +%% text. The last line will begin with the same code, followed +%% immediately by Space <SP>, optionally some text, and the Telnet +%% end-of-line code. +%% +%% For example: +%% 123-First line +%% Second line +%% 234 A line beginning with numbers +%% 123 The last line +%% +%% The user-process then simply needs to search for the second +%% occurrence of the same reply code, followed by <SP> (Space), at +%% the beginning of a line, and ignore all intermediary lines. If +%% an intermediary line begins with a 3-digit number, the Server +%% must pad the front to avoid confusion. +%% +%% This scheme allows standard system routines to be used for +%% reply information (such as for the STAT reply), with +%% "artificial" first and last lines tacked on. In rare cases +%% where these routines are able to generate three digits and a +%% Space at the beginning of any line, the beginning of each +%% text line should be offset by some neutral text, like Space. +%% +%% This scheme assumes that multi-line replies may not be nested." + +%% We have to collect the stream of result characters into lines (ending +%% in "\r\n"; we check for "\n"). When a line is assembled, left-over +%% characters are saved in the process dictionary. +%% + +%% result(Sock) = rescode() +%% +result(Sock) -> + result(Sock, false). + +result_line(Sock) -> + result(Sock, true). + +%% result(Sock, Bool) = {error,Reason} | rescode() | {rescode(), Lines} +%% Printout if Bool = true. +%% +result(Sock, RetForm) -> + case getline(Sock) of + Line when length(Line) > 3 -> + [D1, D2, D3| Tail] = Line, + case Tail of + [$-| _] -> + parse_to_end(Sock, [D1, D2, D3, $ ]); % 3 digits + space + _ -> + ok + end, + result(D1,D2,D3,Line,RetForm); + _ -> + retform(rescode(?PERM_NEG_COMPL,-1,-1),[],RetForm) + end. + +result(D1,_D2,_D3,Line,_RetForm) when D1 - $0 > 10 -> + {error,{invalid_server_response,Line}}; +result(D1,_D2,_D3,Line,_RetForm) when D1 - $0 < 0 -> + {error,{invalid_server_response,Line}}; +result(D1,D2,D3,Line,RetForm) -> + Res1 = D1 - $0, + Res2 = D2 - $0, + Res3 = D3 - $0, + verbose(" ~w : ~s", [Res1, Line]), + retform(rescode(Res1,Res2,Res3),Line,RetForm). + +retform(ResCode,Line,true) -> + {ResCode,Line}; +retform(ResCode,_,_) -> + ResCode. + +leftovers() -> + case get(leftovers) of + undefined -> []; + X -> X + end. + +%% getline(Sock) = Line +%% +getline(Sock) -> + getline(Sock, leftovers()). + +getline(Sock, Rest) -> + getline1(Sock, split($\n, Rest), 0). + +getline1(Sock, {[], Rest}, ?OPER_TIMEOUT) -> + sock_close(Sock), + put(leftovers, Rest), + []; +getline1(Sock, {[], Rest}, Retry) -> + case sock_read(Sock) of + {ok, More} -> + debug(" read : ~s~n",[More]), + getline(Sock, Rest ++ More); + {error, timeout} -> + %% Retry.. + getline1(Sock, {[], Rest}, Retry+1); + Error -> + put(leftovers, Rest), + [] + end; +getline1(Sock, {Line, Rest}, Retry) -> + put(leftovers, Rest), + Line. + +parse_to_end(Sock, Prefix) -> + Line = getline(Sock), + case lists:prefix(Prefix, Line) of + false -> + parse_to_end(Sock, Prefix); + true -> + ok + end. + + +%% Split list after first occurence of S. +%% Returns {Prefix, Suffix} ({[], Cs} if S not found). +split(S, Cs) -> + split(S, Cs, []). + +split(S, [S| Cs], As) -> + {lists:reverse([S|As]), Cs}; +split(S, [C| Cs], As) -> + split(S, Cs, [C| As]); +split(_, [], As) -> + {[], lists:reverse(As)}. + +%% +%% FILE INTERFACE +%% +%% All files are opened raw in binary mode. +%% +-define(BUFSIZE, 4096). + +file_open(File, Option) -> + file:open(File, [raw, binary, Option]). + +file_close(Fd) -> + file:close(Fd). + + +file_read(Fd) -> % Compatible with pre R2A. + case file:read(Fd, ?BUFSIZE) of + {ok, {N, Bytes}} -> + {N, Bytes}; + {ok, Bytes} -> + {size(Bytes), Bytes}; + eof -> + {0, []} + end. + +file_write(Fd, Bytes) -> + file:write(Fd, Bytes). + +absname(Dir, File) -> % Args swapped. + filename:absname(File, Dir). + + + +%% sock_start() +%% + +%% +%% USE GEN_TCP +%% + +sock_start() -> + inet_db:start(). + +%% +%% Connect to FTP server at Host (default is TCP port 21) in raw mode, +%% in order to establish a control connection. +%% + +sock_connect(Host,Port,TimeOut) -> + debug(" info : connect to server on ~p:~p~n",[Host,Port]), + Opts = [{packet, 0}, {active, false}], + case (catch gen_tcp:connect(Host, Port, Opts,TimeOut)) of + {'EXIT', R1} -> % XXX Probably no longer needed. + debug(" error: socket connectionn failed with exit reason:" + "~n ~p",[R1]), + {error, ehost}; + {error, R2} -> + debug(" error: socket connectionn failed with exit reason:" + "~n ~p",[R2]), + {error, ehost}; + {ok, Sock} -> + Sock + end. + +%% +%% Create a listen socket (any port) in binary or raw non-packet mode for +%% data connection. +%% +sock_listen(Mode, IP) -> + Opts = case Mode of + binary -> + [binary, {packet, 0}]; + raw -> + [{packet, 0}] + end, + {ok, Sock} = gen_tcp:listen(0, [{ip, IP}, {active, false} | Opts]), + Sock. + +sock_accept(LSock) -> + {ok, Sock} = gen_tcp:accept(LSock), + Sock. + +sock_close(undefined) -> + ok; +sock_close(Sock) -> + gen_tcp:close(Sock). + +sock_read(Sock) -> + case gen_tcp:recv(Sock, 0, ?BYTE_TIMEOUT) of + {ok, Bytes} -> + {ok, Bytes}; + + {error, closed} -> + {closed, closed}; % Yes + + %% --- OTP-4770 begin --- + %% + %% This seems to happen on windows + %% "Someone" tried to close an already closed socket... + %% + + {error, enotsock} -> + {closed, enotsock}; + + %% + %% --- OTP-4770 end --- + + {error, etimedout} -> + {error, timeout}; + + Other -> + Other + end. + +%% receive +%% {tcp, Sock, Bytes} -> +%% {ok, Bytes}; +%% {tcp_closed, Sock} -> +%% {closed, closed} +%% end. + +sock_write(Sock, Bytes) -> + gen_tcp:send(Sock, Bytes). + +sock_name(Sock) -> + {ok, {IP, Port}} = inet:sockname(Sock), + {IP, Port}. + +sock_listen_port(LSock) -> + {ok, Port} = inet:port(LSock), + Port. + + +%% +%% ERROR STRINGS +%% +errstr({error, Reason}) -> + errstr(Reason); + +errstr(echunk) -> "Synchronisation error during chung sending."; +errstr(eclosed) -> "Session has been closed."; +errstr(econn) -> "Connection to remote server prematurely closed."; +errstr(eexists) ->"File or directory already exists."; +errstr(ehost) -> "Host not found, FTP server not found, " +"or connection rejected."; +errstr(elogin) -> "User not logged in."; +errstr(enotbinary) -> "Term is not a binary."; +errstr(epath) -> "No such file or directory, already exists, " +"or permission denied."; +errstr(etype) -> "No such type."; +errstr(euser) -> "User name or password not valid."; +errstr(etnospc) -> "Insufficient storage space in system."; +errstr(epnospc) -> "Exceeded storage allocation " +"(for current directory or dataset)."; +errstr(efnamena) -> "File name not allowed."; +errstr(Reason) -> + lists:flatten(io_lib:format("Unknown error: ~w", [Reason])). + + + +%% ---------------------------------------------------------- + +get_verbose(Params) -> check_param(verbose,Params). + +get_debug(Flags) -> check_param(debug,Flags). + +check_param(P,Ps) -> lists:member(P,Ps). + + +%% verbose -> ok +%% +%% Prints the string if the Flags list is non-epmty +%% +%% Params: F Format string +%% A Arguments to the format string +%% +verbose(F,A) -> verbose(get(verbose),F,A). + +verbose(true,F,A) -> print(F,A); +verbose(_,_F,_A) -> ok. + + + + +%% debug -> ok +%% +%% Prints the string if debug enabled +%% +%% Params: F Format string +%% A Arguments to the format string +%% +debug(F,A) -> debug(get(debug),F,A). + +debug(true,F,A) -> print(F,A); +debug(_,_F,_A) -> ok. + + +print(F,A) -> io:format(F,A). + + + +transfer_file(Cmd,LFile,RFile,State)-> + #state{csock = CSock, ldir = LDir} = State, + ARFile = case RFile of + "" -> + LFile; + _ -> + RFile + end, + ALFile = absname(LDir, LFile), + case file_open(ALFile, read) of + {ok, Fd} -> + LSock = listen_data(CSock, binary), + case ctrl_cmd(CSock, "~s ~s", [Cmd,ARFile]) of + pos_prel -> + DSock = accept_data(LSock), + SFreply = send_file(Fd, DSock), + file_close(Fd), + sock_close(DSock), + case {SFreply,result(CSock)} of + {ok,pos_compl} -> + {reply, ok, State}; + {ok,Other} -> + debug(" error: unknown reply: ~p~n",[Other]), + {reply, {error, epath}, State}; + {{error,Why},Result} -> + ?STOP_RET(retcode(Result,econn)) + end; + {error, enotconn} -> + ?STOP_RET(econn); + Other -> + debug(" error: ctrl failed: ~p~n",[Other]), + {reply, {error, epath}, State} + end; + {error, Reason} -> + debug(" error: file open: ~p~n",[Reason]), + {reply, {error, epath}, State} + end. + +transfer_data(Cmd,Bin,RFile,State)-> + #state{csock = CSock, ldir = LDir} = State, + LSock = listen_data(CSock, binary), + case ctrl_cmd(CSock, "~s ~s", [Cmd,RFile]) of + pos_prel -> + DSock = accept_data(LSock), + SReply = sock_write(DSock, Bin), + sock_close(DSock), + case {SReply,result(CSock)} of + {ok,pos_compl} -> + {reply, ok, State}; + {ok,trans_no_space} -> + ?STOP_RET(etnospc); + {ok,perm_no_space} -> + ?STOP_RET(epnospc); + {ok,perm_fname_not_allowed} -> + ?STOP_RET(efnamena); + {ok,Other} -> + debug(" error: unknown reply: ~p~n",[Other]), + {reply, {error, epath}, State}; + {{error,Why},Result} -> + ?STOP_RET(retcode(Result,econn)) + %% {{error,_Why},_Result} -> + %% ?STOP_RET(econn) + end; + + {error, enotconn} -> + ?STOP_RET(econn); + + Other -> + debug(" error: ctrl failed: ~p~n",[Other]), + {reply, {error, epath}, State} + end. + + +start_chunk_transfer(Cmd, RFile, #state{csock = CSock} = State) -> + LSock = listen_data(CSock, binary), + case ctrl_cmd(CSock, "~s ~s", [Cmd,RFile]) of + pos_prel -> + DSock = accept_data(LSock), + {reply, ok, State#state{dsock = DSock, chunk = true}}; + {error, enotconn} -> + ?STOP_RET(econn); + Otherwise -> + debug(" error: ctrl failed: ~p~n",[Otherwise]), + {reply, {error, epath}, State} + end. + + +chunk_transfer(Bin,State)-> + #state{dsock = DSock, csock = CSock} = State, + case DSock of + undefined -> + {reply,{error,econn},State}; + _ -> + case sock_write(DSock, Bin) of + ok -> + {reply, ok, State}; + Other -> + debug(" error: chunk write error: ~p~n",[Other]), + {reply, {error, econn}, State#state{dsock = undefined}} + end + end. + + + +end_chunk_transfer(State)-> + #state{csock = CSock, dsock = DSock} = State, + case DSock of + undefined -> + Result = result(CSock), + case Result of + pos_compl -> + {reply,ok,State#state{dsock = undefined, + chunk = false}}; + trans_no_space -> + ?STOP_RET(etnospc); + perm_no_space -> + ?STOP_RET(epnospc); + perm_fname_not_allowed -> + ?STOP_RET(efnamena); + Result -> + debug(" error: send chunk end (1): ~p~n", + [Result]), + {reply,{error,epath},State#state{dsock = undefined, + chunk = false}} + end; + _ -> + sock_close(DSock), + Result = result(CSock), + case Result of + pos_compl -> + {reply,ok,State#state{dsock = undefined, + chunk = false}}; + trans_no_space -> + sock_close(CSock), + ?STOP_RET(etnospc); + perm_no_space -> + sock_close(CSock), + ?STOP_RET(epnospc); + perm_fname_not_allowed -> + sock_close(CSock), + ?STOP_RET(efnamena); + Result -> + debug(" error: send chunk end (2): ~p~n", + [Result]), + {reply,{error,epath},State#state{dsock = undefined, + chunk = false}} + end + end. + +get_key1(Key,List,Default)-> + case lists:keysearch(Key,1,List)of + {value,{_,Val}}-> + Val; + false-> + Default + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/http.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/http.erl new file mode 100644 index 0000000000..a732f23aec --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/http.erl @@ -0,0 +1,260 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Mobile Arts AB +%% Portions created by Mobile Arts are Copyright 2002, Mobile Arts AB +%% All Rights Reserved.'' +%% +%% + +%%% This version of the HTTP/1.1 client implements: +%%% - RFC 2616 HTTP 1.1 client part +%%% - RFC 2817 Upgrading to TLS Within HTTP/1.1 (not yet!) +%%% - RFC 2818 HTTP Over TLS +%%% - RFC 3229 Delta encoding in HTTP (not yet!) +%%% - RFC 3230 Instance Digests in HTTP (not yet!) +%%% - RFC 3310 Authentication and Key Agreement (AKA) (not yet!) +%%% - HTTP/1.1 Specification Errata found at +%%% http://world.std.com/~lawrence/http_errata.html +%%% Additionaly follows the following recommendations: +%%% - RFC 3143 Known HTTP Proxy/Caching Problems (not yet!) +%%% - draft-nottingham-hdrreg-http-00.txt (not yet!) +%%% +%%% Depends on +%%% - uri.erl for all URL parsing (except what is handled by the C driver) +%%% - http_lib.erl for all parsing of body and headers +%%% +%%% Supported Settings are: +%%% http_timeout % (int) Milliseconds before a request times out +%%% http_useproxy % (bool) True if a proxy should be used +%%% http_proxy % (string) Proxy +%%% http_noproxylist % (list) List with hosts not requiring proxy +%%% http_autoredirect % (bool) True if automatic redirection on 30X responses +%%% http_ssl % (list) SSL settings. A non-empty list enables SSL/TLS +%%% support in the HTTP client +%%% http_pipelinesize % (int) Length of pipeline. 1 means no pipeline. +%%% Only has effect when initiating a new session. +%%% http_sessions % (int) Max number of open sessions for {Addr,Port} +%%% +%%% TODO: (Known bugs!) +%% - Cache handling +%% - Doesn't handle a bunch of entity headers properly +%% - Better handling of status codes different from 200,30X and 50X +%% - Many of the settings above are not implemented! +%% - close_session/2 and cancel_request/1 doesn't work +%% - Variable pipe size. +%% - Due to the fact that inet_drv only has a single timer, the timeouts given +%% for pipelined requests are not ok (too long) +%% +%% Note: +%% - Some servers (e.g. Microsoft-IIS/5.0) may sometimes not return a proper +%% 'Location' header on a redirect. +%% The client will fail with {error,no_scheme} in these cases. + +-module(http). +-author("[email protected]"). + +-export([start/0, + request/3,request/4,cancel_request/1, + request_sync/2,request_sync/3]). + +-include("http.hrl"). +-include("jnets_httpd.hrl"). + +-define(START_OPTIONS,[]). + +%%% HTTP Client manager. Used to store open connections. +%%% Will be started automatically unless started explicitly. +start() -> + application:start(ssl), + httpc_manager:start(). + +%%% Asynchronous HTTP request that spawns a handler. +%%% Method HTTPReq +%%% options,get,head,delete,trace = {Url,Headers} +%%% post,put = {Url,Headers,ContentType,Body} +%%% where Url is a {Scheme,Host,Port,PathQuery} tuple, as returned by uri.erl +%%% +%%% Returns: {ok,ReqId} | +%%% {error,Reason} +%%% If {ok,Pid} was returned, the handler will return with +%%% gen_server:cast(From,{Ref,ReqId,{error,Reason}}) | +%%% gen_server:cast(From,{Ref,ReqId,{Status,Headers,Body}}) +%%% where Reason is an atom and Headers a #res_headers{} record +%%% http:format_error(Reason) gives a more informative description. +%%% +%%% Note: +%%% - Always try to find an open connection to a given host and port, and use +%%% the associated socket. +%%% - Unless a 'Connection: close' header is provided don't close the socket +%%% after a response is given +%%% - A given Pid, found in the database, might be terminated before the +%%% message is sent to the Pid. This will happen e.g., if the connection is +%%% closed by the other party and there are no pending requests. +%%% - The HTTP connection process is spawned, if necessary, in +%%% httpc_manager:add_connection/4 +request(Ref,Method,HTTPReqCont) -> + request(Ref,Method,HTTPReqCont,[],self()). + +request(Ref,Method,HTTPReqCont,Settings) -> + request(Ref,Method,HTTPReqCont,Settings,self()). + +request(Ref,Method,{{Scheme,Host,Port,PathQuery}, + Headers,ContentType,Body},Settings,From) -> + case create_settings(Settings,#client_settings{}) of + {error,Reason} -> + {error,Reason}; + CS -> + case create_headers(Headers,#req_headers{}) of + {error,Reason} -> + {error,Reason}; + H -> + Req=#request{ref=Ref,from=From, + scheme=Scheme,address={Host,Port}, + pathquery=PathQuery,method=Method, + headers=H,content={ContentType,Body}, + settings=CS}, + httpc_manager:request(Req) + end + end; +request(Ref,Method,{Url,Headers},Settings,From) -> + request(Ref,Method,{Url,Headers,[],[]},Settings,From). + +%%% Cancels requests identified with ReqId. +%%% FIXME! Doesn't work... +cancel_request(ReqId) -> + httpc_manager:cancel_request(ReqId). + +%%% Close all sessions currently open to Host:Port +%%% FIXME! Doesn't work... +close_session(Host,Port) -> + httpc_manager:close_session(Host,Port). + + +%%% Synchronous HTTP request that waits until a response is created +%%% (e.g. successfull reply or timeout) +%%% Method HTTPReq +%%% options,get,head,delete,trace = {Url,Headers} +%%% post,put = {Url,Headers,ContentType,Body} +%%% where Url is a string() or a {Scheme,Host,Port,PathQuery} tuple +%%% +%%% Returns: {Status,Headers,Body} | +%%% {error,Reason} +%%% where Reason is an atom. +%%% http:format_error(Reason) gives a more informative description. +request_sync(Method,HTTPReqCont) -> + request_sync(Method,HTTPReqCont,[]). + +request_sync(Method,{Url,Headers},Settings) + when Method==options;Method==get;Method==head;Method==delete;Method==trace -> + case uri:parse(Url) of + {error,Reason} -> + {error,Reason}; + ParsedUrl -> + request_sync(Method,{ParsedUrl,Headers,[],[]},Settings,0) + end; +request_sync(Method,{Url,Headers,ContentType,Body},Settings) + when Method==post;Method==put -> + case uri:parse(Url) of + {error,Reason} -> + {error,Reason}; + ParsedUrl -> + request_sync(Method,{ParsedUrl,Headers,ContentType,Body},Settings,0) + end; +request_sync(Method,Request,Settings) -> + {error,bad_request}. + +request_sync(Method,HTTPCont,Settings,_Redirects) -> + case request(request_sync,Method,HTTPCont,Settings,self()) of + {ok,_ReqId} -> + receive + {'$gen_cast',{request_sync,_ReqId2,{Status,Headers,Body}}} -> + {Status,pp_headers(Headers),binary_to_list(Body)}; + {'$gen_cast',{request_sync,_ReqId2,{error,Reason}}} -> + {error,Reason}; + Error -> + Error + end; + Error -> + Error + end. + + +create_settings([],Out) -> + Out; +create_settings([{http_timeout,Val}|Settings],Out) -> + create_settings(Settings,Out#client_settings{timeout=Val}); +create_settings([{http_useproxy,Val}|Settings],Out) -> + create_settings(Settings,Out#client_settings{useproxy=Val}); +create_settings([{http_proxy,Val}|Settings],Out) -> + create_settings(Settings,Out#client_settings{proxy=Val}); +create_settings([{http_noproxylist,Val}|Settings],Out) -> + create_settings(Settings,Out#client_settings{noproxylist=Val}); +create_settings([{http_autoredirect,Val}|Settings],Out) -> + create_settings(Settings,Out#client_settings{autoredirect=Val}); +create_settings([{http_ssl,Val}|Settings],Out) -> + create_settings(Settings,Out#client_settings{ssl=Val}); +create_settings([{http_pipelinesize,Val}|Settings],Out) + when integer(Val),Val>0 -> + create_settings(Settings,Out#client_settings{max_quelength=Val}); +create_settings([{http_sessions,Val}|Settings],Out) + when integer(Val),Val>0 -> + create_settings(Settings,Out#client_settings{max_sessions=Val}); +create_settings([{Key,_Val}|_Settings],_Out) -> + io:format("ERROR bad settings, got ~p~n",[Key]), + {error,bad_settings}. + + +create_headers([],Req) -> + Req; +create_headers([{Key,Val}|Rest],Req) -> + case httpd_util:to_lower(Key) of + "expect" -> + create_headers(Rest,Req#req_headers{expect=Val}); + OtherKey -> + create_headers(Rest, + Req#req_headers{other=[{OtherKey,Val}| + Req#req_headers.other]}) + end. + + +pp_headers(#res_headers{connection=Connection, + transfer_encoding=Transfer_encoding, + retry_after=Retry_after, + content_length=Content_length, + content_type=Content_type, + location=Location, + other=Other}) -> + H1=case Connection of + undefined -> []; + _ -> [{'Connection',Connection}] + end, + H2=case Transfer_encoding of + undefined -> []; + _ -> [{'Transfer-Encoding',Transfer_encoding}] + end, + H3=case Retry_after of + undefined -> []; + _ -> [{'Retry-After',Retry_after}] + end, + H4=case Location of + undefined -> []; + _ -> [{'Location',Location}] + end, + HCL=case Content_length of + "0" -> []; + _ -> [{'Content-Length',Content_length}] + end, + HCT=case Content_type of + undefined -> []; + _ -> [{'Content-Type',Content_type}] + end, + H1++H2++H3++H4++HCL++HCT++Other. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/http.hrl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/http.hrl new file mode 100644 index 0000000000..6904a2379f --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/http.hrl @@ -0,0 +1,127 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Mobile Arts AB +%% Portions created by Mobile Arts are Copyright 2002, Mobile Arts AB +%% All Rights Reserved.'' +%% +%% + +-define(HTTP_REQUEST_TIMEOUT, 5000). +-define(PIPELINE_LENGTH,3). +-define(OPEN_SESSIONS,400). + + +%%% FIXME! These definitions should probably be possible to defined via +%%% user settings +-define(MAX_REDIRECTS, 4). + + +%%% Note that if not persitent the connection can be closed immediately on a +%%% response, because new requests are not sent to this connection process. +%%% address, % ({Host,Port}) Destination Host and Port +-record(session,{ + id, % (int) Session Id identifies session in http_manager + clientclose, % (bool) true if client requested "close" connection + scheme, % (atom) http (HTTP/TCP) or https (TCP/SSL/TCP) + socket, % (socket) Open socket, used by connection + pipeline=[], % (list) Sent requests, not yet taken care of by the + % associated http_responder. + quelength=1, % (int) Current length of pipeline (1 when created) + max_quelength% (int) Max pipeline length + }). + +%%% [{Pid,RequestQue,QueLength},...] list where +%%% - RequestQue (implemented with a list) contains sent requests that +%%% has not yet received a response (pipelined) AND is not currently +%%% handled (awaiting data) by the session process. +%%% - QueLength is the length of this que, but + +%%% Response headers +-record(res_headers,{ +%%% --- Standard "General" headers +% cache_control, + connection, +% date, +% pragma, +% trailer, + transfer_encoding, +% upgrade, +% via, +% warning, +%%% --- Standard "Request" headers +% accept_ranges, +% age, +% etag, + location, +% proxy_authenticate, + retry_after, +% server, +% vary, +% www_authenticate, +%%% --- Standard "Entity" headers +% allow, +% content_encoding, +% content_language, + content_length="0", +% content_location, +% content_md5, +% content_range, + content_type, +% expires, +% last_modified, + other=[] % (list) Key/Value list with other headers + }). + +%%% All data associated to a specific HTTP request +-record(request,{ + id, % (int) Request Id + ref, % Caller specific + from, % (pid) Caller + redircount=0,% (int) Number of redirects made for this request + scheme, % (http|https) (HTTP/TCP) or (TCP/SSL/TCP) connection + address, % ({Host,Port}) Destination Host and Port + pathquery, % (string) Rest of parsed URL + method, % (atom) HTTP request Method + headers, % (list) Key/Value list with Headers + content, % ({ContentType,Body}) Current HTTP request + settings % (#client_settings{}) User defined settings + }). + +-record(response,{ + scheme, % (atom) http (HTTP/TCP) or https (TCP/SSL/TCP) + socket, % (socket) Open socket, used by connection + status, + http_version, + headers=#res_headers{}, + body = <<>> + }). + + + + +%%% HTTP Client settings +-record(client_settings,{ + timeout=?HTTP_REQUEST_TIMEOUT, + % (int) Milliseconds before a request times out + useproxy=false, % (bool) True if the proxy should be used + proxy=undefined, % (tuple) Parsed Proxy URL + noproxylist=[], % (list) List with hosts not requiring proxy + autoredirect=true, % (bool) True if automatic redirection on 30X + % responses. + max_sessions=?OPEN_SESSIONS,% (int) Max open sessions for any Adr,Port + max_quelength=?PIPELINE_LENGTH, % (int) Max pipeline length +% ssl=[{certfile,"/jb/server_root/ssl/ssl_client.pem"}, +% {keyfile,"/jb/server_root/ssl/ssl_client.pem"}, +% {verify,0}] + ssl=false % (list) SSL settings. A non-empty list enables SSL/TLS + % support in the HTTP client + }). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/http_lib.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/http_lib.erl new file mode 100644 index 0000000000..4f6c43710b --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/http_lib.erl @@ -0,0 +1,745 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Mobile Arts AB +%% Portions created by Mobile Arts are Copyright 2002, Mobile Arts AB +%% All Rights Reserved.'' +%% +%% +%%% File : http_lib.erl +%%% Author : Johan Blom <[email protected]> +%%% Description : Generic, HTTP specific helper functions +%%% Created : 4 Mar 2002 by Johan Blom + +%%% TODO +%%% - Check if I need to anything special when parsing +%%% "Content-Type:multipart/form-data" + +-module(http_lib). +-author("[email protected]"). + +-include("http.hrl"). +-include("jnets_httpd.hrl"). + +-export([connection_close/1, + accept/3,deliver/3,recv/4,recv0/3, + connect/1,send/3,close/2,controlling_process/3,setopts/3, + getParameterValue/2, +% get_var/2, + create_request_line/3]). + +-export([read_client_headers/2,read_server_headers/2, + get_auth_data/1,create_header_list/1, + read_client_body/2,read_client_multipartrange_body/3, + read_server_body/2]). + + +%%% Server response: +%%% Check "Connection" header if server requests session to be closed. +%%% No 'close' means returns false +%%% Client Request: +%%% Check if 'close' in request headers +%%% Only care about HTTP 1.1 clients! +connection_close(Headers) when record(Headers,req_headers) -> + case Headers#req_headers.connection of + "close" -> + true; + "keep-alive" -> + false; + Value when list(Value) -> + true; + _ -> + false + end; +connection_close(Headers) when record(Headers,res_headers) -> + case Headers#res_headers.connection of + "close" -> + true; + "keep-alive" -> + false; + Value when list(Value) -> + true; + _ -> + false + end. + + +%% ============================================================================= +%%% Debugging: + +% format_time(TS) -> +% {_,_,MicroSecs}=TS, +% {{Y,Mon,D},{H,M,S}}=calendar:now_to_universal_time(TS), +% lists:flatten(io_lib:format("~4.4.0w-~2.2.0w-~2.2.0w,~2.2.0w:~2.2.0w:~6.3.0f", +% [Y,Mon,D,H,M,S+(MicroSecs/1000000)])). + +%% Time in milli seconds +% t() -> +% {A,B,C} = erlang:now(), +% A*1000000000+B*1000+(C div 1000). + +% sz(L) when list(L) -> +% length(L); +% sz(B) when binary(B) -> +% size(B); +% sz(O) -> +% {unknown_size,O}. + + +%% ============================================================================= + +getHeaderValue(_Attr,[]) -> + []; +getHeaderValue(Attr,[{Attr,Value}|_Rest]) -> + Value; +getHeaderValue(Attr,[_|Rest]) -> + getHeaderValue(Attr,Rest). + +getParameterValue(_Attr,undefined) -> + undefined; +getParameterValue(Attr,List) -> + case lists:keysearch(Attr,1,List) of + {value,{Attr,Val}} -> + Val; + _ -> + undefined + end. + +create_request_line(Method,Path,{Major,Minor}) -> + [atom_to_list(Method)," ",Path, + " HTTP/",integer_to_list(Major),".",integer_to_list(Minor)]; +create_request_line(Method,Path,Minor) -> + [atom_to_list(Method)," ",Path," HTTP/1.",integer_to_list(Minor)]. + + +%%% ============================================================================ +read_client_headers(Info,Timeout) -> + Headers=read_response_h(Info#response.scheme,Info#response.socket,Timeout, + Info#response.headers), + Info#response{headers=Headers}. + +read_server_headers(Info,Timeout) -> + Headers=read_request_h(Info#mod.socket_type,Info#mod.socket,Timeout, + Info#mod.headers), + Info#mod{headers=Headers}. + + +%% Parses the header of a HTTP request and returns a key,value tuple +%% list containing Name and Value of each header directive as of: +%% +%% Content-Type: multipart/mixed -> {"Content-Type", "multipart/mixed"} +%% +%% But in http/1.1 the field-names are case insencitive so now it must be +%% Content-Type: multipart/mixed -> {"content-type", "multipart/mixed"} +%% The standard furthermore says that leading and traling white space +%% is not a part of the fieldvalue and shall therefore be removed. +read_request_h(SType,S,Timeout,H) -> + case recv0(SType,S,Timeout) of + {ok,{http_header,_,'Connection',_,Value}} -> + read_request_h(SType,S,Timeout,H#req_headers{connection=Value}); + {ok,{http_header,_,'Content-Type',_,Val}} -> + read_request_h(SType,S,Timeout,H#req_headers{content_type=Val}); + {ok,{http_header,_,'Host',_,Value}} -> + read_request_h(SType,S,Timeout,H#req_headers{host=Value}); + {ok,{http_header,_,'Content-Length',_,Value}} -> + read_request_h(SType,S,Timeout,H#req_headers{content_length=Value}); +% {ok,{http_header,_,'Expect',_,Value}} -> % FIXME! Update inet_drv.c!! +% read_request_h(SType,S,Timeout,H#req_headers{expect=Value}); + {ok,{http_header,_,'Transfer-Encoding',_,V}} -> + read_request_h(SType,S,Timeout,H#req_headers{transfer_encoding=V}); + {ok,{http_header,_,'Authorization',_,Value}} -> + read_request_h(SType,S,Timeout,H#req_headers{authorization=Value}); + {ok,{http_header,_,'User-Agent',_,Value}} -> + read_request_h(SType,S,Timeout,H#req_headers{user_agent=Value}); + {ok,{http_header,_,'Range',_,Value}} -> + read_request_h(SType,S,Timeout,H#req_headers{range=Value}); + {ok,{http_header,_,'If-Range',_,Value}} -> + read_request_h(SType,S,Timeout,H#req_headers{if_range=Value}); + {ok,{http_header,_,'If-Match',_,Value}} -> + read_request_h(SType,S,Timeout,H#req_headers{if_match=Value}); + {ok,{http_header,_,'If-None-Match',_,Value}} -> + read_request_h(SType,S,Timeout,H#req_headers{if_none_match=Value}); + {ok,{http_header,_,'If-Modified-Since',_,V}} -> + read_request_h(SType,S,Timeout,H#req_headers{if_modified_since=V}); + {ok,{http_header,_,'If-Unmodified-Since',_,V}} -> + read_request_h(SType,S,Timeout,H#req_headers{if_unmodified_since=V}); + {ok,{http_header,_,K,_,V}} -> + read_request_h(SType,S,Timeout, + H#req_headers{other=H#req_headers.other++[{K,V}]}); + {ok,http_eoh} -> + H; + {error, timeout} when SType==http -> + throw({error, session_local_timeout}); + {error, etimedout} when SType==https -> + throw({error, session_local_timeout}); + {error, Reason} when Reason==closed;Reason==enotconn -> + throw({error, session_remotely_closed}); + {error, Reason} -> + throw({error,Reason}) + end. + + +read_response_h(SType,S,Timeout,H) -> + case recv0(SType,S,Timeout) of + {ok,{http_header,_,'Connection',_,Val}} -> + read_response_h(SType,S,Timeout,H#res_headers{connection=Val}); + {ok,{http_header,_,'Content-Length',_,Val}} -> + read_response_h(SType,S,Timeout,H#res_headers{content_length=Val}); + {ok,{http_header,_,'Content-Type',_,Val}} -> + read_response_h(SType,S,Timeout,H#res_headers{content_type=Val}); + {ok,{http_header,_,'Transfer-Encoding',_,V}} -> + read_response_h(SType,S,Timeout,H#res_headers{transfer_encoding=V}); + {ok,{http_header,_,'Location',_,V}} -> + read_response_h(SType,S,Timeout,H#res_headers{location=V}); + {ok,{http_header,_,'Retry-After',_,V}} -> + read_response_h(SType,S,Timeout,H#res_headers{retry_after=V}); + {ok,{http_header,_,K,_,V}} -> + read_response_h(SType,S,Timeout, + H#res_headers{other=H#res_headers.other++[{K,V}]}); + {ok,http_eoh} -> + H; + {error, timeout} when SType==http -> + throw({error, session_local_timeout}); + {error, etimedout} when SType==https -> + throw({error, session_local_timeout}); + {error, Reason} when Reason==closed;Reason==enotconn -> + throw({error, session_remotely_closed}); + {error, Reason} -> + throw({error,Reason}) + end. + + +%%% Got the headers, and maybe a part of the body, now read in the rest +%%% Note: +%%% - No need to check for Expect header if client +%%% - Currently no support for setting MaxHeaderSize in client, set to +%%% unlimited. +%%% - Move to raw packet mode as we are finished with HTTP parsing +read_client_body(Info,Timeout) -> + Headers=Info#response.headers, + case Headers#res_headers.transfer_encoding of + "chunked" -> + ?DEBUG("read_entity_body2()->" + "Transfer-encoding:Chunked Data:",[]), + read_client_chunked_body(Info,Timeout,?MAXBODYSIZE); + Encoding when list(Encoding) -> + ?DEBUG("read_entity_body2()->" + "Transfer-encoding:Unknown",[]), + throw({error,unknown_coding}); + _ -> + ContLen=list_to_integer(Headers#res_headers.content_length), + if + ContLen>?MAXBODYSIZE -> + throw({error,body_too_big}); + true -> + ?DEBUG("read_entity_body2()->" + "Transfer-encoding:none ",[]), + Info#response{body=read_plain_body(Info#response.scheme, + Info#response.socket, + ContLen, + Info#response.body, + Timeout)} + end + end. + + +%%% ---------------------------------------------------------------------- +read_server_body(Info,Timeout) -> + MaxBodySz=httpd_util:lookup(Info#mod.config_db,max_body_size,?MAXBODYSIZE), + ContLen=list_to_integer((Info#mod.headers)#req_headers.content_length), + %% ?vtrace("ContentLength: ~p", [ContLen]), + if + integer(ContLen),integer(MaxBodySz),ContLen>MaxBodySz -> + throw({error,body_too_big}); + true -> + read_server_body2(Info,Timeout,ContLen,MaxBodySz) + end. + + +%%---------------------------------------------------------------------- +%% Control if the body is transfer encoded, if so decode it. +%% Note: +%% - MaxBodySz has an integer value or 'nolimit' +%% - ContLen has an integer value or 'undefined' +%% All applications MUST be able to receive and decode the "chunked" +%% transfer-coding, see RFC 2616 Section 3.6.1 +read_server_body2(Info,Timeout,ContLen,MaxBodySz) -> + ?DEBUG("read_entity_body2()->Max: ~p ~nLength:~p ~nSocket: ~p ~n", + [MaxBodySz,ContLen,Info#mod.socket]), + case (Info#mod.headers)#req_headers.transfer_encoding of + "chunked" -> + ?DEBUG("read_entity_body2()->" + "Transfer-encoding:Chunked Data:",[]), + read_server_chunked_body(Info,Timeout,MaxBodySz); + Encoding when list(Encoding) -> + ?DEBUG("read_entity_body2()->" + "Transfer-encoding:Unknown",[]), + httpd_response:send_status(Info,501,"Unknown Transfer-Encoding"), + http_lib:close(Info#mod.socket_type,Info#mod.socket), + throw({error,{status_sent,"Unknown Transfer-Encoding "++Encoding}}); + _ when integer(ContLen),integer(MaxBodySz),ContLen>MaxBodySz -> + throw({error,body_too_big}); + _ when integer(ContLen) -> + ?DEBUG("read_entity_body2()->" + "Transfer-encoding:none ",[]), + Info#mod{entity_body=read_plain_body(Info#mod.socket_type, + Info#mod.socket, + ContLen,Info#mod.entity_body, + Timeout)} + end. + + +%%% ---------------------------------------------------------------------------- +%%% The body was plain, just read it from the socket. +read_plain_body(_SocketType,Socket,0,Cont,_Timeout) -> + Cont; +read_plain_body(SocketType,Socket,ContLen,Cont,Timeout) -> + Body=read_more_data(SocketType,Socket,ContLen,Timeout), + <<Cont/binary,Body/binary>>. + +%%% ---------------------------------------------------------------------------- +%%% The body was chunked, decode it. +%%% From RFC2616, Section 3.6.1 +%% Chunked-Body = *chunk +%% last-chunk +%% trailer +%% CRLF +%% +%% chunk = chunk-size [ chunk-extension ] CRLF +%% chunk-data CRLF +%% chunk-size = 1*HEX +%% last-chunk = 1*("0") [ chunk-extension ] CRLF +%% +%% chunk-extension= *( ";" chunk-ext-name [ "=" chunk-ext-val ] ) +%% chunk-ext-name = token +%% chunk-ext-val = token | quoted-string +%% chunk-data = chunk-size(OCTET) +%% trailer = *(entity-header CRLF) +%% +%%% "All applications MUST ignore chunk-extension extensions they do not +%%% understand.", see RFC 2616 Section 3.6.1 +%%% We don't understand any extension... +read_client_chunked_body(Info,Timeout,MaxChunkSz) -> + case read_chunk(Info#response.scheme,Info#response.socket, + Timeout,0,MaxChunkSz) of + {last_chunk,_ExtensionList} -> % Ignore extension + TrailH=read_headers_old(Info#response.scheme,Info#response.socket, + Timeout), + H=Info#response.headers, + OtherHeaders=H#res_headers.other++TrailH, + Info#response{headers=H#res_headers{other=OtherHeaders}}; + {Chunk,ChunkSize,_ExtensionList} -> % Ignore extension + Info1=Info#response{body= <<(Info#response.body)/binary, + Chunk/binary>>}, + read_client_chunked_body(Info1,Timeout,MaxChunkSz-ChunkSize); + {error,Reason} -> + throw({error,Reason}) + end. + + +read_server_chunked_body(Info,Timeout,MaxChunkSz) -> + case read_chunk(Info#mod.socket_type,Info#mod.socket, + Timeout,0,MaxChunkSz) of + {last_chunk,_ExtensionList} -> % Ignore extension + TrailH=read_headers_old(Info#mod.socket_type,Info#mod.socket, + Timeout), + H=Info#mod.headers, + OtherHeaders=H#req_headers.other++TrailH, + Info#mod{headers=H#req_headers{other=OtherHeaders}}; + {Chunk,ChunkSize,_ExtensionList} -> % Ignore extension + Info1=Info#mod{entity_body= <<(Info#mod.entity_body)/binary, + Chunk/binary>>}, + read_server_chunked_body(Info1,Timeout,MaxChunkSz-ChunkSize); + {error,Reason} -> + throw({error,Reason}) + end. + + +read_chunk(Scheme,Socket,Timeout,Int,MaxChunkSz) when MaxChunkSz>Int -> + case read_more_data(Scheme,Socket,1,Timeout) of + <<C>> when $0=<C,C=<$9 -> + read_chunk(Scheme,Socket,Timeout,16*Int+(C-$0),MaxChunkSz); + <<C>> when $a=<C,C=<$f -> + read_chunk(Scheme,Socket,Timeout,16*Int+10+(C-$a),MaxChunkSz); + <<C>> when $A=<C,C=<$F -> + read_chunk(Scheme,Socket,Timeout,16*Int+10+(C-$A),MaxChunkSz); + <<$;>> when Int>0 -> + ExtensionList=read_chunk_ext_name(Scheme,Socket,Timeout,[],[]), + read_chunk_data(Scheme,Socket,Int+1,ExtensionList,Timeout); + <<$;>> when Int==0 -> + ExtensionList=read_chunk_ext_name(Scheme,Socket,Timeout,[],[]), + read_data_lf(Scheme,Socket,Timeout), + {last_chunk,ExtensionList}; + <<?CR>> when Int>0 -> + read_chunk_data(Scheme,Socket,Int+1,[],Timeout); + <<?CR>> when Int==0 -> + read_data_lf(Scheme,Socket,Timeout), + {last_chunk,[]}; + <<C>> when C==$ -> % Some servers (e.g., Apache 1.3.6) throw in + % additional whitespace... + read_chunk(Scheme,Socket,Timeout,Int,MaxChunkSz); + _Other -> + {error,unexpected_chunkdata} + end; +read_chunk(_Scheme,_Socket,_Timeout,_Int,_MaxChunkSz) -> + {error,body_too_big}. + + +%%% Note: +%%% - Got the initial ?CR already! +%%% - Bitsyntax does not allow matching of ?CR,?LF in the end of the first read +read_chunk_data(Scheme,Socket,Int,ExtensionList,Timeout) -> + case read_more_data(Scheme,Socket,Int,Timeout) of + <<?LF,Chunk/binary>> -> + case read_more_data(Scheme,Socket,2,Timeout) of + <<?CR,?LF>> -> + {Chunk,size(Chunk),ExtensionList}; + _ -> + {error,bad_chunkdata} + end; + _ -> + {error,bad_chunkdata} + end. + +read_chunk_ext_name(Scheme,Socket,Timeout,Name,Acc) -> + Len=length(Name), + case read_more_data(Scheme,Socket,1,Timeout) of + $= when Len>0 -> + read_chunk_ext_val(Scheme,Socket,Timeout,Name,[],Acc); + $; when Len>0 -> + read_chunk_ext_name(Scheme,Socket,Timeout,[], + [{lists:reverse(Name),""}|Acc]); + ?CR when Len>0 -> + lists:reverse([{lists:reverse(Name,"")}|Acc]); + Token -> % FIXME Check that it is "token" + read_chunk_ext_name(Scheme,Socket,Timeout,[Token|Name],Acc); + _ -> + {error,bad_chunk_extension_name} + end. + +read_chunk_ext_val(Scheme,Socket,Timeout,Name,Val,Acc) -> + Len=length(Val), + case read_more_data(Scheme,Socket,1,Timeout) of + $; when Len>0 -> + read_chunk_ext_name(Scheme,Socket,Timeout,[], + [{Name,lists:reverse(Val)}|Acc]); + ?CR when Len>0 -> + lists:reverse([{Name,lists:reverse(Val)}|Acc]); + Token -> % FIXME Check that it is "token" or "quoted-string" + read_chunk_ext_val(Scheme,Socket,Timeout,Name,[Token|Val],Acc); + _ -> + {error,bad_chunk_extension_value} + end. + +read_data_lf(Scheme,Socket,Timeout) -> + case read_more_data(Scheme,Socket,1,Timeout) of + ?LF -> + ok; + _ -> + {error,bad_chunkdata} + end. + +%%% ---------------------------------------------------------------------------- +%%% The body was "multipart/byteranges", decode it. +%%% Example from RFC 2616, Appendix 19.2 +%%% HTTP/1.1 206 Partial Content +%%% Date: Wed, 15 Nov 1995 06:25:24 GMT +%%% Last-Modified: Wed, 15 Nov 1995 04:58:08 GMT +%%% Content-type: multipart/byteranges; boundary=THIS_STRING_SEPARATES +%%% +%%% --THIS_STRING_SEPARATES +%%% Content-type: application/pdf +%%% Content-range: bytes 500-999/8000 +%%% +%%% ...the first range... +%%% --THIS_STRING_SEPARATES +%%% Content-type: application/pdf +%%% Content-range: bytes 7000-7999/8000 +%%% +%%% ...the second range +%%% --THIS_STRING_SEPARATES-- +%%% +%%% Notes: +%%% +%%% 1) Additional CRLFs may precede the first boundary string in the +%%% entity. +%%% FIXME!! +read_client_multipartrange_body(Info,Parstr,Timeout) -> + Boundary=get_boundary(Parstr), + scan_boundary(Info,Boundary), + Info#response{body=read_multipart_body(Info,Boundary,Timeout)}. + +read_multipart_body(Info,Boundary,Timeout) -> + Info. + +% Headers=read_headers_old(Info#response.scheme,Info#response.socket,Timeout), +% H=Info#response.headers, +% OtherHeaders=H#res_headers.other++TrailH, +% Info#response{headers=H#res_headers{other=OtherHeaders}}. + + +scan_boundary(Info,Boundary) -> + Info. + + +get_boundary(Parstr) -> + case skip_lwsp(Parstr) of + [] -> + throw({error,missing_range_boundary_parameter}); + Val -> + get_boundary2(string:tokens(Val, ";")) + end. + +get_boundary2([]) -> + undefined; +get_boundary2([Param|Rest]) -> + case string:tokens(skip_lwsp(Param), "=") of + ["boundary"++Attribute,Value] -> + Value; + _ -> + get_boundary2(Rest) + end. + + +%% skip space & tab +skip_lwsp([$ | Cs]) -> skip_lwsp(Cs); +skip_lwsp([$\t | Cs]) -> skip_lwsp(Cs); +skip_lwsp(Cs) -> Cs. + +%%% ---------------------------------------------------------------------------- + +%%% Read the incoming data from the open socket. +read_more_data(http,Socket,Len,Timeout) -> + case gen_tcp:recv(Socket,Len,Timeout) of + {ok,Val} -> + Val; + {error, timeout} -> + throw({error, session_local_timeout}); + {error, Reason} when Reason==closed;Reason==enotconn -> + throw({error, session_remotely_closed}); + {error, Reason} -> +% httpd_response:send_status(Info,400,none), + throw({error, Reason}) + end; +read_more_data(https,Socket,Len,Timeout) -> + case ssl:recv(Socket,Len,Timeout) of + {ok,Val} -> + Val; + {error, etimedout} -> + throw({error, session_local_timeout}); + {error, Reason} when Reason==closed;Reason==enotconn -> + throw({error, session_remotely_closed}); + {error, Reason} -> +% httpd_response:send_status(Info,400,none), + throw({error, Reason}) + end. + + +%% ============================================================================= +%%% Socket handling + +accept(http,ListenSocket, Timeout) -> + gen_tcp:accept(ListenSocket, Timeout); +accept(https,ListenSocket, Timeout) -> + ssl:accept(ListenSocket, Timeout). + + +close(http,Socket) -> + gen_tcp:close(Socket); +close(https,Socket) -> + ssl:close(Socket). + + +connect(#request{scheme=http,settings=Settings,address=Addr}) -> + case proxyusage(Addr,Settings) of + {error,Reason} -> + {error,Reason}; + {Host,Port} -> + Opts=[binary,{active,false},{reuseaddr,true}], + gen_tcp:connect(Host,Port,Opts) + end; +connect(#request{scheme=https,settings=Settings,address=Addr}) -> + case proxyusage(Addr,Settings) of + {error,Reason} -> + {error,Reason}; + {Host,Port} -> + Opts=case Settings#client_settings.ssl of + false -> + [binary,{active,false}]; + SSLSettings -> + [binary,{active,false}]++SSLSettings + end, + ssl:connect(Host,Port,Opts) + end. + + +%%% Check to see if the given {Host,Port} tuple is in the NoProxyList +%%% Returns an eventually updated {Host,Port} tuple, with the proxy address +proxyusage(HostPort,Settings) -> + case Settings#client_settings.useproxy of + true -> + case noProxy(HostPort,Settings#client_settings.noproxylist) of + true -> + HostPort; + _ -> + case Settings#client_settings.proxy of + undefined -> + {error,no_proxy_defined}; + ProxyHostPort -> + ProxyHostPort + end + end; + _ -> + HostPort + end. + +noProxy(_HostPort,[]) -> + false; +noProxy({Host,Port},[{Host,Port}|Rest]) -> + true; +noProxy(HostPort,[_|Rest]) -> + noProxy(HostPort,Rest). + + +controlling_process(http,Socket,Pid) -> + gen_tcp:controlling_process(Socket,Pid); +controlling_process(https,Socket,Pid) -> + ssl:controlling_process(Socket,Pid). + + +deliver(SocketType, Socket, Message) -> + case send(SocketType, Socket, Message) of + {error, einval} -> + close(SocketType, Socket), + socket_closed; + {error, _Reason} -> +% ?vlog("deliver(~p) failed for reason:" +% "~n Reason: ~p",[SocketType,_Reason]), + close(SocketType, Socket), + socket_closed; + _Other -> + ok + end. + + +recv0(http,Socket,Timeout) -> + gen_tcp:recv(Socket,0,Timeout); +recv0(https,Socket,Timeout) -> + ssl:recv(Socket,0,Timeout). + +recv(http,Socket,Len,Timeout) -> + gen_tcp:recv(Socket,Len,Timeout); +recv(https,Socket,Len,Timeout) -> + ssl:recv(Socket,Len,Timeout). + + +setopts(http,Socket,Options) -> + inet:setopts(Socket,Options); +setopts(https,Socket,Options) -> + ssl:setopts(Socket,Options). + + +send(http,Socket,Message) -> + gen_tcp:send(Socket,Message); +send(https,Socket,Message) -> + ssl:send(Socket,Message). + + +%%% ============================================================================ +%%% HTTP Server only + +%%% Returns the Authenticating data in the HTTP request +get_auth_data("Basic "++EncodedString) -> + UnCodedString=httpd_util:decode_base64(EncodedString), + case catch string:tokens(UnCodedString,":") of + [User,PassWord] -> + {User,PassWord}; + {error,Error}-> + {error,Error} + end; +get_auth_data(BadCredentials) when list(BadCredentials) -> + {error,BadCredentials}; +get_auth_data(_) -> + {error,nouser}. + + +create_header_list(H) -> + lookup(connection,H#req_headers.connection)++ + lookup(host,H#req_headers.host)++ + lookup(content_length,H#req_headers.content_length)++ + lookup(transfer_encoding,H#req_headers.transfer_encoding)++ + lookup(authorization,H#req_headers.authorization)++ + lookup(user_agent,H#req_headers.user_agent)++ + lookup(user_agent,H#req_headers.range)++ + lookup(user_agent,H#req_headers.if_range)++ + lookup(user_agent,H#req_headers.if_match)++ + lookup(user_agent,H#req_headers.if_none_match)++ + lookup(user_agent,H#req_headers.if_modified_since)++ + lookup(user_agent,H#req_headers.if_unmodified_since)++ + H#req_headers.other. + +lookup(_Key,undefined) -> + []; +lookup(Key,Val) -> + [{Key,Val}]. + + + +%%% ============================================================================ +%%% This code is for parsing trailer headers in chunked messages. +%%% Will be deprecated whenever I have found an alternative working solution! +%%% Note: +%%% - The header names are returned slighly different from what the what +%%% inet_drv returns +read_headers_old(Scheme,Socket,Timeout) -> + read_headers_old(<<>>,Scheme,Socket,Timeout,[],[]). + +read_headers_old(<<>>,Scheme,Socket,Timeout,Acc,AccHdrs) -> + read_headers_old(read_more_data(Scheme,Socket,1,Timeout), + Scheme,Socket,Timeout,Acc,AccHdrs); +read_headers_old(<<$\r>>,Scheme,Socket,Timeout,Acc,AccHdrs) -> + read_headers_old(<<$\r,(read_more_data(Scheme,Socket,1,Timeout))/binary>>, + Scheme,Socket,Timeout,Acc,AccHdrs); +read_headers_old(<<$\r,$\n>>,Scheme,Socket,Timeout,Acc,AccHdrs) -> + if + Acc==[] -> % Done! + tagup_header(lists:reverse(AccHdrs)); + true -> + read_headers_old(read_more_data(Scheme,Socket,1,Timeout), + Scheme,Socket, + Timeout,[],[lists:reverse(Acc)|AccHdrs]) + end; +read_headers_old(<<C>>,Scheme,Socket,Timeout,Acc,AccHdrs) -> + read_headers_old(read_more_data(Scheme,Socket,1,Timeout), + Scheme,Socket,Timeout,[C|Acc],AccHdrs); +read_headers_old(Bin,_Scheme,_Socket,_Timeout,_Acc,_AccHdrs) -> + io:format("ERROR: Unexpected data from inet driver: ~p",[Bin]), + throw({error,this_is_a_bug}). + + +%% Parses the header of a HTTP request and returns a key,value tuple +%% list containing Name and Value of each header directive as of: +%% +%% Content-Type: multipart/mixed -> {"Content-Type", "multipart/mixed"} +%% +%% But in http/1.1 the field-names are case insencitive so now it must be +%% Content-Type: multipart/mixed -> {"content-type", "multipart/mixed"} +%% The standard furthermore says that leading and traling white space +%% is not a part of the fieldvalue and shall therefore be removed. +tagup_header([]) -> []; +tagup_header([Line|Rest]) -> [tag(Line, [])|tagup_header(Rest)]. + +tag([], Tag) -> + {httpd_util:to_lower(lists:reverse(Tag)), ""}; +tag([$:|Rest], Tag) -> + {httpd_util:to_lower(lists:reverse(Tag)), httpd_util:strip(Rest)}; +tag([Chr|Rest], Tag) -> + tag(Rest, [Chr|Tag]). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpc_handler.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpc_handler.erl new file mode 100644 index 0000000000..8e5e1c709a --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpc_handler.erl @@ -0,0 +1,724 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Mobile Arts AB +%% Portions created by Mobile Arts are Copyright 2002, Mobile Arts AB +%% All Rights Reserved.'' +%% +%% + +%%% TODO: +%%% - If an error is returned when sending a request, don't use this +%%% session anymore. +%%% - Closing of sessions not properly implemented for some cases + +%%% File : httpc_handler.erl +%%% Author : Johan Blom <[email protected]> +%%% Description : Handles HTTP client responses, for a single TCP session +%%% Created : 4 Mar 2002 by Johan Blom + +-module(httpc_handler). + +-include("http.hrl"). +-include("jnets_httpd.hrl"). + +-export([init_connection/2,http_request/2]). + +%%% ========================================================================== +%%% "Main" function in the spawned process for the session. +init_connection(Req,Session) when record(Req,request) -> + case catch http_lib:connect(Req) of + {ok,Socket} -> + case catch http_request(Req,Socket) of + ok -> + case Session#session.clientclose of + true -> + ok; + false -> + httpc_manager:register_socket(Req#request.address, + Session#session.id, + Socket) + end, + next_response_with_request(Req, + Session#session{socket=Socket}); + {error,Reason} -> % Not possible to use new session + gen_server:cast(Req#request.from, + {Req#request.ref,Req#request.id,{error,Reason}}), + exit_session_ok(Req#request.address, + Session#session{socket=Socket}) + end; + {error,Reason} -> % Not possible to set up new session + gen_server:cast(Req#request.from, + {Req#request.ref,Req#request.id,{error,Reason}}), + exit_session_ok2(Req#request.address, + Session#session.clientclose,Session#session.id) + end. + +next_response_with_request(Req,Session) -> + Timeout=(Req#request.settings)#client_settings.timeout, + case catch read(Timeout,Session#session.scheme,Session#session.socket) of + {Status,Headers,Body} -> + NewReq=handle_response({Status,Headers,Body},Timeout,Req,Session), + next_response_with_request(NewReq,Session); + {error,Reason} -> + gen_server:cast(Req#request.from, + {Req#request.ref,Req#request.id,{error,Reason}}), + exit_session(Req#request.address,Session,aborted_request); + {'EXIT',Reason} -> + gen_server:cast(Req#request.from, + {Req#request.ref,Req#request.id,{error,Reason}}), + exit_session(Req#request.address,Session,aborted_request) + end. + +handle_response(Response,Timeout,Req,Session) -> + case http_response(Response,Req,Session) of + ok -> + next_response(Timeout,Req#request.address,Session); + stop -> + exit(normal); + {error,Reason} -> + gen_server:cast(Req#request.from, + {Req#request.ref,Req#request.id,{error,Reason}}), + exit_session(Req#request.address,Session,aborted_request) + end. + + + +%%% Wait for the next respond until +%%% - session is closed by the other side +%%% => set up a new a session, if there are pending requests in the que +%%% - "Connection:close" header is received +%%% => close the connection (release socket) then +%%% set up a new a session, if there are pending requests in the que +%%% +%%% Note: +%%% - When invoked there are no pending responses on received requests. +%%% - Never close the session explicitly, let it timeout instead! +next_response(Timeout,Address,Session) -> + case httpc_manager:next_request(Address,Session#session.id) of + no_more_requests -> + %% There are no more pending responses, now just wait for + %% timeout or a new response. + case catch read(Timeout, + Session#session.scheme,Session#session.socket) of + {error,Reason} when Reason==session_remotely_closed; + Reason==session_local_timeout -> + exit_session_ok(Address,Session); + {error,Reason} -> + exit_session(Address,Session,aborted_request); + {'EXIT',Reason} -> + exit_session(Address,Session,aborted_request); + {Status2,Headers2,Body2} -> + case httpc_manager:next_request(Address, + Session#session.id) of + no_more_requests -> % Should not happen! + exit_session(Address,Session,aborted_request); + {error,Reason} -> % Should not happen! + exit_session(Address,Session,aborted_request); + NewReq -> + handle_response({Status2,Headers2,Body2}, + Timeout,NewReq,Session) + end + end; + {error,Reason} -> % The connection has been closed by httpc_manager + exit_session(Address,Session,aborted_request); + NewReq -> + NewReq + end. + +%% =========================================================================== +%% Internals + +%%% Read in and parse response data from the socket +read(Timeout,SockType,Socket) -> + Info=#response{scheme=SockType,socket=Socket}, + http_lib:setopts(SockType,Socket,[{packet, http}]), + Info1=read_response(SockType,Socket,Info,Timeout), + http_lib:setopts(SockType,Socket,[binary,{packet, raw}]), + case (Info1#response.headers)#res_headers.content_type of + "multipart/byteranges"++Param -> + range_response_body(Info1,Timeout,Param); + _ -> + #response{status=Status2,headers=Headers2,body=Body2}= + http_lib:read_client_body(Info1,Timeout), + {Status2,Headers2,Body2} + end. + + +%%% From RFC 2616: +%%% Status-Line = HTTP-Version SP Status-Code SP Reason-Phrase CRLF +%%% HTTP-Version = "HTTP" "/" 1*DIGIT "." 1*DIGIT +%%% Status-Code = 3DIGIT +%%% Reason-Phrase = *<TEXT, excluding CR, LF> +read_response(SockType,Socket,Info,Timeout) -> + case http_lib:recv0(SockType,Socket,Timeout) of + {ok,{http_response,{1,VerMin}, Status, _Phrase}} when VerMin==0; + VerMin==1 -> + Info1=Info#response{status=Status,http_version=VerMin}, + http_lib:read_client_headers(Info1,Timeout); + {ok,{http_response,_Version, _Status, _Phrase}} -> + throw({error,bad_status_line}); + {error, timeout} -> + throw({error,session_local_timeout}); + {error, Reason} when Reason==closed;Reason==enotconn -> + throw({error,session_remotely_closed}); + {error, Reason} -> + throw({error,Reason}) + end. + +%%% From RFC 2616, Section 4.4, Page 34 +%% 4.If the message uses the media type "multipart/byteranges", and the +%% transfer-length is not otherwise specified, then this self- +%% delimiting media type defines the transfer-length. This media type +%% MUST NOT be used unless the sender knows that the recipient can parse +%% it; the presence in a request of a Range header with multiple byte- +%% range specifiers from a 1.1 client implies that the client can parse +%% multipart/byteranges responses. +%%% FIXME !! +range_response_body(Info,Timeout,Param) -> + Headers=Info#response.headers, + case {Headers#res_headers.content_length, + Headers#res_headers.transfer_encoding} of + {undefined,undefined} -> + #response{status=Status2,headers=Headers2,body=Body2}= + http_lib:read_client_multipartrange_body(Info,Param,Timeout), + {Status2,Headers2,Body2}; + _ -> + #response{status=Status2,headers=Headers2,body=Body2}= + http_lib:read_client_body(Info,Timeout), + {Status2,Headers2,Body2} + end. + + +%%% ---------------------------------------------------------------------------- +%%% Host: field is required when addressing multi-homed sites ... +%%% It must not be present when the request is being made to a proxy. +http_request(#request{method=Method,id=Id, + scheme=Scheme,address={Host,Port},pathquery=PathQuery, + headers=Headers, content={ContentType,Body}, + settings=Settings}, + Socket) -> + PostData= + if + Method==post;Method==put -> + case Headers#req_headers.expect of + "100-continue" -> + content_type_header(ContentType) ++ + content_length_header(length(Body)) ++ + "\r\n"; + _ -> + content_type_header(ContentType) ++ + content_length_header(length(Body)) ++ + "\r\n" ++ Body + end; + true -> + "\r\n" + end, + Message= + case useProxy(Settings#client_settings.useproxy, + {Scheme,Host,Port,PathQuery}) of + false -> + method(Method)++" "++PathQuery++" HTTP/1.1\r\n"++ + host_header(Host)++te_header()++ + headers(Headers) ++ PostData; + AbsURI -> + method(Method)++" "++AbsURI++" HTTP/1.1\r\n"++ + te_header()++ + headers(Headers)++PostData + end, + http_lib:send(Scheme,Socket,Message). + +useProxy(false,_) -> + false; +useProxy(true,{Scheme,Host,Port,PathQuery}) -> + [atom_to_list(Scheme),"://",Host,":",integer_to_list(Port),PathQuery]. + + + +headers(#req_headers{expect=Expect, + other=Other}) -> + H1=case Expect of + undefined ->[]; + _ -> "Expect: "++Expect++"\r\n" + end, + H1++headers_other(Other). + + +headers_other([]) -> + []; +headers_other([{Key,Value}|Rest]) when atom(Key) -> + Head = atom_to_list(Key)++": "++Value++"\r\n", + Head ++ headers_other(Rest); +headers_other([{Key,Value}|Rest]) -> + Head = Key++": "++Value++"\r\n", + Head ++ headers_other(Rest). + +host_header(Host) -> + "Host: "++lists:concat([Host])++"\r\n". +content_type_header(ContentType) -> + "Content-Type: " ++ ContentType ++ "\r\n". +content_length_header(ContentLength) -> + "Content-Length: "++integer_to_list(ContentLength) ++ "\r\n". +te_header() -> + "TE: \r\n". + +method(Method) -> + httpd_util:to_upper(atom_to_list(Method)). + + +%%% ---------------------------------------------------------------------------- +http_response({Status,Headers,Body},Req,Session) -> + case Status of + 100 -> + status_continue(Req,Session); + 200 -> + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {Status,Headers,Body}}), + ServerClose=http_lib:connection_close(Headers), + handle_connection(Session#session.clientclose,ServerClose, + Req,Session); + 300 -> status_multiple_choices(Headers,Body,Req,Session); + 301 -> status_moved_permanently(Req#request.method, + Headers,Body,Req,Session); + 302 -> status_found(Headers,Body,Req,Session); + 303 -> status_see_other(Headers,Body,Req,Session); + 304 -> status_not_modified(Headers,Body,Req,Session); + 305 -> status_use_proxy(Headers,Body,Req,Session); + %% 306 This Status code is not used in HTTP 1.1 + 307 -> status_temporary_redirect(Headers,Body,Req,Session); + 503 -> status_service_unavailable({Status,Headers,Body},Req,Session); + Status50x when Status50x==500;Status50x==501;Status50x==502; + Status50x==504;Status50x==505 -> + status_server_error_50x({Status,Headers,Body},Req,Session); + _ -> % FIXME May want to take some action on other Status codes as well + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {Status,Headers,Body}}), + ServerClose=http_lib:connection_close(Headers), + handle_connection(Session#session.clientclose,ServerClose, + Req,Session) + end. + + +%%% Status code dependent functions. + +%%% Received a 100 Status code ("Continue") +%%% From RFC2616 +%%% The client SHOULD continue with its request. This interim response is +%%% used to inform the client that the initial part of the request has +%%% been received and has not yet been rejected by the server. The client +%%% SHOULD continue by sending the remainder of the request or, if the +%%% request has already been completed, ignore this response. The server +%%% MUST send a final response after the request has been completed. See +%%% section 8.2.3 for detailed discussion of the use and handling of this +%%% status code. +status_continue(Req,Session) -> + {_,Body}=Req#request.content, + http_lib:send(Session#session.scheme,Session#session.socket,Body), + next_response_with_request(Req,Session). + + +%%% Received a 300 Status code ("Multiple Choices") +%%% The resource is located in any one of a set of locations +%%% - If a 'Location' header is present (preserved server choice), use that +%%% to automatically redirect to the given URL +%%% - else if the Content-Type/Body both are non-empty let the user agent make +%%% the choice and thus return a response with status 300 +%%% Note: +%%% - If response to a HEAD request, the Content-Type/Body both should be empty. +%%% - The behaviour on an empty Content-Type or Body is unspecified. +%%% However, e.g. "Apache/1.3" servers returns both empty if the header +%%% 'if-modified-since: Date' was sent in the request and the content is +%%% "not modified" (instead of 304). Thus implicitly giving the cache as the +%%% only choice. +status_multiple_choices(Headers,Body,Req,Session) + when ((Req#request.settings)#client_settings.autoredirect)==true -> + ServerClose=http_lib:connection_close(Headers), + case Headers#res_headers.location of + undefined -> + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {300,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose, + Req,Session); + RedirUrl -> + Scheme=Session#session.scheme, + case uri:parse(RedirUrl) of + {error,Reason} -> + {error,Reason}; + {Scheme,Host,Port,PathQuery} -> % Automatic redirection + NewReq=Req#request{redircount=Req#request.redircount+1, + address={Host,Port},pathquery=PathQuery}, + handle_redirect(Session#session.clientclose,ServerClose, + NewReq,Session) + end + end; +status_multiple_choices(Headers,Body,Req,Session) -> + ServerClose=http_lib:connection_close(Headers), + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {300,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose,Req,Session). + + +%%% Received a 301 Status code ("Moved Permanently") +%%% The resource has been assigned a new permanent URI +%%% - If a 'Location' header is present, use that to automatically redirect to +%%% the given URL if GET or HEAD request +%%% - else return +%%% Note: +%%% - The Body should contain a short hypertext note with a hyperlink to the +%%% new URI. Return this if Content-Type acceptable (some HTTP servers doesn't +%%% deal properly with Accept headers) +status_moved_permanently(Method,Headers,Body,Req,Session) + when (((Req#request.settings)#client_settings.autoredirect)==true) and + (Method==get) or (Method==head) -> + ServerClose=http_lib:connection_close(Headers), + case Headers#res_headers.location of + undefined -> + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {301,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose, + Req,Session); + RedirUrl -> + Scheme=Session#session.scheme, + case uri:parse(RedirUrl) of + {error,Reason} -> + {error,Reason}; + {Scheme,Host,Port,PathQuery} -> % Automatic redirection + NewReq=Req#request{redircount=Req#request.redircount+1, + address={Host,Port},pathquery=PathQuery}, + handle_redirect(Session#session.clientclose,ServerClose, + NewReq,Session) + end + end; +status_moved_permanently(_Method,Headers,Body,Req,Session) -> + ServerClose=http_lib:connection_close(Headers), + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {301,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose,Req,Session). + + +%%% Received a 302 Status code ("Found") +%%% The requested resource resides temporarily under a different URI. +%%% Note: +%%% - Only cacheable if indicated by a Cache-Control or Expires header +status_found(Headers,Body,Req,Session) + when ((Req#request.settings)#client_settings.autoredirect)==true -> + ServerClose=http_lib:connection_close(Headers), + case Headers#res_headers.location of + undefined -> + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {302,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose, + Req,Session); + RedirUrl -> + Scheme=Session#session.scheme, + case uri:parse(RedirUrl) of + {error,Reason} -> + {error,Reason}; + {Scheme,Host,Port,PathQuery} -> % Automatic redirection + NewReq=Req#request{redircount=Req#request.redircount+1, + address={Host,Port},pathquery=PathQuery}, + handle_redirect(Session#session.clientclose,ServerClose, + NewReq,Session) + end + end; +status_found(Headers,Body,Req,Session) -> + ServerClose=http_lib:connection_close(Headers), + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {302,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose,Req,Session). + +%%% Received a 303 Status code ("See Other") +%%% The request found under a different URI and should be retrieved using GET +%%% Note: +%%% - Must not be cached +status_see_other(Headers,Body,Req,Session) + when ((Req#request.settings)#client_settings.autoredirect)==true -> + ServerClose=http_lib:connection_close(Headers), + case Headers#res_headers.location of + undefined -> + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {303,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose, + Req,Session); + RedirUrl -> + Scheme=Session#session.scheme, + case uri:parse(RedirUrl) of + {error,Reason} -> + {error,Reason}; + {Scheme,Host,Port,PathQuery} -> % Automatic redirection + NewReq=Req#request{redircount=Req#request.redircount+1, + method=get, + address={Host,Port},pathquery=PathQuery}, + handle_redirect(Session#session.clientclose,ServerClose, + NewReq,Session) + end + end; +status_see_other(Headers,Body,Req,Session) -> + ServerClose=http_lib:connection_close(Headers), + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {303,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose,Req,Session). + + +%%% Received a 304 Status code ("Not Modified") +%%% Note: +%%% - The response MUST NOT contain a body. +%%% - The response MUST include the following header fields: +%%% - Date, unless its omission is required +%%% - ETag and/or Content-Location, if the header would have been sent +%%% in a 200 response to the same request +%%% - Expires, Cache-Control, and/or Vary, if the field-value might +%%% differ from that sent in any previous response for the same +%%% variant +status_not_modified(Headers,Body,Req,Session) + when ((Req#request.settings)#client_settings.autoredirect)==true -> + ServerClose=http_lib:connection_close(Headers), + case Headers#res_headers.location of + undefined -> + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {304,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose, + Req,Session); + RedirUrl -> + Scheme=Session#session.scheme, + case uri:parse(RedirUrl) of + {error,Reason} -> + {error,Reason}; + {Scheme,Host,Port,PathQuery} -> % Automatic redirection + NewReq=Req#request{redircount=Req#request.redircount+1, + address={Host,Port},pathquery=PathQuery}, + handle_redirect(Session#session.clientclose,ServerClose, + NewReq,Session) + end + end; +status_not_modified(Headers,Body,Req,Session) -> + ServerClose=http_lib:connection_close(Headers), + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {304,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose,Req,Session). + + + +%%% Received a 305 Status code ("Use Proxy") +%%% The requested resource MUST be accessed through the proxy given by the +%%% Location field +status_use_proxy(Headers,Body,Req,Session) + when ((Req#request.settings)#client_settings.autoredirect)==true -> + ServerClose=http_lib:connection_close(Headers), + case Headers#res_headers.location of + undefined -> + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {305,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose, + Req,Session); + RedirUrl -> + Scheme=Session#session.scheme, + case uri:parse(RedirUrl) of + {error,Reason} -> + {error,Reason}; + {Scheme,Host,Port,PathQuery} -> % Automatic redirection + NewReq=Req#request{redircount=Req#request.redircount+1, + address={Host,Port},pathquery=PathQuery}, + handle_redirect(Session#session.clientclose,ServerClose, + NewReq,Session) + end + end; +status_use_proxy(Headers,Body,Req,Session) -> + ServerClose=http_lib:connection_close(Headers), + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {305,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose,Req,Session). + + +%%% Received a 307 Status code ("Temporary Redirect") +status_temporary_redirect(Headers,Body,Req,Session) + when ((Req#request.settings)#client_settings.autoredirect)==true -> + ServerClose=http_lib:connection_close(Headers), + case Headers#res_headers.location of + undefined -> + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {307,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose, + Req,Session); + RedirUrl -> + Scheme=Session#session.scheme, + case uri:parse(RedirUrl) of + {error,Reason} -> + {error,Reason}; + {Scheme,Host,Port,PathQuery} -> % Automatic redirection + NewReq=Req#request{redircount=Req#request.redircount+1, + address={Host,Port},pathquery=PathQuery}, + handle_redirect(Session#session.clientclose,ServerClose, + NewReq,Session) + end + end; +status_temporary_redirect(Headers,Body,Req,Session) -> + ServerClose=http_lib:connection_close(Headers), + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {307,Headers,Body}}), + handle_connection(Session#session.clientclose,ServerClose,Req,Session). + + + +%%% Received a 503 Status code ("Service Unavailable") +%%% The server is currently unable to handle the request due to a +%%% temporary overloading or maintenance of the server. The implication +%%% is that this is a temporary condition which will be alleviated after +%%% some delay. If known, the length of the delay MAY be indicated in a +%%% Retry-After header. If no Retry-After is given, the client SHOULD +%%% handle the response as it would for a 500 response. +%% Note: +%% - This session is now considered busy, thus cancel any requests in the +%% pipeline and close the session. +%% FIXME! Implement a user option to automatically retry if the 'Retry-After' +%% header is given. +status_service_unavailable(Resp,Req,Session) -> +% RetryAfter=Headers#res_headers.retry_after, + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id,Resp}), + close_session(server_connection_close,Req,Session). + + +%%% Received a 50x Status code (~ "Service Error") +%%% Response status codes beginning with the digit "5" indicate cases in +%%% which the server is aware that it has erred or is incapable of +%%% performing the request. +status_server_error_50x(Resp,Req,Session) -> + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id,Resp}), + close_session(server_connection_close,Req,Session). + + +%%% Handles requests for redirects +%%% The redirected request might be: +%%% - FIXME! on another TCP session, another scheme +%%% - on the same TCP session, same scheme +%%% - on another TCP session , same scheme +%%% However, in all cases treat it as a new request, with redircount updated. +%%% +%%% The redirect may fail, but this not a reason to close this session. +%%% Instead return a error for this request, and continue as ok. +handle_redirect(ClientClose,ServerClose,Req,Session) -> + case httpc_manager:request(Req) of + {ok,_ReqId} -> % FIXME Should I perhaps reuse the Reqid? + handle_connection(ClientClose,ServerClose,Req,Session); + {error,Reason} -> + gen_server:cast(Req#request.from,{Req#request.ref,Req#request.id, + {error,Reason}}), + handle_connection(ClientClose,ServerClose,Req,Session) + end. + +%%% Check if the persistent connection flag is false (ie client request +%%% non-persistive connection), or if the server requires a closed connection +%%% (by sending a "Connection: close" header). If the connection required +%%% non-persistent, we may close the connection immediately. +handle_connection(ClientClose,ServerClose,Req,Session) -> + case {ClientClose,ServerClose} of + {false,false} -> + ok; + {false,true} -> % The server requests this session to be closed. + close_session(server_connection_close,Req,Session); + {true,_} -> % The client requested a non-persistent connection + close_session(client_connection_close,Req,Session) + end. + + +%%% Close the session. +%%% We now have three cases: +%%% - Client request a non-persistent connection when initiating the request. +%%% Session info not stored in httpc_manager +%%% - Server requests a non-persistent connection when answering a request. +%%% No need to resend request, but there might be a pipeline. +%%% - Some kind of error +%%% Close the session, we may then try resending all requests in the pipeline +%%% including the current depending on the error. +%%% FIXME! Should not always abort the session (see close_session in +%%% httpc_manager for more details) +close_session(client_connection_close,_Req,Session) -> + http_lib:close(Session#session.scheme,Session#session.socket), + stop; +close_session(server_connection_close,Req,Session) -> + http_lib:close(Session#session.scheme,Session#session.socket), + httpc_manager:abort_session(Req#request.address,Session#session.id, + aborted_request), + stop. + +exit_session(Address,Session,Reason) -> + http_lib:close(Session#session.scheme,Session#session.socket), + httpc_manager:abort_session(Address,Session#session.id,Reason), + exit(normal). + +%%% This is the "normal" case to close a persistent connection. I.e., there are +%%% no more requests waiting and the session was closed by the client, or +%%% server because of a timeout or user request. +exit_session_ok(Address,Session) -> + http_lib:close(Session#session.scheme,Session#session.socket), + exit_session_ok2(Address,Session#session.clientclose,Session#session.id). + +exit_session_ok2(Address,ClientClose,Sid) -> + case ClientClose of + false -> + httpc_manager:close_session(Address,Sid); + true -> + ok + end, + exit(normal). + +%%% ============================================================================ +%%% This is deprecated code, to be removed + +format_time() -> + {_,_,MicroSecs}=TS=now(), + {{Y,Mon,D},{H,M,S}}=calendar:now_to_universal_time(TS), + lists:flatten(io_lib:format("~4.4.0w-~2.2.0w-~2.2.0w,~2.2.0w:~2.2.0w:~6.3.0f", + [Y,Mon,D,H,M,S+(MicroSecs/1000000)])). + +%%% Read more data from the open socket. +%%% Two different read functions is used because for the {active, once} socket +%%% option is (currently) not available for SSL... +%%% FIXME +% read_more_data(http,Socket,Timeout) -> +% io:format("read_more_data(ip_comm) -> " +% "~n set active = 'once' and " +% "await a chunk data", []), +% http_lib:setopts(Socket, [{active,once}]), +% read_more_data_ipcomm(Socket,Timeout); +% read_more_data(https,Socket,Timeout) -> +% case ssl:recv(Socket,0,Timeout) of +% {ok,MoreData} -> +% MoreData; +% {error,closed} -> +% throw({error, session_remotely_closed}); +% {error,etimedout} -> +% throw({error, session_local_timeout}); +% {error,Reason} -> +% throw({error, Reason}); +% Other -> +% throw({error, Other}) +% end. + +% %%% Send any incoming requests on the open session immediately +% read_more_data_ipcomm(Socket,Timeout) -> +% receive +% {tcp,Socket,MoreData} -> +% % ?vtrace("read_more_data(ip_comm) -> got some data:~p", +% % [MoreData]), +% MoreData; +% {tcp_closed,Socket} -> +% % ?vtrace("read_more_data(ip_comm) -> socket closed",[]), +% throw({error,session_remotely_closed}); +% {tcp_error,Socket,Reason} -> +% % ?vtrace("read_more_data(ip_comm) -> ~p socket error: ~p", +% % [self(),Reason]), +% throw({error, Reason}); +% stop -> +% throw({error, user_req}) +% after Timeout -> +% throw({error, session_local_timeout}) +% end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpc_manager.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpc_manager.erl new file mode 100644 index 0000000000..29659ce1ce --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpc_manager.erl @@ -0,0 +1,542 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Mobile Arts AB +%% Portions created by Mobile Arts are Copyright 2002, Mobile Arts AB +%% All Rights Reserved.'' +%% +%% +%% Created : 18 Dec 2001 by Johan Blom <[email protected]> +%% + +-module(httpc_manager). + +-behaviour(gen_server). + +-include("http.hrl"). + +-define(HMACALL, ?MODULE). +-define(HMANAME, ?MODULE). + +%%-------------------------------------------------------------------- +%% External exports +-export([start_link/0,start/0, + request/1,cancel_request/1, + next_request/2, + register_socket/3, + abort_session/3,close_session/2,close_session/3 + ]). + +%% Debugging only +-export([status/0]). + +%% gen_server callbacks +-export([init/1,handle_call/3,handle_cast/2,handle_info/2,terminate/2, + code_change/3]). + +%%% address_db - ets() Contains mappings from a tuple {Host,Port} to a tuple +%%% {LastSID,OpenSessions,ets()} where +%%% LastSid is the last allocated session id, +%%% OpenSessions is the number of currently open sessions and +%%% ets() contains mappings from Session Id to #session{}. +%%% +%%% Note: +%%% - Only persistent connections are stored in address_db +%%% - When automatically redirecting, multiple requests are performed. +-record(state,{ + address_db, % ets() + reqid % int() Next Request id to use (identifies request). + }). + +%%==================================================================== +%% External functions +%%==================================================================== +%%-------------------------------------------------------------------- +%% Function: start_link/0 +%% Description: Starts the server +%%-------------------------------------------------------------------- +start() -> + ensure_started(). + +start_link() -> + gen_server:start_link({local,?HMACALL}, ?HMANAME, [], []). + + +%% Find available session process and store in address_db. If no +%% available, start new handler process. +request(Req) -> + ensure_started(), + ClientClose=http_lib:connection_close(Req#request.headers), + gen_server:call(?HMACALL,{request,ClientClose,Req},infinity). + +cancel_request(ReqId) -> + gen_server:call(?HMACALL,{cancel_request,ReqId},infinity). + + +%%% Close Session +close_session(Addr,Sid) -> + gen_server:call(?HMACALL,{close_session,Addr,Sid},infinity). +close_session(Req,Addr,Sid) -> + gen_server:call(?HMACALL,{close_session,Req,Addr,Sid},infinity). + +abort_session(Addr,Sid,Msg) -> + gen_server:call(?HMACALL,{abort_session,Addr,Sid,Msg},infinity). + + +%%% Pick next in request que +next_request(Addr,Sid) -> + gen_server:call(?HMACALL,{next_request,Addr,Sid},infinity). + +%%% Session handler has succeded to set up a new session, now register +%%% the socket +register_socket(Addr,Sid,Socket) -> + gen_server:cast(?HMACALL,{register_socket,Addr,Sid,Socket}). + + +%%% Debugging +status() -> + gen_server:cast(?HMACALL,status). + + +%%-------------------------------------------------------------------- +%% Function: init/1 +%% Description: Initiates the server +%% Returns: {ok, State} | +%% {ok, State, Timeout} | +%% ignore | +%% {stop, Reason} +%%-------------------------------------------------------------------- +init([]) -> + process_flag(trap_exit, true), + {ok,#state{address_db=ets:new(address_db,[private]), + reqid=0}}. + + +%%-------------------------------------------------------------------- +%% Function: handle_call/3 +%% Description: Handling call messages +%% Returns: {reply, Reply, State} | +%% {reply, Reply, State, Timeout} | +%% {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, Reply, State} | (terminate/2 is called) +%% {stop, Reason, State} (terminate/2 is called) +%%-------------------------------------------------------------------- +%%% Note: +%%% - We may have multiple non-persistent connections, each will be handled in +%%% separate processes, thus don't add such connections to address_db +handle_call({request,false,Req},_From,State) -> + case ets:lookup(State#state.address_db,Req#request.address) of + [] -> + STab=ets:new(session_db,[private,{keypos,2},set]), + case persistent_new_session_request(0,Req,STab,State) of + {Reply,LastSid,State2} -> + ets:insert(State2#state.address_db, + {Req#request.address,{LastSid,1,STab}}), + {reply,Reply,State2}; + {ErrorReply,State2} -> + {reply,ErrorReply,State2} + end; + [{_,{LastSid,OpenS,STab}}] -> + case lookup_session_entry(STab) of + {ok,Session} -> + old_session_request(Session,Req,STab,State); + need_new_session when OpenS<(Req#request.settings)#client_settings.max_sessions -> + case persistent_new_session_request(LastSid,Req, + STab,State) of + {Reply,LastSid2,State2} -> + ets:insert(State2#state.address_db, + {Req#request.address, + {LastSid2,OpenS+1,STab}}), + {reply,Reply,State2}; + {ErrorReply,State2} -> + {reply,ErrorReply,State2} + end; + need_new_session -> + {reply,{error,too_many_sessions},State} + end + end; +handle_call({request,true,Req},_From,State) -> + {Reply,State2}=not_persistent_new_session_request(Req,State), + {reply,Reply,State2}; +handle_call({cancel_request,true,_ReqId},_From,State) -> +%% FIXME Should be possible to scan through all requests made, but perhaps +%% better to give some more hints (such as Addr etc) + Reply=ok, + {reply,Reply,State}; +handle_call({next_request,Addr,Sid},_From,State) -> + case ets:lookup(State#state.address_db,Addr) of + [] -> + {reply,{error,no_connection},State}; + [{_,{_,_,STab}}] -> + case ets:lookup(STab,Sid) of + [] -> + {reply,{error,session_not_registered},State}; + [S=#session{pipeline=[],quelength=QueLen}] -> + if + QueLen==1 -> + ets:insert(STab,S#session{quelength=0}); + true -> + ok + end, + {reply,no_more_requests,State}; + [S=#session{pipeline=Que}] -> + [Req|RevQue]=lists:reverse(Que), + ets:insert(STab,S#session{pipeline=lists:reverse(RevQue), + quelength=S#session.quelength-1}), + {reply,Req,State} + end + end; +handle_call({close_session,Addr,Sid},_From,State) -> + case ets:lookup(State#state.address_db,Addr) of + [] -> + {reply,{error,no_connection},State}; + [{_,{LastSid,OpenS,STab}}] -> + case ets:lookup(STab,Sid) of + [#session{pipeline=Que}] -> + R=handle_close_session(lists:reverse(Que),STab,Sid,State), + ets:insert(State#state.address_db, + {Addr,{LastSid,OpenS-1,STab}}), + {reply,R,State}; + [] -> + {reply,{error,session_not_registered},State} + end + end; +handle_call({close_session,Req,Addr,Sid},_From,State) -> + case ets:lookup(State#state.address_db,Addr) of + [] -> + {reply,{error,no_connection},State}; + [{_,{LastSid,OpenS,STab}}] -> + case ets:lookup(STab,Sid) of + [#session{pipeline=Que}] -> + R=handle_close_session([Req|lists:reverse(Que)], + STab,Sid,State), + ets:insert(State#state.address_db, + {Addr,{LastSid,OpenS-1,STab}}), + {reply,R,State}; + [] -> + {reply,{error,session_not_registered},State} + end + end; +handle_call({abort_session,Addr,Sid,Msg},_From,State) -> + case ets:lookup(State#state.address_db,Addr) of + [] -> + {reply,{error,no_connection},State}; + [{_,{LastSid,OpenS,STab}}] -> + case ets:lookup(STab,Sid) of + [#session{pipeline=Que}] -> + R=abort_request_que(Que,{error,Msg}), + ets:delete(STab,Sid), + ets:insert(State#state.address_db, + {Addr,{LastSid,OpenS-1,STab}}), + {reply,R,State}; + [] -> + {reply,{error,session_not_registered},State} + end + end. + + +%%-------------------------------------------------------------------- +%% Function: handle_cast/2 +%% Description: Handling cast messages +%% Returns: {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} (terminate/2 is called) +%%-------------------------------------------------------------------- +handle_cast(status, State) -> + io:format("Status:~n"), + print_all(lists:sort(ets:tab2list(State#state.address_db))), + {noreply, State}; +handle_cast({register_socket,Addr,Sid,Socket},State) -> + case ets:lookup(State#state.address_db,Addr) of + [] -> + {noreply,State}; + [{_,{_,_,STab}}] -> + case ets:lookup(STab,Sid) of + [Session] -> + ets:insert(STab,Session#session{socket=Socket}), + {noreply,State}; + [] -> + {noreply,State} + end + end. + +print_all([]) -> + ok; +print_all([{Addr,{LastSid,OpenSessions,STab}}|Rest]) -> + io:format(" Address:~p LastSid=~p OpenSessions=~p~n",[Addr,LastSid,OpenSessions]), + SortedList=lists:sort(fun(A,B) -> + if + A#session.id<B#session.id -> + true; + true -> + false + end + end,ets:tab2list(STab)), + print_all2(SortedList), + print_all(Rest). + +print_all2([]) -> + ok; +print_all2([Session|Rest]) -> + io:format(" Session:~p~n",[Session#session.id]), + io:format(" Client close:~p~n",[Session#session.clientclose]), + io:format(" Socket:~p~n",[Session#session.socket]), + io:format(" Pipe: length=~p Que=~p~n",[Session#session.quelength,Session#session.pipeline]), + print_all2(Rest). + +%%-------------------------------------------------------------------- +%% Function: handle_info/2 +%% Description: Handling all non call/cast messages +%% Returns: {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} (terminate/2 is called) +%%-------------------------------------------------------------------- +handle_info({'EXIT',_Pid,normal}, State) -> + {noreply, State}; +handle_info(Info, State) -> + io:format("ERROR httpc_manager:handle_info ~p~n",[Info]), + {noreply, State}. + +%%-------------------------------------------------------------------- +%% Function: terminate/2 +%% Description: Shutdown the server +%% Returns: any (ignored by gen_server) +%%-------------------------------------------------------------------- +terminate(_Reason, State) -> + ets:delete(State#state.address_db). + +%%-------------------------------------------------------------------- +%% Func: code_change/3 +%% Purpose: Convert process state when code is changed +%% Returns: {ok, NewState} +%%-------------------------------------------------------------------- +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%-------------------------------------------------------------------- +%%% Internal functions +%%-------------------------------------------------------------------- + +%%% From RFC 2616, Section 8.1.4 +%%% A client, server, or proxy MAY close the transport connection at any +%%% time. For example, a client might have started to send a new request +%%% at the same time that the server has decided to close the "idle" +%%% connection. From the server's point of view, the connection is being +%%% closed while it was idle, but from the client's point of view, a +%%% request is in progress. +%%% +%%% This means that clients, servers, and proxies MUST be able to recover +%%% from asynchronous close events. Client software SHOULD reopen the +%%% transport connection and retransmit the aborted sequence of requests +%%% without user interaction so long as the request sequence is +%%% idempotent (see section 9.1.2). Non-idempotent methods or sequences +%%% +%%% FIXME +%%% Note: +%%% - If this happen (server close because of idle) there can't be any requests +%%% in the que. +%%% - This is the main function for closing of sessions +handle_close_session([],STab,Sid,_State) -> + ets:delete(STab,Sid); +handle_close_session(Que,STab,Sid,_State) -> + ets:delete(STab,Sid), + abort_request_que(Que,{error,aborted_request}). + + +%%% From RFC 2616, Section 8.1.2.2 +%%% Clients which assume persistent connections and pipeline immediately +%%% after connection establishment SHOULD be prepared to retry their +%%% connection if the first pipelined attempt fails. If a client does +%%% such a retry, it MUST NOT pipeline before it knows the connection is +%%% persistent. Clients MUST also be prepared to resend their requests if +%%% the server closes the connection before sending all of the +%%% corresponding responses. +%%% FIXME! I'm currently not checking if tis is the first attempt on the session +%%% FIXME! Pipeline size must be dynamically variable (e.g. 0 if resend, 2 else) +%%% The que contains requests that have been sent ok previously, but the session +%%% was closed prematurely when reading the response. +%%% Try setup a new session and resend these requests. +%%% Note: +%%% - This MUST be a persistent session +% handle_closed_pipelined_session_que([],_State) -> +% ok; +% handle_closed_pipelined_session_que(_Que,_State) -> +% ok. + + +%%% From RFC 2616, Section 8.2.4 +%%% If an HTTP/1.1 client sends a request which includes a request body, +%%% but which does not include an Expect request-header field with the +%%% "100-continue" expectation, and if the client is not directly +%%% connected to an HTTP/1.1 origin server, and if the client sees the +%%% connection close before receiving any status from the server, the +%%% client SHOULD retry the request. If the client does retry this +%%% request, it MAY use the following "binary exponential backoff" +%%% algorithm to be assured of obtaining a reliable response: +%%% ... +%%% FIXME! I'm currently not checking if a "Expect: 100-continue" has been sent. +% handle_remotely_closed_session_que([],_State) -> +% ok; +% handle_remotely_closed_session_que(_Que,_State) -> +% % resend_que(Que,Socket), +% ok. + +%%% Resend all requests in the request que +% resend_que([],_) -> +% ok; +% resend_que([Req|Que],Socket) -> +% case catch httpc_handler:http_request(Req,Socket) of +% ok -> +% resend_que(Que,Socket); +% {error,Reason} -> +% {error,Reason} +% end. + + +%%% From RFC 2616, +%%% Section 8.1.2.2: +%%% Clients SHOULD NOT pipeline requests using non-idempotent methods or +%%% non-idempotent sequences of methods (see section 9.1.2). Otherwise, a +%%% premature termination of the transport connection could lead to +%%% indeterminate results. A client wishing to send a non-idempotent +%%% request SHOULD wait to send that request until it has received the +%%% response status for the previous request. +%%% Section 9.1.2: +%%% Methods can also have the property of "idempotence" in that (aside +%%% from error or expiration issues) the side-effects of N > 0 identical +%%% requests is the same as for a single request. The methods GET, HEAD, +%%% PUT and DELETE share this property. Also, the methods OPTIONS and +%%% TRACE SHOULD NOT have side effects, and so are inherently idempotent. +%%% +%%% Note that POST and CONNECT are idempotent methods. +%%% +%%% Tries to find an open, free session i STab. Such a session has quelength +%%% less than ?MAX_PIPELINE_LENGTH +%%% Don't care about non-standard, user defined methods. +%%% +%%% Returns {ok,Session} or need_new_session where +%%% Session is the session that may be used +lookup_session_entry(STab) -> + MS=[{#session{quelength='$1',max_quelength='$2', + id='_',clientclose='_',socket='$3',scheme='_',pipeline='_'}, + [{'<','$1','$2'},{is_port,'$3'}], + ['$_']}], + case ets:select(STab,MS) of + [] -> + need_new_session; + SessionList -> % Now check if any of these has an empty pipeline. + case lists:keysearch(0,2,SessionList) of + {value,Session} -> + {ok,Session}; + false -> + {ok,hd(SessionList)} + end + end. + + +%%% Returns a tuple {Reply,State} where +%%% Reply is the response sent back to the application +%%% +%%% Note: +%%% - An {error,einval} from a send should sometimes rather be {error,closed} +%%% - Don't close the session from here, let httpc_handler take care of that. +%old_session_request(Session,Req,STab,State) +% when (Req#request.settings)#client_settings.max_quelength==0 -> +% Session1=Session#session{pipeline=[Req]}, +% ets:insert(STab,Session1), +% {reply,{ok,ReqId},State#state{reqid=ReqId+1}}; +old_session_request(Session,Req,STab,State) -> + ReqId=State#state.reqid, + Req1=Req#request{id=ReqId}, + case catch httpc_handler:http_request(Req1,Session#session.socket) of + ok -> + Session1=Session#session{pipeline=[Req1|Session#session.pipeline], + quelength=Session#session.quelength+1}, + ets:insert(STab,Session1), + {reply,{ok,ReqId},State#state{reqid=ReqId+1}}; + {error,Reason} -> + ets:insert(STab,Session#session{socket=undefined}), +% http_lib:close(Session#session.sockettype,Session#session.socket), + {reply,{error,Reason},State#state{reqid=ReqId+1}} + end. + +%%% Returns atuple {Reply,Sid,State} where +%%% Reply is the response sent back to the application, and +%%% Sid is the last used Session Id +persistent_new_session_request(Sid,Req,STab,State) -> + ReqId=State#state.reqid, + case setup_new_session(Req#request{id=ReqId},false,Sid) of + {error,Reason} -> + {{error,Reason},State#state{reqid=ReqId+1}}; + {NewSid,Session} -> + ets:insert(STab,Session), + {{ok,ReqId},NewSid,State#state{reqid=ReqId+1}} + end. + +%%% Returns a tuple {Reply,State} where +%%% Reply is the response sent back to the application +not_persistent_new_session_request(Req,State) -> + ReqId=State#state.reqid, + case setup_new_session(Req#request{id=ReqId},true,undefined) of + {error,Reason} -> + {{error,Reason},State#state{reqid=ReqId+1}}; + ok -> + {{ok,ReqId},State#state{reqid=ReqId+1}} + end. + +%%% As there are no sessions available, setup a new session and send the request +%%% on it. +setup_new_session(Req,ClientClose,Sid) -> + S=#session{id=Sid,clientclose=ClientClose, + scheme=Req#request.scheme, + max_quelength=(Req#request.settings)#client_settings.max_quelength}, + spawn_link(httpc_handler,init_connection,[Req,S]), + case ClientClose of + false -> + {Sid+1,S}; + true -> + ok + end. + + +%%% ---------------------------------------------------------------------------- +%%% Abort all requests in the request que. +abort_request_que([],_Msg) -> + ok; +abort_request_que([#request{from=From,ref=Ref,id=Id}|Que],Msg) -> + gen_server:cast(From,{Ref,Id,Msg}), + abort_request_que(Que,Msg); +abort_request_que(#request{from=From,ref=Ref,id=Id},Msg) -> + gen_server:cast(From,{Ref,Id,Msg}). + + +%%% -------------------------------- +% C={httpc_manager,{?MODULE,start_link,[]},permanent,1000, +% worker,[?MODULE]}, +% supervisor:start_child(inets_sup, C), +ensure_started() -> + case whereis(?HMANAME) of + undefined -> + start_link(); + _ -> + ok + end. + + +%%% ============================================================================ +%%% This is deprecated code, to be removed + +% format_time() -> +% {_,_,MicroSecs}=TS=now(), +% {{Y,Mon,D},{H,M,S}}=calendar:now_to_universal_time(TS), +% lists:flatten(io_lib:format("~4.4.0w-~2.2.0w-~2.2.0w,~2.2.0w:~2.2.0w:~6.3.0f", +% [Y,Mon,D,H,M,S+(MicroSecs/1000000)])). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd.erl new file mode 100644 index 0000000000..3199e4430d --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd.erl @@ -0,0 +1,594 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd.erl,v 1.1 2008/12/17 09:53:33 mikpe Exp $ +%% +-module(httpd). +-export([multi_start/1, multi_start_link/1, + start/0, start/1, start/2, + start_link/0, start_link/1, start_link/2, + start_child/0,start_child/1, + multi_stop/1, + stop/0,stop/1,stop/2, + stop_child/0,stop_child/1,stop_child/2, + multi_restart/1, + restart/0,restart/1,restart/2, + parse_query/1]). + +%% Optional start related stuff... +-export([load/1, load_mime_types/1, + start2/1, start2/2, + start_link2/1, start_link2/2, + stop2/1]). + +%% Management stuff +-export([block/0,block/1,block/2,block/3,block/4, + unblock/0,unblock/1,unblock/2]). + +%% Debugging and status info stuff... +-export([verbosity/3,verbosity/4]). +-export([get_status/1,get_status/2,get_status/3, + get_admin_state/0,get_admin_state/1,get_admin_state/2, + get_usage_state/0,get_usage_state/1,get_usage_state/2]). + +-include("httpd.hrl"). + +-define(D(F, A), io:format("~p:" ++ F ++ "~n", [?MODULE|A])). + + +%% start + +start() -> + start("/var/tmp/server_root/conf/8888.conf"). + +start(ConfigFile) -> + %% ?D("start(~s) -> entry", [ConfigFile]), + start(ConfigFile, []). + +start(ConfigFile, Verbosity) when list(ConfigFile), list(Verbosity) -> + httpd_sup:start(ConfigFile, Verbosity). + + +%% start_link + +start_link() -> + start("/var/tmp/server_root/conf/8888.conf"). + +start_link(ConfigFile) -> + start_link(ConfigFile, []). + +start_link(ConfigFile, Verbosity) when list(ConfigFile), list(Verbosity) -> + httpd_sup:start_link(ConfigFile, Verbosity). + + +%% start2 & start_link2 + +start2(Config) -> + start2(Config, []). + +start2(Config, Verbosity) when list(Config), list(Verbosity) -> + httpd_sup:start2(Config, Verbosity). + +start_link2(Config) -> + start_link2(Config, []). + +start_link2(Config, Verbosity) when list(Config), list(Verbosity) -> + httpd_sup:start_link2(Config, Verbosity). + + +%% stop + +stop() -> + stop(8888). + +stop(Port) when integer(Port) -> + stop(undefined, Port); +stop(Pid) when pid(Pid) -> + httpd_sup:stop(Pid); +stop(ConfigFile) when list(ConfigFile) -> + %% ?D("stop(~s) -> entry", [ConfigFile]), + httpd_sup:stop(ConfigFile). + +stop(Addr, Port) when integer(Port) -> + httpd_sup:stop(Addr, Port). + +stop2(Config) when list(Config) -> + httpd_sup:stop2(Config). + +%% start_child + +start_child() -> + start_child("/var/tmp/server_root/conf/8888.conf"). + +start_child(ConfigFile) -> + start_child(ConfigFile, []). + +start_child(ConfigFile, Verbosity) -> + inets_sup:start_child(ConfigFile, Verbosity). + + +%% stop_child + +stop_child() -> + stop_child(8888). + +stop_child(Port) -> + stop_child(undefined,Port). + +stop_child(Addr, Port) when integer(Port) -> + inets_sup:stop_child(Addr, Port). + + +%% multi_start + +multi_start(MultiConfigFile) -> + case read_multi_file(MultiConfigFile) of + {ok,ConfigFiles} -> + mstart(ConfigFiles); + Error -> + Error + end. + +mstart(ConfigFiles) -> + mstart(ConfigFiles,[]). +mstart([],Results) -> + {ok,lists:reverse(Results)}; +mstart([H|T],Results) -> + Res = start(H), + mstart(T,[Res|Results]). + + +%% multi_start_link + +multi_start_link(MultiConfigFile) -> + case read_multi_file(MultiConfigFile) of + {ok,ConfigFiles} -> + mstart_link(ConfigFiles); + Error -> + Error + end. + +mstart_link(ConfigFiles) -> + mstart_link(ConfigFiles,[]). +mstart_link([],Results) -> + {ok,lists:reverse(Results)}; +mstart_link([H|T],Results) -> + Res = start_link(H), + mstart_link(T,[Res|Results]). + + +%% multi_stop + +multi_stop(MultiConfigFile) -> + case read_multi_file(MultiConfigFile) of + {ok,ConfigFiles} -> + mstop(ConfigFiles); + Error -> + Error + end. + +mstop(ConfigFiles) -> + mstop(ConfigFiles,[]). +mstop([],Results) -> + {ok,lists:reverse(Results)}; +mstop([H|T],Results) -> + Res = stop(H), + mstop(T,[Res|Results]). + + +%% multi_restart + +multi_restart(MultiConfigFile) -> + case read_multi_file(MultiConfigFile) of + {ok,ConfigFiles} -> + mrestart(ConfigFiles); + Error -> + Error + end. + +mrestart(ConfigFiles) -> + mrestart(ConfigFiles,[]). +mrestart([],Results) -> + {ok,lists:reverse(Results)}; +mrestart([H|T],Results) -> + Res = restart(H), + mrestart(T,[Res|Results]). + + +%% restart + +restart() -> restart(undefined,8888). + +restart(Port) when integer(Port) -> + restart(undefined,Port); +restart(ConfigFile) when list(ConfigFile) -> + case get_addr_and_port(ConfigFile) of + {ok,Addr,Port} -> + restart(Addr,Port); + Error -> + Error + end. + + +restart(Addr,Port) when integer(Port) -> + do_restart(Addr,Port). + +do_restart(Addr,Port) when integer(Port) -> + Name = make_name(Addr,Port), + case whereis(Name) of + Pid when pid(Pid) -> + httpd_manager:restart(Pid); + _ -> + {error,not_started} + end. + + +%%% ========================================================= +%%% Function: block/0, block/1, block/2, block/3, block/4 +%%% block() +%%% block(Port) +%%% block(ConfigFile) +%%% block(Addr,Port) +%%% block(Port,Mode) +%%% block(ConfigFile,Mode) +%%% block(Addr,Port,Mode) +%%% block(ConfigFile,Mode,Timeout) +%%% block(Addr,Port,Mode,Timeout) +%%% +%%% Returns: ok | {error,Reason} +%%% +%%% Description: This function is used to block an HTTP server. +%%% The blocking can be done in two ways, +%%% disturbing or non-disturbing. Default is disturbing. +%%% When a HTTP server is blocked, all requests are rejected +%%% (status code 503). +%%% +%%% disturbing: +%%% By performing a disturbing block, the server +%%% is blocked forcefully and all ongoing requests +%%% are terminated. No new connections are accepted. +%%% If a timeout time is given then, on-going requests +%%% are given this much time to complete before the +%%% server is forcefully blocked. In this case no new +%%% connections is accepted. +%%% +%%% non-disturbing: +%%% A non-disturbing block is more gracefull. No +%%% new connections are accepted, but the ongoing +%%% requests are allowed to complete. +%%% If a timeout time is given, it waits this long before +%%% giving up (the block operation is aborted and the +%%% server state is once more not-blocked). +%%% +%%% Types: Port -> integer() +%%% Addr -> {A,B,C,D} | string() | undefined +%%% ConfigFile -> string() +%%% Mode -> disturbing | non_disturbing +%%% Timeout -> integer() +%%% +block() -> block(undefined,8888,disturbing). + +block(Port) when integer(Port) -> + block(undefined,Port,disturbing); + +block(ConfigFile) when list(ConfigFile) -> + case get_addr_and_port(ConfigFile) of + {ok,Addr,Port} -> + block(Addr,Port,disturbing); + Error -> + Error + end. + +block(Addr,Port) when integer(Port) -> + block(Addr,Port,disturbing); + +block(Port,Mode) when integer(Port), atom(Mode) -> + block(undefined,Port,Mode); + +block(ConfigFile,Mode) when list(ConfigFile), atom(Mode) -> + case get_addr_and_port(ConfigFile) of + {ok,Addr,Port} -> + block(Addr,Port,Mode); + Error -> + Error + end. + + +block(Addr,Port,disturbing) when integer(Port) -> + do_block(Addr,Port,disturbing); +block(Addr,Port,non_disturbing) when integer(Port) -> + do_block(Addr,Port,non_disturbing); + +block(ConfigFile,Mode,Timeout) when list(ConfigFile), atom(Mode), integer(Timeout) -> + case get_addr_and_port(ConfigFile) of + {ok,Addr,Port} -> + block(Addr,Port,Mode,Timeout); + Error -> + Error + end. + + +block(Addr,Port,non_disturbing,Timeout) when integer(Port), integer(Timeout) -> + do_block(Addr,Port,non_disturbing,Timeout); +block(Addr,Port,disturbing,Timeout) when integer(Port), integer(Timeout) -> + do_block(Addr,Port,disturbing,Timeout). + +do_block(Addr,Port,Mode) when integer(Port), atom(Mode) -> + Name = make_name(Addr,Port), + case whereis(Name) of + Pid when pid(Pid) -> + httpd_manager:block(Pid,Mode); + _ -> + {error,not_started} + end. + + +do_block(Addr,Port,Mode,Timeout) when integer(Port), atom(Mode) -> + Name = make_name(Addr,Port), + case whereis(Name) of + Pid when pid(Pid) -> + httpd_manager:block(Pid,Mode,Timeout); + _ -> + {error,not_started} + end. + + +%%% ========================================================= +%%% Function: unblock/0, unblock/1, unblock/2 +%%% unblock() +%%% unblock(Port) +%%% unblock(ConfigFile) +%%% unblock(Addr,Port) +%%% +%%% Description: This function is used to reverse a previous block +%%% operation on the HTTP server. +%%% +%%% Types: Port -> integer() +%%% Addr -> {A,B,C,D} | string() | undefined +%%% ConfigFile -> string() +%%% +unblock() -> unblock(undefined,8888). +unblock(Port) when integer(Port) -> unblock(undefined,Port); + +unblock(ConfigFile) when list(ConfigFile) -> + case get_addr_and_port(ConfigFile) of + {ok,Addr,Port} -> + unblock(Addr,Port); + Error -> + Error + end. + +unblock(Addr,Port) when integer(Port) -> + Name = make_name(Addr,Port), + case whereis(Name) of + Pid when pid(Pid) -> + httpd_manager:unblock(Pid); + _ -> + {error,not_started} + end. + + +verbosity(Port,Who,Verbosity) -> + verbosity(undefined,Port,Who,Verbosity). + +verbosity(Addr,Port,Who,Verbosity) -> + Name = make_name(Addr,Port), + case whereis(Name) of + Pid when pid(Pid) -> + httpd_manager:verbosity(Pid,Who,Verbosity); + _ -> + not_started + end. + + +%%% ========================================================= +%%% Function: get_admin_state/0, get_admin_state/1, get_admin_state/2 +%%% get_admin_state() +%%% get_admin_state(Port) +%%% get_admin_state(Addr,Port) +%%% +%%% Returns: {ok,State} | {error,Reason} +%%% +%%% Description: This function is used to retrieve the administrative +%%% state of the HTTP server. +%%% +%%% Types: Port -> integer() +%%% Addr -> {A,B,C,D} | string() | undefined +%%% State -> unblocked | shutting_down | blocked +%%% Reason -> term() +%%% +get_admin_state() -> get_admin_state(undefined,8888). +get_admin_state(Port) when integer(Port) -> get_admin_state(undefined,Port); + +get_admin_state(ConfigFile) when list(ConfigFile) -> + case get_addr_and_port(ConfigFile) of + {ok,Addr,Port} -> + unblock(Addr,Port); + Error -> + Error + end. + +get_admin_state(Addr,Port) when integer(Port) -> + Name = make_name(Addr,Port), + case whereis(Name) of + Pid when pid(Pid) -> + httpd_manager:get_admin_state(Pid); + _ -> + {error,not_started} + end. + + + +%%% ========================================================= +%%% Function: get_usage_state/0, get_usage_state/1, get_usage_state/2 +%%% get_usage_state() +%%% get_usage_state(Port) +%%% get_usage_state(Addr,Port) +%%% +%%% Returns: {ok,State} | {error,Reason} +%%% +%%% Description: This function is used to retrieve the usage +%%% state of the HTTP server. +%%% +%%% Types: Port -> integer() +%%% Addr -> {A,B,C,D} | string() | undefined +%%% State -> idle | active | busy +%%% Reason -> term() +%%% +get_usage_state() -> get_usage_state(undefined,8888). +get_usage_state(Port) when integer(Port) -> get_usage_state(undefined,Port); + +get_usage_state(ConfigFile) when list(ConfigFile) -> + case get_addr_and_port(ConfigFile) of + {ok,Addr,Port} -> + unblock(Addr,Port); + Error -> + Error + end. + +get_usage_state(Addr,Port) when integer(Port) -> + Name = make_name(Addr,Port), + case whereis(Name) of + Pid when pid(Pid) -> + httpd_manager:get_usage_state(Pid); + _ -> + {error,not_started} + end. + + + +%%% ========================================================= +%% Function: get_status(ConfigFile) -> Status +%% get_status(Port) -> Status +%% get_status(Addr,Port) -> Status +%% get_status(Port,Timeout) -> Status +%% get_status(Addr,Port,Timeout) -> Status +%% +%% Arguments: ConfigFile -> string() +%% Configuration file from which Port and +%% BindAddress will be extracted. +%% Addr -> {A,B,C,D} | string() +%% Bind Address of the http server +%% Port -> integer() +%% Port number of the http server +%% Timeout -> integer() +%% Timeout time for the call +%% +%% Returns: Status -> list() +%% +%% Description: This function is used when the caller runs in the +%% same node as the http server or if calling with a +%% program such as erl_call (see erl_interface). +%% + +get_status(ConfigFile) when list(ConfigFile) -> + case get_addr_and_port(ConfigFile) of + {ok,Addr,Port} -> + get_status(Addr,Port); + Error -> + Error + end; + +get_status(Port) when integer(Port) -> + get_status(undefined,Port,5000). + +get_status(Port,Timeout) when integer(Port), integer(Timeout) -> + get_status(undefined,Port,Timeout); + +get_status(Addr,Port) when list(Addr), integer(Port) -> + get_status(Addr,Port,5000). + +get_status(Addr,Port,Timeout) when integer(Port) -> + Name = make_name(Addr,Port), + case whereis(Name) of + Pid when pid(Pid) -> + httpd_manager:get_status(Pid,Timeout); + _ -> + not_started + end. + + +%% load config + +load(ConfigFile) -> + httpd_conf:load(ConfigFile). + +load_mime_types(MimeTypesFile) -> + httpd_conf:load_mime_types(MimeTypesFile). + + +%% parse_query + +parse_query(String) -> + {ok, SplitString} = regexp:split(String,"[&;]"), + foreach(SplitString). + +foreach([]) -> + []; +foreach([KeyValue|Rest]) -> + {ok, Plus2Space, _} = regexp:gsub(KeyValue,"[\+]"," "), + case regexp:split(Plus2Space,"=") of + {ok,[Key|Value]} -> + [{httpd_util:decode_hex(Key), + httpd_util:decode_hex(lists:flatten(Value))}|foreach(Rest)]; + {ok,_} -> + foreach(Rest) + end. + + +%% get_addr_and_port + +get_addr_and_port(ConfigFile) -> + case httpd_conf:load(ConfigFile) of + {ok,ConfigList} -> + Port = httpd_util:key1search(ConfigList,port,80), + Addr = httpd_util:key1search(ConfigList,bind_address), + {ok,Addr,Port}; + Error -> + Error + end. + + +%% make_name + +make_name(Addr,Port) -> + httpd_util:make_name("httpd",Addr,Port). + + +%% Multi stuff +%% + +read_multi_file(File) -> + read_mfile(file:open(File,[read])). + +read_mfile({ok,Fd}) -> + read_mfile(read_line(Fd),Fd,[]); +read_mfile(Error) -> + Error. + +read_mfile(eof,_Fd,SoFar) -> + {ok,lists:reverse(SoFar)}; +read_mfile({error,Reason},_Fd,SoFar) -> + {error,Reason}; +read_mfile([$#|Comment],Fd,SoFar) -> + read_mfile(read_line(Fd),Fd,SoFar); +read_mfile([],Fd,SoFar) -> + read_mfile(read_line(Fd),Fd,SoFar); +read_mfile(Line,Fd,SoFar) -> + read_mfile(read_line(Fd),Fd,[Line|SoFar]). + +read_line(Fd) -> read_line1(io:get_line(Fd,[])). +read_line1(eof) -> eof; +read_line1(String) -> httpd_conf:clean(String). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd.hrl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd.hrl new file mode 100644 index 0000000000..015c1b1e2d --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd.hrl @@ -0,0 +1,77 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd.hrl,v 1.1 2008/12/17 09:53:33 mikpe Exp $ +%% + +-include_lib("kernel/include/file.hrl"). + +-ifndef(SERVER_SOFTWARE). +-define(SERVER_SOFTWARE,"inets/develop"). % Define in Makefile! +-endif. +-define(SERVER_PROTOCOL,"HTTP/1.1"). +-define(SOCKET_CHUNK_SIZE,8192). +-define(SOCKET_MAX_POLL,25). +-define(FILE_CHUNK_SIZE,64*1024). +-define(NICE(Reason),lists:flatten(atom_to_list(?MODULE)++": "++Reason)). +-define(DEFAULT_CONTEXT, + [{errmsg,"[an error occurred while processing this directive]"}, + {timefmt,"%A, %d-%b-%y %T %Z"}, + {sizefmt,"abbrev"}]). + + +-ifdef(inets_error). +-define(ERROR(Format, Args), io:format("E(~p:~p:~p) : "++Format++"~n", + [self(),?MODULE,?LINE]++Args)). +-else. +-define(ERROR(F,A),[]). +-endif. + +-ifdef(inets_log). +-define(LOG(Format, Args), io:format("L(~p:~p:~p) : "++Format++"~n", + [self(),?MODULE,?LINE]++Args)). +-else. +-define(LOG(F,A),[]). +-endif. + +-ifdef(inets_debug). +-define(DEBUG(Format, Args), io:format("D(~p:~p:~p) : "++Format++"~n", + [self(),?MODULE,?LINE]++Args)). +-else. +-define(DEBUG(F,A),[]). +-endif. + +-ifdef(inets_cdebug). +-define(CDEBUG(Format, Args), io:format("C(~p:~p:~p) : "++Format++"~n", + [self(),?MODULE,?LINE]++Args)). +-else. +-define(CDEBUG(F,A),[]). +-endif. + + +-record(init_data,{peername,resolve}). +-record(mod,{init_data, + data=[], + socket_type=ip_comm, + socket, + config_db, + method, + absolute_uri=[], + request_uri, + http_version, + request_line, + parsed_header=[], + entity_body, + connection}). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_acceptor.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_acceptor.erl new file mode 100644 index 0000000000..7bf2d5d868 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_acceptor.erl @@ -0,0 +1,174 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_acceptor.erl,v 1.1 2008/12/17 09:53:33 mikpe Exp $ +%% +-module(httpd_acceptor). + +-include("httpd.hrl"). +-include("httpd_verbosity.hrl"). + + +%% External API +-export([start_link/6]). + +%% Other exports (for spawn's etc.) +-export([acceptor/4, acceptor/7]). + + +%% +%% External API +%% + +%% start_link + +start_link(Manager, SocketType, Addr, Port, ConfigDb, Verbosity) -> + Args = [self(), Manager, SocketType, Addr, Port, ConfigDb, Verbosity], + proc_lib:start_link(?MODULE, acceptor, Args). + + +acceptor(Parent, Manager, SocketType, Addr, Port, ConfigDb, Verbosity) -> + put(sname,acc), + put(verbosity,Verbosity), + ?vlog("starting",[]), + case (catch do_init(SocketType, Addr, Port)) of + {ok, ListenSocket} -> + proc_lib:init_ack(Parent, {ok, self()}), + acceptor(Manager, SocketType, ListenSocket, ConfigDb); + Error -> + proc_lib:init_ack(Parent, Error), + error + end. + +do_init(SocketType, Addr, Port) -> + do_socket_start(SocketType), + ListenSocket = do_socket_listen(SocketType, Addr, Port), + {ok, ListenSocket}. + + +do_socket_start(SocketType) -> + case httpd_socket:start(SocketType) of + ok -> + ok; + {error, Reason} -> + ?vinfo("failed socket start: ~p",[Reason]), + throw({error, {socket_start_failed, Reason}}) + end. + + +do_socket_listen(SocketType, Addr, Port) -> + case httpd_socket:listen(SocketType, Addr, Port) of + {error, Reason} -> + ?vinfo("failed socket listen operation: ~p", [Reason]), + throw({error, {listen, Reason}}); + ListenSocket -> + ListenSocket + end. + + +%% acceptor + +acceptor(Manager, SocketType, ListenSocket, ConfigDb) -> + ?vdebug("await connection",[]), + case (catch httpd_socket:accept(SocketType, ListenSocket, 30000)) of + {error, Reason} -> + handle_error(Reason, ConfigDb, SocketType), + ?MODULE:acceptor(Manager, SocketType, ListenSocket, ConfigDb); + + {'EXIT', Reason} -> + handle_error({'EXIT', Reason}, ConfigDb, SocketType), + ?MODULE:acceptor(Manager, SocketType, ListenSocket, ConfigDb); + + Socket -> + handle_connection(Manager, ConfigDb, SocketType, Socket), + ?MODULE:acceptor(Manager, SocketType, ListenSocket, ConfigDb) + end. + + +handle_connection(Manager, ConfigDb, SocketType, Socket) -> + case httpd_request_handler:start_link(Manager, ConfigDb) of + {ok, Pid} -> + httpd_socket:controlling_process(SocketType, Socket, Pid), + httpd_request_handler:synchronize(Pid, SocketType, Socket); + {error, Reason} -> + handle_connection_err(SocketType, Socket, ConfigDb, Reason) + end. + + +handle_connection_err(SocketType, Socket, ConfigDb, Reason) -> + String = + lists:flatten( + io_lib:format("failed starting request handler:~n ~p", [Reason])), + report_error(ConfigDb, String), + httpd_socket:close(SocketType, Socket). + + +handle_error(timeout, _, _) -> + ?vtrace("Accept timeout",[]), + ok; + +handle_error({enfile, _}, _, _) -> + ?vinfo("Accept error: enfile",[]), + %% Out of sockets... + sleep(200); + +handle_error(emfile, _, _) -> + ?vinfo("Accept error: emfile",[]), + %% Too many open files -> Out of sockets... + sleep(200); + +handle_error(closed, _, _) -> + ?vlog("Accept error: closed",[]), + %% This propably only means that the application is stopping, + %% but just in case + exit(closed); + +handle_error(econnaborted, _, _) -> + ?vlog("Accept aborted",[]), + ok; + +handle_error(esslaccept, _, _) -> + %% The user has selected to cancel the installation of + %% the certifikate, This is not a real error, so we do + %% not write an error message. + ok; + +handle_error({'EXIT', Reason}, ConfigDb, SocketType) -> + ?vinfo("Accept exit:~n ~p",[Reason]), + String = lists:flatten(io_lib:format("Accept exit: ~p", [Reason])), + accept_failed(SocketType, ConfigDb, String); + +handle_error(Reason, ConfigDb, SocketType) -> + ?vinfo("Accept error:~n ~p",[Reason]), + String = lists:flatten(io_lib:format("Accept error: ~p", [Reason])), + accept_failed(SocketType, ConfigDb, String). + + +accept_failed(SocketType, ConfigDb, String) -> + error_logger:error_report(String), + mod_log:error_log(SocketType, undefined, ConfigDb, + {0, "unknown"}, String), + mod_disk_log:error_log(SocketType, undefined, ConfigDb, + {0, "unknown"}, String), + exit({accept_failed, String}). + + +report_error(Db, String) -> + error_logger:error_report(String), + mod_log:report_error(Db, String), + mod_disk_log:report_error(Db, String). + + +sleep(T) -> receive after T -> ok end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_acceptor_sup.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_acceptor_sup.erl new file mode 100644 index 0000000000..86c31ad5df --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_acceptor_sup.erl @@ -0,0 +1,116 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_acceptor_sup.erl,v 1.1 2008/12/17 09:53:33 mikpe Exp $ +%% +%%---------------------------------------------------------------------- +%% Purpose: The top supervisor for the Megaco/H.248 application +%%---------------------------------------------------------------------- + +-module(httpd_acceptor_sup). + +-behaviour(supervisor). + +-include("httpd_verbosity.hrl"). + +%% public +-export([start/3, stop/1, init/1]). + +-export([start_acceptor/4, stop_acceptor/2]). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% supervisor callback functions + + +start(Addr, Port, AccSupVerbosity) -> + SupName = make_name(Addr, Port), + supervisor:start_link({local, SupName}, ?MODULE, [AccSupVerbosity]). + +stop(StartArgs) -> + ok. + +init([Verbosity]) -> % Supervisor + do_init(Verbosity); +init(BadArg) -> + {error, {badarg, BadArg}}. + +do_init(Verbosity) -> + put(verbosity,?vvalidate(Verbosity)), + put(sname,acc_sup), + ?vlog("starting", []), + Flags = {one_for_one, 500, 100}, + KillAfter = timer:seconds(1), + Workers = [], + {ok, {Flags, Workers}}. + + +%%---------------------------------------------------------------------- +%% Function: [start|stop]_acceptor/5 +%% Description: Starts a [auth | security] worker (child) process +%%---------------------------------------------------------------------- + +start_acceptor(SocketType, Addr, Port, ConfigDb) -> + Verbosity = get_acc_verbosity(), + start_worker(httpd_acceptor, SocketType, Addr, Port, + ConfigDb, Verbosity, self(), []). + +stop_acceptor(Addr, Port) -> + stop_worker(httpd_acceptor, Addr, Port). + + +%%---------------------------------------------------------------------- +%% Function: start_worker/5 +%% Description: Starts a (permanent) worker (child) process +%%---------------------------------------------------------------------- + +start_worker(M, SocketType, Addr, Port, ConfigDB, Verbosity, Manager, + Modules) -> + SupName = make_name(Addr, Port), + Args = [Manager, SocketType, Addr, Port, ConfigDB, Verbosity], + Spec = {{M, Addr, Port}, + {M, start_link, Args}, + permanent, timer:seconds(1), worker, [M] ++ Modules}, + supervisor:start_child(SupName, Spec). + + +%%---------------------------------------------------------------------- +%% Function: stop_permanent_worker/3 +%% Description: Stops a permanent worker (child) process +%%---------------------------------------------------------------------- + +stop_worker(M, Addr, Port) -> + SupName = make_name(Addr, Port), + Name = {M, Addr, Port}, + case supervisor:terminate_child(SupName, Name) of + ok -> + supervisor:delete_child(SupName, Name); + Error -> + Error + end. + + +make_name(Addr,Port) -> + httpd_util:make_name("httpd_acc_sup",Addr,Port). + + + +get_acc_verbosity() -> + get_verbosity(get(acceptor_verbosity)). + +get_verbosity(undefined) -> + ?default_verbosity; +get_verbosity(V) -> + ?vvalidate(V). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_conf.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_conf.erl new file mode 100644 index 0000000000..69419b1eb3 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_conf.erl @@ -0,0 +1,688 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_conf.erl,v 1.1 2008/12/17 09:53:33 mikpe Exp $ +%% +-module(httpd_conf). +-export([load/1, load_mime_types/1, + load/2, store/1, store/2, + remove_all/1, remove/1, + is_directory/1, is_file/1, + make_integer/1, clean/1, custom_clean/3, check_enum/2]). + + +-define(VMODULE,"CONF"). +-include("httpd_verbosity.hrl"). + +%% The configuration data is handled in three (3) phases: +%% 1. Parse the config file and put all directives into a key-vale +%% tuple list (load/1). +%% 2. Traverse the key-value tuple list store it into an ETS table. +%% Directives depending on other directives are taken care of here +%% (store/1). +%% 3. Traverse the ETS table and do a complete clean-up (remove/1). + +-include("httpd.hrl"). + +%% +%% Phase 1: Load +%% + +%% load + +load(ConfigFile) -> + ?CDEBUG("load -> ConfigFile: ~p",[ConfigFile]), + case read_config_file(ConfigFile) of + {ok, Config} -> + case bootstrap(Config) of + {error, Reason} -> + {error, Reason}; + {ok, Modules} -> + load_config(Config, lists:append(Modules, [?MODULE])) + end; + {error, Reason} -> + {error, ?NICE("Error while reading config file: "++Reason)} + end. + + +bootstrap([]) -> + {error, ?NICE("Modules must be specified in the config file")}; +bootstrap([Line|Config]) -> + case Line of + [$M,$o,$d,$u,$l,$e,$s,$ |Modules] -> + {ok, ModuleList} = regexp:split(Modules," "), + TheMods = [list_to_atom(X) || X <- ModuleList], + case verify_modules(TheMods) of + ok -> + {ok, TheMods}; + {error, Reason} -> + ?ERROR("bootstrap -> : validation failed: ~p",[Reason]), + {error, Reason} + end; + _ -> + bootstrap(Config) + end. + + +%% +%% verify_modules/1 -> ok | {error, Reason} +%% +%% Verifies that all specified modules are available. +%% +verify_modules([]) -> + ok; +verify_modules([Mod|Rest]) -> + case code:which(Mod) of + non_existing -> + {error, ?NICE(atom_to_list(Mod)++" does not exist")}; + Path -> + verify_modules(Rest) + end. + +%% +%% read_config_file/1 -> {ok, [line(), line()..]} | {error, Reason} +%% +%% Reads the entire configuration file and returns list of strings or +%% and error. +%% + + +read_config_file(FileName) -> + case file:open(FileName, [read]) of + {ok, Stream} -> + read_config_file(Stream, []); + {error, Reason} -> + {error, ?NICE("Cannot open "++FileName)} + end. + +read_config_file(Stream, SoFar) -> + case io:get_line(Stream, []) of + eof -> + {ok, lists:reverse(SoFar)}; + {error, Reason} -> + {error, Reason}; + [$#|Rest] -> + %% Ignore commented lines for efficiency later .. + read_config_file(Stream, SoFar); + Line -> + {ok, NewLine, _}=regexp:sub(clean(Line),"[\t\r\f ]"," "), + case NewLine of + [] -> + %% Also ignore empty lines .. + read_config_file(Stream, SoFar); + Other -> + read_config_file(Stream, [NewLine|SoFar]) + end + end. + +is_exported(Module, ToFind) -> + Exports = Module:module_info(exports), + lists:member(ToFind, Exports). + +%% +%% load/4 -> {ok, ConfigList} | {error, Reason} +%% +%% This loads the config file into each module specified by Modules +%% Each module has its own context that is passed to and (optionally) +%% returned by the modules load function. The module can also return +%% a ConfigEntry, which will be added to the global configuration +%% list. +%% All configuration directives are guaranteed to be passed to all +%% modules. Each module only implements the function clauses of +%% the load function for the configuration directives it supports, +%% it's ok if an apply returns {'EXIT', {function_clause, ..}}. +%% +load_config(Config, Modules) -> + %% Create default contexts for all modules + Contexts = lists:duplicate(length(Modules), []), + load_config(Config, Modules, Contexts, []). + + +load_config([], _Modules, _Contexts, ConfigList) -> + case a_must(ConfigList, [server_name,port,server_root,document_root]) of + ok -> + {ok, ConfigList}; + {missing, Directive} -> + {error, ?NICE(atom_to_list(Directive)++ + " must be specified in the config file")} + end; + +load_config([Line|Config], Modules, Contexts, ConfigList) -> + ?CDEBUG("load_config -> Line: ~p",[Line]), + case load_traverse(Line, Contexts, Modules, [], ConfigList, no) of + {ok, NewContexts, NewConfigList} -> + load_config(Config, Modules, NewContexts, NewConfigList); + {error, Reason} -> + ?ERROR("load_config -> traverse failed: ~p",[Reason]), + {error, Reason} + end. + + +load_traverse(Line, [], [], NewContexts, ConfigList, no) -> + ?CDEBUG("load_traverse/no -> ~n" + " Line: ~p~n" + " NewContexts: ~p~n" + " ConfigList: ~p", + [Line,NewContexts,ConfigList]), + {error, ?NICE("Configuration directive not recognized: "++Line)}; +load_traverse(Line, [], [], NewContexts, ConfigList, yes) -> + ?CDEBUG("load_traverse/yes -> ~n" + " Line: ~p~n" + " NewContexts: ~p~n" + " ConfigList: ~p", + [Line,NewContexts,ConfigList]), + {ok, lists:reverse(NewContexts), ConfigList}; +load_traverse(Line, [Context|Contexts], [Module|Modules], NewContexts, ConfigList, State) -> + ?CDEBUG("load_traverse/~p -> ~n" + " Line: ~p~n" + " Module: ~p~n" + " Context: ~p~n" + " Contexts: ~p~n" + " NewContexts: ~p", + [State,Line,Module,Context,Contexts,NewContexts]), + case is_exported(Module, {load, 2}) of + true -> + ?CDEBUG("load_traverse -> ~p:load/2 exported",[Module]), + case catch apply(Module, load, [Line, Context]) of + {'EXIT', {function_clause, _}} -> + ?CDEBUG("load_traverse -> exit: function_clause" + "~n Module: ~p" + "~n Line: ~s",[Module,Line]), + load_traverse(Line, Contexts, Modules, [Context|NewContexts], ConfigList, State); + {'EXIT', Reason} -> + ?CDEBUG("load_traverse -> exit: ~p",[Reason]), + error_logger:error_report({'EXIT', Reason}), + load_traverse(Line, Contexts, Modules, [Context|NewContexts], ConfigList, State); + {ok, NewContext} -> + ?CDEBUG("load_traverse -> ~n" + " NewContext: ~p",[NewContext]), + load_traverse(Line, Contexts, Modules, [NewContext|NewContexts], ConfigList,yes); + {ok, NewContext, ConfigEntry} when tuple(ConfigEntry) -> + ?CDEBUG("load_traverse (tuple) -> ~n" + " NewContext: ~p~n" + " ConfigEntry: ~p",[NewContext,ConfigEntry]), + load_traverse(Line, Contexts, Modules, [NewContext|NewContexts], + [ConfigEntry|ConfigList], yes); + {ok, NewContext, ConfigEntry} when list(ConfigEntry) -> + ?CDEBUG("load_traverse (list) -> ~n" + " NewContext: ~p~n" + " ConfigEntry: ~p",[NewContext,ConfigEntry]), + load_traverse(Line, Contexts, Modules, [NewContext|NewContexts], + lists:append(ConfigEntry, ConfigList), yes); + {error, Reason} -> + ?CDEBUG("load_traverse -> error: ~p",[Reason]), + {error, Reason} + end; + false -> + ?CDEBUG("load_traverse -> ~p:load/2 not exported",[Module]), + load_traverse(Line, Contexts, Modules, [Context|NewContexts], + ConfigList,yes) + end. + + +load(eof, []) -> + eof; + +load([$M,$a,$x,$H,$e,$a,$d,$e,$r,$S,$i,$z,$e,$ |MaxHeaderSize], []) -> + ?DEBUG("load -> MaxHeaderSize: ~p",[MaxHeaderSize]), + case make_integer(MaxHeaderSize) of + {ok, Integer} -> + {ok, [], {max_header_size,Integer}}; + {error, _} -> + {error, ?NICE(clean(MaxHeaderSize)++ + " is an invalid number of MaxHeaderSize")} + end; +load([$M,$a,$x,$H,$e,$a,$d,$e,$r,$A,$c,$t,$i,$o,$n,$ |Action], []) -> + ?DEBUG("load -> MaxHeaderAction: ~p",[Action]), + {ok, [], {max_header_action,list_to_atom(clean(Action))}}; +load([$M,$a,$x,$B,$o,$d,$y,$S,$i,$z,$e,$ |MaxBodySize], []) -> + ?DEBUG("load -> MaxBodySize: ~p",[MaxBodySize]), + case make_integer(MaxBodySize) of + {ok, Integer} -> + {ok, [], {max_body_size,Integer}}; + {error, _} -> + {error, ?NICE(clean(MaxBodySize)++ + " is an invalid number of MaxBodySize")} + end; +load([$M,$a,$x,$B,$o,$d,$y,$A,$c,$t,$i,$o,$n,$ |Action], []) -> + ?DEBUG("load -> MaxBodyAction: ~p",[Action]), + {ok, [], {max_body_action,list_to_atom(clean(Action))}}; +load([$S,$e,$r,$v,$e,$r,$N,$a,$m,$e,$ |ServerName], []) -> + ?DEBUG("load -> ServerName: ~p",[ServerName]), + {ok,[],{server_name,clean(ServerName)}}; +load([$S,$o,$c,$k,$e,$t,$T,$y,$p,$e,$ |SocketType], []) -> + ?DEBUG("load -> SocketType: ~p",[SocketType]), + case check_enum(clean(SocketType),["ssl","ip_comm"]) of + {ok, ValidSocketType} -> + {ok, [], {com_type,ValidSocketType}}; + {error,_} -> + {error, ?NICE(clean(SocketType) ++ " is an invalid SocketType")} + end; +load([$P,$o,$r,$t,$ |Port], []) -> + ?DEBUG("load -> Port: ~p",[Port]), + case make_integer(Port) of + {ok, Integer} -> + {ok, [], {port,Integer}}; + {error, _} -> + {error, ?NICE(clean(Port)++" is an invalid Port")} + end; +load([$B,$i,$n,$d,$A,$d,$d,$r,$e,$s,$s,$ |Address], []) -> + ?DEBUG("load -> Address: ~p",[Address]), + case clean(Address) of + "*" -> + {ok, [], {bind_address,any}}; + CAddress -> + ?CDEBUG("load -> CAddress: ~p",[CAddress]), + case inet:getaddr(CAddress,inet) of + {ok, IPAddr} -> + ?CDEBUG("load -> IPAddr: ~p",[IPAddr]), + {ok, [], {bind_address,IPAddr}}; + {error, _} -> + {error, ?NICE(CAddress++" is an invalid address")} + end + end; +load([$K,$e,$e,$p,$A,$l,$i,$v,$e,$ |OnorOff], []) -> + case list_to_atom(clean(OnorOff)) of + off -> + {ok, [], {persistent_conn, false}}; + _ -> + {ok, [], {persistent_conn, true}} + end; +load([$M,$a,$x,$K,$e,$e,$p,$A,$l,$i,$v,$e,$R,$e,$q,$u,$e,$s,$t,$ |MaxRequests], []) -> + case make_integer(MaxRequests) of + {ok, Integer} -> + {ok, [], {max_keep_alive_request, Integer}}; + {error, _} -> + {error, ?NICE(clean(MaxRequests)++" is an invalid MaxKeepAliveRequest")} + end; +load([$K,$e,$e,$p,$A,$l,$i,$v,$e,$T,$i,$m,$e,$o,$u,$t,$ |Timeout], []) -> + case make_integer(Timeout) of + {ok, Integer} -> + {ok, [], {keep_alive_timeout, Integer*1000}}; + {error, _} -> + {error, ?NICE(clean(Timeout)++" is an invalid KeepAliveTimeout")} + end; +load([$M,$o,$d,$u,$l,$e,$s,$ |Modules], []) -> + {ok, ModuleList} = regexp:split(Modules," "), + {ok, [], {modules,[list_to_atom(X) || X <- ModuleList]}}; +load([$S,$e,$r,$v,$e,$r,$A,$d,$m,$i,$n,$ |ServerAdmin], []) -> + {ok, [], {server_admin,clean(ServerAdmin)}}; +load([$S,$e,$r,$v,$e,$r,$R,$o,$o,$t,$ |ServerRoot], []) -> + case is_directory(clean(ServerRoot)) of + {ok, Directory} -> + MimeTypesFile = + filename:join([clean(ServerRoot),"conf", "mime.types"]), + case load_mime_types(MimeTypesFile) of + {ok, MimeTypesList} -> + {ok, [], [{server_root,string:strip(Directory,right,$/)}, + {mime_types,MimeTypesList}]}; + {error, Reason} -> + {error, Reason} + end; + {error, _} -> + {error, ?NICE(clean(ServerRoot)++" is an invalid ServerRoot")} + end; +load([$M,$a,$x,$C,$l,$i,$e,$n,$t,$s,$ |MaxClients], []) -> + ?DEBUG("load -> MaxClients: ~p",[MaxClients]), + case make_integer(MaxClients) of + {ok, Integer} -> + {ok, [], {max_clients,Integer}}; + {error, _} -> + {error, ?NICE(clean(MaxClients)++" is an invalid number of MaxClients")} + end; +load([$D,$o,$c,$u,$m,$e,$n,$t,$R,$o,$o,$t,$ |DocumentRoot],[]) -> + case is_directory(clean(DocumentRoot)) of + {ok, Directory} -> + {ok, [], {document_root,string:strip(Directory,right,$/)}}; + {error, _} -> + {error, ?NICE(clean(DocumentRoot)++"is an invalid DocumentRoot")} + end; +load([$D,$e,$f,$a,$u,$l,$t,$T,$y,$p,$e,$ |DefaultType], []) -> + {ok, [], {default_type,clean(DefaultType)}}; +load([$S,$S,$L,$C,$e,$r,$t,$i,$f,$i,$c,$a,$t,$e,$F,$i,$l,$e,$ | SSLCertificateFile], []) -> + ?DEBUG("load -> SSLCertificateFile: ~p",[SSLCertificateFile]), + case is_file(clean(SSLCertificateFile)) of + {ok, File} -> + {ok, [], {ssl_certificate_file,File}}; + {error, _} -> + {error, ?NICE(clean(SSLCertificateFile)++ + " is an invalid SSLCertificateFile")} + end; +load([$S,$S,$L,$C,$e,$r,$t,$i,$f,$i,$c,$a,$t,$e,$K,$e,$y,$F,$i,$l,$e,$ | + SSLCertificateKeyFile], []) -> + ?DEBUG("load -> SSLCertificateKeyFile: ~p",[SSLCertificateKeyFile]), + case is_file(clean(SSLCertificateKeyFile)) of + {ok, File} -> + {ok, [], {ssl_certificate_key_file,File}}; + {error, _} -> + {error, ?NICE(clean(SSLCertificateKeyFile)++ + " is an invalid SSLCertificateKeyFile")} + end; +load([$S,$S,$L,$V,$e,$r,$i,$f,$y,$C,$l,$i,$e,$n,$t,$ |SSLVerifyClient], []) -> + ?DEBUG("load -> SSLVerifyClient: ~p",[SSLVerifyClient]), + case make_integer(clean(SSLVerifyClient)) of + {ok, Integer} when Integer >=0,Integer =< 2 -> + {ok, [], {ssl_verify_client,Integer}}; + {ok, Integer} -> + {error,?NICE(clean(SSLVerifyClient)++" is an invalid SSLVerifyClient")}; + {error, nomatch} -> + {error,?NICE(clean(SSLVerifyClient)++" is an invalid SSLVerifyClient")} + end; +load([$S,$S,$L,$V,$e,$r,$i,$f,$y,$D,$e,$p,$t,$h,$ | + SSLVerifyDepth], []) -> + ?DEBUG("load -> SSLVerifyDepth: ~p",[SSLVerifyDepth]), + case make_integer(clean(SSLVerifyDepth)) of + {ok, Integer} when Integer > 0 -> + {ok, [], {ssl_verify_client_depth,Integer}}; + {ok, Integer} -> + {error,?NICE(clean(SSLVerifyDepth) ++ + " is an invalid SSLVerifyDepth")}; + {error, nomatch} -> + {error,?NICE(clean(SSLVerifyDepth) ++ + " is an invalid SSLVerifyDepth")} + end; +load([$S,$S,$L,$C,$i,$p,$h,$e,$r,$s,$ | SSLCiphers], []) -> + ?DEBUG("load -> SSLCiphers: ~p",[SSLCiphers]), + {ok, [], {ssl_ciphers, clean(SSLCiphers)}}; +load([$S,$S,$L,$C,$A,$C,$e,$r,$t,$i,$f,$i,$c,$a,$t,$e,$F,$i,$l,$e,$ | + SSLCACertificateFile], []) -> + case is_file(clean(SSLCACertificateFile)) of + {ok, File} -> + {ok, [], {ssl_ca_certificate_file,File}}; + {error, _} -> + {error, ?NICE(clean(SSLCACertificateFile)++ + " is an invalid SSLCACertificateFile")} + end; +load([$S,$S,$L,$P,$a,$s,$s,$w,$o,$r,$d,$C,$a,$l,$l,$b,$a,$c,$k,$M,$o,$d,$u,$l,$e,$ | SSLPasswordCallbackModule], []) -> + ?DEBUG("load -> SSLPasswordCallbackModule: ~p", + [SSLPasswordCallbackModule]), + {ok, [], {ssl_password_callback_module, + list_to_atom(clean(SSLPasswordCallbackModule))}}; +load([$S,$S,$L,$P,$a,$s,$s,$w,$o,$r,$d,$C,$a,$l,$l,$b,$a,$c,$k,$F,$u,$n,$c,$t,$i,$o,$n,$ | SSLPasswordCallbackFunction], []) -> + ?DEBUG("load -> SSLPasswordCallbackFunction: ~p", + [SSLPasswordCallbackFunction]), + {ok, [], {ssl_password_callback_function, + list_to_atom(clean(SSLPasswordCallbackFunction))}}. + + +%% +%% load_mime_types/1 -> {ok, MimeTypes} | {error, Reason} +%% +load_mime_types(MimeTypesFile) -> + case file:open(MimeTypesFile, [read]) of + {ok, Stream} -> + parse_mime_types(Stream, []); + {error, _} -> + {error, ?NICE("Can't open " ++ MimeTypesFile)} + end. + +parse_mime_types(Stream,MimeTypesList) -> + Line= + case io:get_line(Stream,'') of + eof -> + eof; + String -> + clean(String) + end, + parse_mime_types(Stream, MimeTypesList, Line). + +parse_mime_types(Stream, MimeTypesList, eof) -> + file:close(Stream), + {ok, MimeTypesList}; +parse_mime_types(Stream, MimeTypesList, "") -> + parse_mime_types(Stream, MimeTypesList); +parse_mime_types(Stream, MimeTypesList, [$#|_]) -> + parse_mime_types(Stream, MimeTypesList); +parse_mime_types(Stream, MimeTypesList, Line) -> + case regexp:split(Line, " ") of + {ok, [NewMimeType|Suffixes]} -> + parse_mime_types(Stream,lists:append(suffixes(NewMimeType,Suffixes), + MimeTypesList)); + {ok, _} -> + {error, ?NICE(Line)} + end. + +suffixes(MimeType,[]) -> + []; +suffixes(MimeType,[Suffix|Rest]) -> + [{Suffix,MimeType}|suffixes(MimeType,Rest)]. + +%% +%% Phase 2: Store +%% + +%% store + +store(ConfigList) -> + Modules = httpd_util:key1search(ConfigList, modules, []), + Port = httpd_util:key1search(ConfigList, port), + Addr = httpd_util:key1search(ConfigList,bind_address), + Name = httpd_util:make_name("httpd_conf",Addr,Port), + ?CDEBUG("store -> Name = ~p",[Name]), + ConfigDB = ets:new(Name, [named_table, bag, protected]), + ?CDEBUG("store -> ConfigDB = ~p",[ConfigDB]), + store(ConfigDB, ConfigList, lists:append(Modules,[?MODULE]),ConfigList). + +store(ConfigDB, ConfigList, Modules,[]) -> + ?vtrace("store -> done",[]), + ?CDEBUG("store -> done",[]), + {ok, ConfigDB}; +store(ConfigDB, ConfigList, Modules, [ConfigListEntry|Rest]) -> + ?vtrace("store -> entry with" + "~n ConfigListEntry: ~p",[ConfigListEntry]), + ?CDEBUG("store -> " + "~n ConfigListEntry: ~p",[ConfigListEntry]), + case store_traverse(ConfigListEntry,ConfigList,Modules) of + {ok, ConfigDBEntry} when tuple(ConfigDBEntry) -> + ?vtrace("store -> ConfigDBEntry(tuple): " + "~n ~p",[ConfigDBEntry]), + ?CDEBUG("store -> ConfigDBEntry(tuple): " + "~n ~p",[ConfigDBEntry]), + ets:insert(ConfigDB,ConfigDBEntry), + store(ConfigDB,ConfigList,Modules,Rest); + {ok, ConfigDBEntry} when list(ConfigDBEntry) -> + ?vtrace("store -> ConfigDBEntry(list): " + "~n ~p",[ConfigDBEntry]), + ?CDEBUG("store -> ConfigDBEntry(list): " + "~n ~p",[ConfigDBEntry]), + lists:foreach(fun(Entry) -> + ets:insert(ConfigDB,Entry) + end,ConfigDBEntry), + store(ConfigDB,ConfigList,Modules,Rest); + {error, Reason} -> + ?vlog("store -> error: ~p",[Reason]), + ?ERROR("store -> error: ~p",[Reason]), + {error,Reason} + end. + +store_traverse(ConfigListEntry,ConfigList,[]) -> + {error,?NICE("Unable to store configuration...")}; +store_traverse(ConfigListEntry, ConfigList, [Module|Rest]) -> + case is_exported(Module, {store, 2}) of + true -> + ?CDEBUG("store_traverse -> call ~p:store/2",[Module]), + case catch apply(Module,store,[ConfigListEntry, ConfigList]) of + {'EXIT',{function_clause,_}} -> + ?CDEBUG("store_traverse -> exit: function_clause",[]), + store_traverse(ConfigListEntry,ConfigList,Rest); + {'EXIT',Reason} -> + ?ERROR("store_traverse -> exit: ~p",[Reason]), + error_logger:error_report({'EXIT',Reason}), + store_traverse(ConfigListEntry,ConfigList,Rest); + Result -> + ?CDEBUG("store_traverse -> ~n" + " Result: ~p",[Result]), + Result + end; + false -> + store_traverse(ConfigListEntry,ConfigList,Rest) + end. + +store({mime_types,MimeTypesList},ConfigList) -> + Port = httpd_util:key1search(ConfigList, port), + Addr = httpd_util:key1search(ConfigList, bind_address), + Name = httpd_util:make_name("httpd_mime",Addr,Port), + ?CDEBUG("store(mime_types) -> Name: ~p",[Name]), + {ok, MimeTypesDB} = store_mime_types(Name,MimeTypesList), + ?CDEBUG("store(mime_types) -> ~n" + " MimeTypesDB: ~p~n" + " MimeTypesDB info: ~p", + [MimeTypesDB,ets:info(MimeTypesDB)]), + {ok, {mime_types,MimeTypesDB}}; +store(ConfigListEntry,ConfigList) -> + ?CDEBUG("store/2 -> ~n" + " ConfigListEntry: ~p~n" + " ConfigList: ~p", + [ConfigListEntry,ConfigList]), + {ok, ConfigListEntry}. + + +%% store_mime_types +store_mime_types(Name,MimeTypesList) -> + ?CDEBUG("store_mime_types -> Name: ~p",[Name]), + MimeTypesDB = ets:new(Name, [set, protected]), + ?CDEBUG("store_mime_types -> MimeTypesDB: ~p",[MimeTypesDB]), + store_mime_types1(MimeTypesDB, MimeTypesList). + +store_mime_types1(MimeTypesDB,[]) -> + {ok, MimeTypesDB}; +store_mime_types1(MimeTypesDB,[Type|Rest]) -> + ?CDEBUG("store_mime_types1 -> Type: ~p",[Type]), + ets:insert(MimeTypesDB, Type), + store_mime_types1(MimeTypesDB, Rest). + + +%% +%% Phase 3: Remove +%% + +remove_all(ConfigDB) -> + Modules = httpd_util:lookup(ConfigDB,modules,[]), + remove_traverse(ConfigDB, lists:append(Modules,[?MODULE])). + +remove_traverse(ConfigDB,[]) -> + ?vtrace("remove_traverse -> done", []), + ok; +remove_traverse(ConfigDB,[Module|Rest]) -> + ?vtrace("remove_traverse -> call ~p:remove", [Module]), + case (catch apply(Module,remove,[ConfigDB])) of + {'EXIT',{undef,_}} -> + ?vtrace("remove_traverse -> undef", []), + remove_traverse(ConfigDB,Rest); + {'EXIT',{function_clause,_}} -> + ?vtrace("remove_traverse -> function_clause", []), + remove_traverse(ConfigDB,Rest); + {'EXIT',Reason} -> + ?vtrace("remove_traverse -> exit: ~p", [Reason]), + error_logger:error_report({'EXIT',Reason}), + remove_traverse(ConfigDB,Rest); + {error,Reason} -> + ?vtrace("remove_traverse -> error: ~p", [Reason]), + error_logger:error_report(Reason), + remove_traverse(ConfigDB,Rest); + _ -> + remove_traverse(ConfigDB,Rest) + end. + +remove(ConfigDB) -> + ets:delete(ConfigDB), + ok. + + +%% +%% Utility functions +%% + +%% is_directory + +is_directory(Directory) -> + case file:read_file_info(Directory) of + {ok,FileInfo} -> + #file_info{type = Type, access = Access} = FileInfo, + is_directory(Type,Access,FileInfo,Directory); + {error,Reason} -> + {error,Reason} + end. + +is_directory(directory,read,_FileInfo,Directory) -> + {ok,Directory}; +is_directory(directory,read_write,_FileInfo,Directory) -> + {ok,Directory}; +is_directory(_Type,_Access,FileInfo,_Directory) -> + {error,FileInfo}. + + +%% is_file + +is_file(File) -> + case file:read_file_info(File) of + {ok,FileInfo} -> + #file_info{type = Type, access = Access} = FileInfo, + is_file(Type,Access,FileInfo,File); + {error,Reason} -> + {error,Reason} + end. + +is_file(regular,read,_FileInfo,File) -> + {ok,File}; +is_file(regular,read_write,_FileInfo,File) -> + {ok,File}; +is_file(_Type,_Access,FileInfo,_File) -> + {error,FileInfo}. + +%% make_integer + +make_integer(String) -> + case regexp:match(clean(String),"[0-9]+") of + {match, _, _} -> + {ok, list_to_integer(clean(String))}; + nomatch -> + {error, nomatch} + end. + + +%% clean + +clean(String) -> + {ok,CleanedString,_} = regexp:gsub(String, "^[ \t\n\r\f]*|[ \t\n\r\f]*\$",""), + CleanedString. + +%% custom_clean + +custom_clean(String,MoreBefore,MoreAfter) -> + {ok,CleanedString,_}=regexp:gsub(String,"^[ \t\n\r\f"++MoreBefore++ + "]*|[ \t\n\r\f"++MoreAfter++"]*\$",""), + CleanedString. + +%% check_enum + +check_enum(Enum,[]) -> + {error, not_valid}; +check_enum(Enum,[Enum|Rest]) -> + {ok, list_to_atom(Enum)}; +check_enum(Enum, [NotValid|Rest]) -> + check_enum(Enum, Rest). + +%% a_must + +a_must(ConfigList,[]) -> + ok; +a_must(ConfigList,[Directive|Rest]) -> + case httpd_util:key1search(ConfigList,Directive) of + undefined -> + {missing,Directive}; + _ -> + a_must(ConfigList,Rest) + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_example.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_example.erl new file mode 100644 index 0000000000..4aec440db3 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_example.erl @@ -0,0 +1,134 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_example.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(httpd_example). +-export([print/1]). +-export([get/2, post/2, yahoo/2, test1/2]). + +-export([newformat/3]). +%% These are used by the inets test-suite +-export([delay/1]). + + +print(String) -> + [header(), + top("Print"), + String++"\n", + footer()]. + + +test1(Env, []) -> + io:format("Env:~p~n",[Env]), + ["<html>", + "<head>", + "<title>Test1</title>", + "</head>", + "<body>", + "<h1>Erlang Body</h1>", + "<h2>Stuff</h2>", + "</body>", + "</html>"]. + + +get(Env,[]) -> + [header(), + top("GET Example"), + "<FORM ACTION=\"/cgi-bin/erl/httpd_example:get\" METHOD=GET> +<B>Input:</B> <INPUT TYPE=\"text\" NAME=\"input1\"> +<INPUT TYPE=\"text\" NAME=\"input2\"> +<INPUT TYPE=\"submit\"><BR> +</FORM>" ++ "\n", + footer()]; + +get(Env,Input) -> + default(Env,Input). + +post(Env,[]) -> + [header(), + top("POST Example"), + "<FORM ACTION=\"/cgi-bin/erl/httpd_example:post\" METHOD=POST> +<B>Input:</B> <INPUT TYPE=\"text\" NAME=\"input1\"> +<INPUT TYPE=\"text\" NAME=\"input2\"> +<INPUT TYPE=\"submit\"><BR> +</FORM>" ++ "\n", + footer()]; + +post(Env,Input) -> + default(Env,Input). + +yahoo(Env,Input) -> + "Location: http://www.yahoo.com\r\n\r\n". + +default(Env,Input) -> + [header(), + top("Default Example"), + "<B>Environment:</B> ",io_lib:format("~p",[Env]),"<BR>\n", + "<B>Input:</B> ",Input,"<BR>\n", + "<B>Parsed Input:</B> ", + io_lib:format("~p",[httpd:parse_query(Input)]),"\n", + footer()]. + +header() -> + header("text/html"). +header(MimeType) -> + "Content-type: " ++ MimeType ++ "\r\n\r\n". + +top(Title) -> + "<HTML> +<HEAD> +<TITLE>" ++ Title ++ "</TITLE> +</HEAD> +<BODY>\n". + +footer() -> + "</BODY> +</HTML>\n". + + +newformat(SessionID,Env,Input)-> + mod_esi:deliver(SessionID,"Content-Type:text/html\r\n\r\n"), + mod_esi:deliver(SessionID,top("new esi format test")), + mod_esi:deliver(SessionID,"This new format is nice<BR>"), + mod_esi:deliver(SessionID,"This new format is nice<BR>"), + mod_esi:deliver(SessionID,"This new format is nice<BR>"), + mod_esi:deliver(SessionID,footer()). + +%% ------------------------------------------------------ + +delay(Time) when integer(Time) -> + i("httpd_example:delay(~p) -> do the delay",[Time]), + sleep(Time), + i("httpd_example:delay(~p) -> done, now reply",[Time]), + delay_reply("delay ok"); +delay(Time) when list(Time) -> + delay(httpd_conf:make_integer(Time)); +delay({ok,Time}) when integer(Time) -> + delay(Time); +delay({error,_Reason}) -> + i("delay -> called with invalid time"), + delay_reply("delay failed: invalid delay time"). + +delay_reply(Reply) -> + [header(), + top("delay"), + Reply, + footer()]. + +i(F) -> i(F,[]). +i(F,A) -> io:format(F ++ "~n",A). + +sleep(T) -> receive after T -> ok end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_manager.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_manager.erl new file mode 100644 index 0000000000..704cb1f319 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_manager.erl @@ -0,0 +1,1029 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_manager.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% + +-module(httpd_manager). + +-include("httpd.hrl"). +-include("httpd_verbosity.hrl"). + +-behaviour(gen_server). + +%% External API +-export([start/2, start/3, start_link/2, start_link/3, stop/1, restart/1]). + +%% Internal API +-export([new_connection/1, done_connection/1]). + +%% Module API +-export([config_lookup/2, config_lookup/3, + config_multi_lookup/2, config_multi_lookup/3, + config_match/2, config_match/3]). + +%% gen_server exports +-export([init/1, + handle_call/3, handle_cast/2, handle_info/2, + terminate/2, + code_change/3]). + + +%% Management exports +-export([block/2, block/3, unblock/1]). +-export([get_admin_state/1, get_usage_state/1]). +-export([is_busy/1,is_busy/2,is_busy_or_blocked/1,is_blocked/1]). %% ??????? +-export([get_status/1, get_status/2]). +-export([verbosity/2, verbosity/3]). + + +-export([c/1]). + +-record(state,{socket_type = ip_comm, + config_file, + config_db = null, + connections, %% Current request handlers + admin_state = unblocked, + blocker_ref = undefined, + blocking_tmr = undefined, + status = []}). + + +c(Port) -> + Ref = httpd_util:make_name("httpd",undefined,Port), + gen_server:call(Ref, fake_close). + + +%% +%% External API +%% + +start(ConfigFile, ConfigList) -> + start(ConfigFile, ConfigList, []). + +start(ConfigFile, ConfigList, Verbosity) -> + Port = httpd_util:key1search(ConfigList,port,80), + Addr = httpd_util:key1search(ConfigList,bind_address), + Name = make_name(Addr,Port), + ?LOG("start -> Name = ~p",[Name]), + gen_server:start({local,Name},?MODULE, + [ConfigFile, ConfigList, Addr, Port, Verbosity],[]). + +start_link(ConfigFile, ConfigList) -> + start_link(ConfigFile, ConfigList, []). + +start_link(ConfigFile, ConfigList, Verbosity) -> + Port = httpd_util:key1search(ConfigList,port,80), + Addr = httpd_util:key1search(ConfigList,bind_address), + Name = make_name(Addr,Port), + ?LOG("start_link -> Name = ~p",[Name]), + gen_server:start_link({local, Name},?MODULE, + [ConfigFile, ConfigList, Addr, Port, Verbosity],[]). + +%% stop + +stop(ServerRef) -> + gen_server:call(ServerRef, stop). + +%% restart + +restart(ServerRef) -> + gen_server:call(ServerRef, restart). + + +%%%---------------------------------------------------------------- + +block(ServerRef, disturbing) -> + call(ServerRef,block); + +block(ServerRef, non_disturbing) -> + do_block(ServerRef, non_disturbing, infinity). + +block(ServerRef, Method, Timeout) -> + do_block(ServerRef, Method, Timeout). + + +%% The reason for not using call here, is that the manager cannot +%% _wait_ for completion of the requests. It must be able to do +%% do other things at the same time as the blocking goes on. +do_block(ServerRef, Method, infinity) -> + Ref = make_ref(), + cast(ServerRef, {block, Method, infinity, self(), Ref}), + receive + {block_reply, Reply, Ref} -> + Reply + end; +do_block(ServerRef,Method,Timeout) when Timeout > 0 -> + Ref = make_ref(), + cast(ServerRef,{block,Method,Timeout,self(),Ref}), + receive + {block_reply,Reply,Ref} -> + Reply + end. + + +%%%---------------------------------------------------------------- + +%% unblock + +unblock(ServerRef) -> + call(ServerRef,unblock). + +%% get admin/usage state + +get_admin_state(ServerRef) -> + call(ServerRef,get_admin_state). + +get_usage_state(ServerRef) -> + call(ServerRef,get_usage_state). + + +%% get_status + +get_status(ServerRef) -> + gen_server:call(ServerRef,get_status). + +get_status(ServerRef,Timeout) -> + gen_server:call(ServerRef,get_status,Timeout). + + +verbosity(ServerRef,Verbosity) -> + verbosity(ServerRef,all,Verbosity). + +verbosity(ServerRef,all,Verbosity) -> + gen_server:call(ServerRef,{verbosity,all,Verbosity}); +verbosity(ServerRef,manager,Verbosity) -> + gen_server:call(ServerRef,{verbosity,manager,Verbosity}); +verbosity(ServerRef,request,Verbosity) -> + gen_server:call(ServerRef,{verbosity,request,Verbosity}); +verbosity(ServerRef,acceptor,Verbosity) -> + gen_server:call(ServerRef,{verbosity,acceptor,Verbosity}); +verbosity(ServerRef,security,Verbosity) -> + gen_server:call(ServerRef,{verbosity,security,Verbosity}); +verbosity(ServerRef,auth,Verbosity) -> + gen_server:call(ServerRef,{verbosity,auth,Verbosity}). + +%% +%% Internal API +%% + + +%% new_connection + +new_connection(Manager) -> + gen_server:call(Manager, {new_connection, self()}). + +%% done + +done_connection(Manager) -> + gen_server:cast(Manager, {done_connection, self()}). + + +%% is_busy(ServerRef) -> true | false +%% +%% Tests if the server is (in usage state) busy, +%% i.e. has rached the heavy load limit. +%% + +is_busy(ServerRef) -> + gen_server:call(ServerRef,is_busy). + +is_busy(ServerRef,Timeout) -> + gen_server:call(ServerRef,is_busy,Timeout). + + +%% is_busy_or_blocked(ServerRef) -> busy | blocked | false +%% +%% Tests if the server is busy (usage state), i.e. has rached, +%% the heavy load limit, or blocked (admin state) . +%% + +is_busy_or_blocked(ServerRef) -> + gen_server:call(ServerRef,is_busy_or_blocked). + + +%% is_blocked(ServerRef) -> true | false +%% +%% Tests if the server is blocked (admin state) . +%% + +is_blocked(ServerRef) -> + gen_server:call(ServerRef,is_blocked). + + +%% +%% Module API. Theese functions are intended for use from modules only. +%% + +config_lookup(Port, Query) -> + config_lookup(undefined, Port, Query). +config_lookup(Addr, Port, Query) -> + Name = httpd_util:make_name("httpd",Addr,Port), + gen_server:call(whereis(Name), {config_lookup, Query}). + +config_multi_lookup(Port, Query) -> + config_multi_lookup(undefined,Port,Query). +config_multi_lookup(Addr,Port, Query) -> + Name = httpd_util:make_name("httpd",Addr,Port), + gen_server:call(whereis(Name), {config_multi_lookup, Query}). + +config_match(Port, Pattern) -> + config_match(undefined,Port,Pattern). +config_match(Addr, Port, Pattern) -> + Name = httpd_util:make_name("httpd",Addr,Port), + gen_server:call(whereis(Name), {config_match, Pattern}). + + +%% +%% Server call-back functions +%% + +%% init + +init([ConfigFile, ConfigList, Addr, Port, Verbosity]) -> + process_flag(trap_exit, true), + case (catch do_init(ConfigFile, ConfigList, Addr, Port, Verbosity)) of + {error, Reason} -> + ?vlog("failed starting server: ~p", [Reason]), + {stop, Reason}; + {ok, State} -> + {ok, State} + end. + + +do_init(ConfigFile, ConfigList, Addr, Port, Verbosity) -> + put(sname,man), + set_verbosity(Verbosity), + ?vlog("starting",[]), + ConfigDB = do_initial_store(ConfigList), + ?vtrace("config db: ~p", [ConfigDB]), + SocketType = httpd_socket:config(ConfigDB), + ?vtrace("socket type: ~p, now start acceptor", [SocketType]), + case httpd_acceptor_sup:start_acceptor(SocketType, Addr, Port, ConfigDB) of + {ok, Pid} -> + ?vtrace("acceptor started: ~p", [Pid]), + Status = [{max_conn,0}, {last_heavy_load,never}, + {last_connection,never}], + State = #state{socket_type = SocketType, + config_file = ConfigFile, + config_db = ConfigDB, + connections = [], + status = Status}, + ?vdebug("started",[]), + {ok, State}; + Else -> + Else + end. + + +do_initial_store(ConfigList) -> + case httpd_conf:store(ConfigList) of + {ok, ConfigDB} -> + ConfigDB; + {error, Reason} -> + ?vinfo("failed storing configuration: ~p",[Reason]), + throw({error, Reason}) + end. + + + +%% handle_call + +handle_call(stop, _From, State) -> + ?vlog("stop",[]), + {stop, normal, ok, State}; + +handle_call({config_lookup, Query}, _From, State) -> + ?vlog("config lookup: Query = ~p",[Query]), + Res = httpd_util:lookup(State#state.config_db, Query), + ?vdebug("config lookup result: ~p",[Res]), + {reply, Res, State}; + +handle_call({config_multi_lookup, Query}, _From, State) -> + ?vlog("multi config lookup: Query = ~p",[Query]), + Res = httpd_util:multi_lookup(State#state.config_db, Query), + ?vdebug("multi config lookup result: ~p",[Res]), + {reply, Res, State}; + +handle_call({config_match, Query}, _From, State) -> + ?vlog("config match: Query = ~p",[Query]), + Res = ets:match_object(State#state.config_db, Query), + ?vdebug("config match result: ~p",[Res]), + {reply, Res, State}; + +handle_call(get_status, _From, State) -> + ?vdebug("get status",[]), + ManagerStatus = manager_status(self()), + %% AuthStatus = auth_status(get(auth_server)), + %% SecStatus = sec_status(get(sec_server)), + %% AccStatus = sec_status(get(acceptor_server)), + S1 = [{current_conn,length(State#state.connections)}|State#state.status]++ + [ManagerStatus], + ?vtrace("status = ~p",[S1]), + {reply,S1,State}; + +handle_call(is_busy, From, State) -> + Reply = case get_ustate(State) of + busy -> + true; + _ -> + false + end, + ?vlog("is busy: ~p",[Reply]), + {reply,Reply,State}; + +handle_call(is_busy_or_blocked, From, State) -> + Reply = + case get_astate(State) of + unblocked -> + case get_ustate(State) of + busy -> + busy; + _ -> + false + end; + _ -> + blocked + end, + ?vlog("is busy or blocked: ~p",[Reply]), + {reply,Reply,State}; + +handle_call(is_blocked, From, State) -> + Reply = + case get_astate(State) of + unblocked -> + false; + _ -> + true + end, + ?vlog("is blocked: ~p",[Reply]), + {reply,Reply,State}; + +handle_call(get_admin_state, From, State) -> + Reply = get_astate(State), + ?vlog("admin state: ~p",[Reply]), + {reply,Reply,State}; + +handle_call(get_usage_state, From, State) -> + Reply = get_ustate(State), + ?vlog("usage state: ~p",[Reply]), + {reply,Reply,State}; + +handle_call({verbosity,Who,Verbosity}, From, State) -> + V = ?vvalidate(Verbosity), + ?vlog("~n Set new verbosity to ~p for ~p",[V,Who]), + Reply = set_verbosity(Who,V,State), + {reply,Reply,State}; + +handle_call(restart, From, State) when State#state.admin_state == blocked -> + ?vlog("restart",[]), + case handle_restart(State) of + {stop, Reply,S1} -> + {stop, Reply, S1}; + {_, Reply, S1} -> + {reply,Reply,S1} + end; + +handle_call(restart, From, State) -> + ?vlog("restart(~p)",[State#state.admin_state]), + {reply,{error,{invalid_admin_state,State#state.admin_state}},State}; + +handle_call(block, From, State) -> + ?vlog("block(disturbing)",[]), + {Reply,S1} = handle_block(State), + {reply,Reply,S1}; + +handle_call(unblock, {From,_Tag}, State) -> + ?vlog("unblock",[]), + {Reply,S1} = handle_unblock(State,From), + {reply, Reply, S1}; + +handle_call({new_connection, Pid}, From, State) -> + ?vlog("~n New connection (~p) when connection count = ~p", + [Pid,length(State#state.connections)]), + {S, S1} = handle_new_connection(State, Pid), + Reply = {S, get(request_handler_verbosity)}, + {reply, Reply, S1}; + +handle_call(Request, From, State) -> + ?vinfo("~n unknown request '~p' from ~p", [Request,From]), + String = + lists:flatten( + io_lib:format("Unknown request " + "~n ~p" + "~nto manager (~p)" + "~nfrom ~p", + [Request, self(), From])), + report_error(State,String), + {reply, ok, State}. + + +%% handle_cast + +handle_cast({done_connection, Pid}, State) -> + ?vlog("~n Done connection (~p)", [Pid]), + S1 = handle_done_connection(State, Pid), + {noreply, S1}; + +handle_cast({block, disturbing, Timeout, From, Ref}, State) -> + ?vlog("block(disturbing,~p)",[Timeout]), + S1 = handle_block(State, Timeout, From, Ref), + {noreply,S1}; + +handle_cast({block, non_disturbing, Timeout, From, Ref}, State) -> + ?vlog("block(non-disturbing,~p)",[Timeout]), + S1 = handle_nd_block(State, Timeout, From, Ref), + {noreply,S1}; + +handle_cast(Message, State) -> + ?vinfo("~n received unknown message '~p'",[Message]), + String = + lists:flatten( + io_lib:format("Unknown message " + "~n ~p" + "~nto manager (~p)", + [Message, self()])), + report_error(State, String), + {noreply, State}. + +%% handle_info + +handle_info({block_timeout, Method}, State) -> + ?vlog("received block_timeout event",[]), + S1 = handle_block_timeout(State,Method), + {noreply, S1}; + +handle_info({'DOWN', Ref, process, _Object, Info}, State) -> + ?vlog("~n down message for ~p",[Ref]), + S1 = + case State#state.blocker_ref of + Ref -> + handle_blocker_exit(State); + _ -> + %% Not our blocker, so ignore + State + end, + {noreply, S1}; + +handle_info({'EXIT', Pid, normal}, State) -> + ?vdebug("~n Normal exit message from ~p", [Pid]), + {noreply, State}; + +handle_info({'EXIT', Pid, blocked}, S) -> + ?vdebug("blocked exit signal from request handler (~p)", [Pid]), + {noreply, S}; + +handle_info({'EXIT', Pid, Reason}, State) -> + ?vlog("~n Exit message from ~p for reason ~p",[Pid, Reason]), + S1 = check_connections(State, Pid, Reason), + {noreply, S1}; + +handle_info(Info, State) -> + ?vinfo("~n received unknown info '~p'",[Info]), + String = + lists:flatten( + io_lib:format("Unknown info " + "~n ~p" + "~nto manager (~p)", + [Info, self()])), + report_error(State, String), + {noreply, State}. + + +%% terminate + +terminate(R, #state{config_db = Db}) -> + ?vlog("Terminating for reason: ~n ~p", [R]), + httpd_conf:remove_all(Db), + ok. + + +%% code_change({down,ToVsn}, State, Extra) +%% +%% NOTE: +%% Actually upgrade from 2.5.1 to 2.5.3 and downgrade from +%% 2.5.3 to 2.5.1 is done with an application restart, so +%% these function is actually never used. The reason for keeping +%% this stuff is only for future use. +%% +code_change({down,ToVsn},State,Extra) -> + {ok,State}; + +%% code_change(FromVsn, State, Extra) +%% +code_change(FromVsn,State,Extra) -> + {ok,State}. + + + +%% ------------------------------------------------------------------------- +%% check_connection +%% +%% +%% +%% + +check_connections(#state{connections = []} = State, _Pid, _Reason) -> + State; +check_connections(#state{admin_state = shutting_down, + connections = Connections} = State, Pid, Reason) -> + %% Could be a crashing request handler + case lists:delete(Pid, Connections) of + [] -> % Crashing request handler => block complete + String = + lists:flatten( + io_lib:format("request handler (~p) crashed:" + "~n ~p", [Pid, Reason])), + report_error(State, String), + ?vlog("block complete",[]), + demonitor_blocker(State#state.blocker_ref), + {Tmr,From,Ref} = State#state.blocking_tmr, + ?vlog("(possibly) stop block timer",[]), + stop_block_tmr(Tmr), + ?vlog("and send the reply",[]), + From ! {block_reply,ok,Ref}, + State#state{admin_state = blocked, connections = [], + blocker_ref = undefined}; + Connections1 -> + State#state{connections = Connections1} + end; +check_connections(#state{connections = Connections} = State, Pid, Reason) -> + case lists:delete(Pid, Connections) of + Connections -> % Not a request handler, so ignore + State; + Connections1 -> + String = + lists:flatten( + io_lib:format("request handler (~p) crashed:" + "~n ~p", [Pid, Reason])), + report_error(State, String), + State#state{connections = lists:delete(Pid, Connections)} + end. + + +%% ------------------------------------------------------------------------- +%% handle_[new | done]_connection +%% +%% +%% +%% + +handle_new_connection(State, Handler) -> + UsageState = get_ustate(State), + AdminState = get_astate(State), + handle_new_connection(UsageState, AdminState, State, Handler). + +handle_new_connection(busy, unblocked, State, Handler) -> + Status = update_heavy_load_status(State#state.status), + {{reject, busy}, + State#state{status = Status}}; + +handle_new_connection(_UsageState, unblocked, State, Handler) -> + Connections = State#state.connections, + Status = update_connection_status(State#state.status, + length(Connections)+1), + link(Handler), + {accept, + State#state{connections = [Handler|Connections], status = Status}}; + +handle_new_connection(_UsageState, _AdminState, State, _Handler) -> + {{reject, blocked}, + State}. + + +handle_done_connection(#state{admin_state = shutting_down, + connections = Connections} = State, Handler) -> + unlink(Handler), + case lists:delete(Handler, Connections) of + [] -> % Ok, block complete + ?vlog("block complete",[]), + demonitor_blocker(State#state.blocker_ref), + {Tmr,From,Ref} = State#state.blocking_tmr, + ?vlog("(possibly) stop block timer",[]), + stop_block_tmr(Tmr), + ?vlog("and send the reply",[]), + From ! {block_reply,ok,Ref}, + State#state{admin_state = blocked, connections = [], + blocker_ref = undefined}; + Connections1 -> + State#state{connections = Connections1} + end; + +handle_done_connection(#state{connections = Connections} = State, Handler) -> + State#state{connections = lists:delete(Handler, Connections)}. + + +%% ------------------------------------------------------------------------- +%% handle_block +%% +%% +%% +%% +handle_block(#state{admin_state = AdminState} = S) -> + handle_block(S, AdminState). + +handle_block(S,unblocked) -> + %% Kill all connections + ?vtrace("handle_block(unblocked) -> kill all request handlers",[]), +%% [exit(Pid,blocked) || Pid <- S#state.connections], + [kill_handler(Pid) || Pid <- S#state.connections], + {ok,S#state{connections = [], admin_state = blocked}}; +handle_block(S,blocked) -> + ?vtrace("handle_block(blocked) -> already blocked",[]), + {ok,S}; +handle_block(S,shutting_down) -> + ?vtrace("handle_block(shutting_down) -> ongoing...",[]), + {{error,shutting_down},S}. + + +kill_handler(Pid) -> + ?vtrace("kill request handler: ~p",[Pid]), + exit(Pid, blocked). +%% exit(Pid, kill). + +handle_block(S,Timeout,From,Ref) when Timeout >= 0 -> + do_block(S,Timeout,From,Ref); + +handle_block(S,Timeout,From,Ref) -> + Reply = {error,{invalid_block_request,Timeout}}, + From ! {block_reply,Reply,Ref}, + S. + +do_block(S,Timeout,From,Ref) -> + case S#state.connections of + [] -> + %% Already in idle usage state => go directly to blocked + ?vdebug("do_block -> already in idle usage state",[]), + From ! {block_reply,ok,Ref}, + S#state{admin_state = blocked}; + _ -> + %% Active or Busy usage state => go to shutting_down + ?vdebug("do_block -> active or busy usage state",[]), + %% Make sure we get to know if blocker dies... + ?vtrace("do_block -> create blocker monitor",[]), + MonitorRef = monitor_blocker(From), + ?vtrace("do_block -> (possibly) start block timer",[]), + Tmr = {start_block_tmr(Timeout,disturbing),From,Ref}, + S#state{admin_state = shutting_down, + blocker_ref = MonitorRef, blocking_tmr = Tmr} + end. + +handle_nd_block(S,infinity,From,Ref) -> + do_nd_block(S,infinity,From,Ref); + +handle_nd_block(S,Timeout,From,Ref) when Timeout >= 0 -> + do_nd_block(S,Timeout,From,Ref); + +handle_nd_block(S,Timeout,From,Ref) -> + Reply = {error,{invalid_block_request,Timeout}}, + From ! {block_reply,Reply,Ref}, + S. + +do_nd_block(S,Timeout,From,Ref) -> + case S#state.connections of + [] -> + %% Already in idle usage state => go directly to blocked + ?vdebug("do_nd_block -> already in idle usage state",[]), + From ! {block_reply,ok,Ref}, + S#state{admin_state = blocked}; + _ -> + %% Active or Busy usage state => go to shutting_down + ?vdebug("do_nd_block -> active or busy usage state",[]), + %% Make sure we get to know if blocker dies... + ?vtrace("do_nd_block -> create blocker monitor",[]), + MonitorRef = monitor_blocker(From), + ?vtrace("do_nd_block -> (possibly) start block timer",[]), + Tmr = {start_block_tmr(Timeout,non_disturbing),From,Ref}, + S#state{admin_state = shutting_down, + blocker_ref = MonitorRef, blocking_tmr = Tmr} + end. + +handle_block_timeout(S,Method) -> + %% Time to take this to the road... + demonitor_blocker(S#state.blocker_ref), + handle_block_timeout1(S,Method,S#state.blocking_tmr). + +handle_block_timeout1(S,non_disturbing,{_,From,Ref}) -> + ?vdebug("handle_block_timeout1(non-disturbing) -> send reply: timeout",[]), + From ! {block_reply,{error,timeout},Ref}, + S#state{admin_state = unblocked, + blocker_ref = undefined, blocking_tmr = undefined}; + +handle_block_timeout1(S,disturbing,{_,From,Ref}) -> + ?vdebug("handle_block_timeout1(disturbing) -> kill all connections",[]), + [exit(Pid,blocked) || Pid <- S#state.connections], + + ?vdebug("handle_block_timeout1 -> send reply: ok",[]), + From ! {block_reply,ok,Ref}, + S#state{admin_state = blocked, connections = [], + blocker_ref = undefined, blocking_tmr = undefined}; + +handle_block_timeout1(S,Method,{_,From,Ref}) -> + ?vinfo("received block timeout with unknown block method:" + "~n Method: ~p",[Method]), + From ! {block_reply,{error,{unknown_block_method,Method}},Ref}, + S#state{admin_state = blocked, connections = [], + blocker_ref = undefined, blocking_tmr = undefined}; + +handle_block_timeout1(S,Method,TmrInfo) -> + ?vinfo("received block timeout with erroneous timer info:" + "~n Method: ~p" + "~n TmrInfo: ~p",[Method,TmrInfo]), + S#state{admin_state = unblocked, + blocker_ref = undefined, blocking_tmr = undefined}. + +handle_unblock(S,FromA) -> + handle_unblock(S,FromA,S#state.admin_state). + +handle_unblock(S,_FromA,unblocked) -> + {ok,S}; +handle_unblock(S,FromA,_AdminState) -> + ?vtrace("handle_unblock -> (possibly) stop block timer",[]), + stop_block_tmr(S#state.blocking_tmr), + case S#state.blocking_tmr of + {Tmr,FromB,Ref} -> + %% Another process is trying to unblock + %% Inform the blocker + FromB ! {block_reply, {error,{unblocked,FromA}},Ref}; + _ -> + ok + end, + {ok,S#state{admin_state = unblocked, blocking_tmr = undefined}}. + +%% The blocker died so we give up on the block. +handle_blocker_exit(S) -> + {Tmr,_From,_Ref} = S#state.blocking_tmr, + ?vtrace("handle_blocker_exit -> (possibly) stop block timer",[]), + stop_block_tmr(Tmr), + S#state{admin_state = unblocked, + blocker_ref = undefined, blocking_tmr = undefined}. + + + +%% ------------------------------------------------------------------------- +%% handle_restart +%% +%% +%% +%% +handle_restart(#state{config_file = undefined} = State) -> + {continue, {error, undefined_config_file}, State}; +handle_restart(#state{config_db = Db, config_file = ConfigFile} = State) -> + ?vtrace("load new configuration",[]), + {ok, Config} = httpd_conf:load(ConfigFile), + ?vtrace("check for illegal changes (addr, port and socket-type)",[]), + case (catch check_constant_values(Db, Config)) of + ok -> + %% If something goes wrong between the remove + %% and the store where fu-ed + ?vtrace("remove old configuration, now hold you breath...",[]), + httpd_conf:remove_all(Db), + ?vtrace("store new configuration",[]), + case httpd_conf:store(Config) of + {ok, NewConfigDB} -> + ?vlog("restart done, puh!",[]), + {continue, ok, State#state{config_db = NewConfigDB}}; + Error -> + ?vlog("failed store new config: ~n ~p",[Error]), + {stop, Error, State} + end; + Error -> + ?vlog("restart NOT performed due to:" + "~n ~p",[Error]), + {continue, Error, State} + end. + + +check_constant_values(Db, Config) -> + %% Check port number + ?vtrace("check_constant_values -> check port number",[]), + Port = httpd_util:lookup(Db,port), + case httpd_util:key1search(Config,port) of %% MUST be equal + Port -> + ok; + OtherPort -> + throw({error,{port_number_changed,Port,OtherPort}}) + end, + + %% Check bind address + ?vtrace("check_constant_values -> check bind address",[]), + Addr = httpd_util:lookup(Db,bind_address), + case httpd_util:key1search(Config,bind_address) of %% MUST be equal + Addr -> + ok; + OtherAddr -> + throw({error,{addr_changed,Addr,OtherAddr}}) + end, + + %% Check socket type + ?vtrace("check_constant_values -> check socket type",[]), + SockType = httpd_util:lookup(Db, com_type), + case httpd_util:key1search(Config, com_type) of %% MUST be equal + SockType -> + ok; + OtherSockType -> + throw({error,{sock_type_changed,SockType,OtherSockType}}) + end, + ?vtrace("check_constant_values -> done",[]), + ok. + + +%% get_ustate(State) -> idle | active | busy +%% +%% Retrieve the usage state of the HTTP server: +%% 0 active connection -> idle +%% max_clients active connections -> busy +%% Otherwise -> active +%% +get_ustate(State) -> + get_ustate(length(State#state.connections),State). + +get_ustate(0,_State) -> + idle; +get_ustate(ConnectionCnt,State) -> + ConfigDB = State#state.config_db, + case httpd_util:lookup(ConfigDB, max_clients, 150) of + ConnectionCnt -> + busy; + _ -> + active + end. + + +get_astate(S) -> S#state.admin_state. + + +%% Timer handling functions +start_block_tmr(infinity,_) -> + undefined; +start_block_tmr(T,M) -> + erlang:send_after(T,self(),{block_timeout,M}). + +stop_block_tmr(undefined) -> + ok; +stop_block_tmr(Ref) -> + erlang:cancel_timer(Ref). + + +%% Monitor blocker functions +monitor_blocker(Pid) when pid(Pid) -> + case (catch erlang:monitor(process,Pid)) of + MonitorRef -> + MonitorRef; + {'EXIT',Reason} -> + undefined + end; +monitor_blocker(_) -> + undefined. + +demonitor_blocker(undefined) -> + ok; +demonitor_blocker(Ref) -> + (catch erlang:demonitor(Ref)). + + +%% Some status utility functions + +update_heavy_load_status(Status) -> + update_status_with_time(Status,last_heavy_load). + +update_connection_status(Status,ConnCount) -> + S1 = case lists:keysearch(max_conn,1,Status) of + {value,{max_conn,C1}} when ConnCount > C1 -> + lists:keyreplace(max_conn,1,Status,{max_conn,ConnCount}); + {value,{max_conn,C2}} -> + Status; + false -> + [{max_conn,ConnCount}|Status] + end, + update_status_with_time(S1,last_connection). + +update_status_with_time(Status,Key) -> + lists:keyreplace(Key,1,Status,{Key,universal_time()}). + +universal_time() -> calendar:universal_time(). + + +auth_status(P) when pid(P) -> + Items = [status, message_queue_len, reductions, + heap_size, stack_size, current_function], + {auth_status, process_status(P,Items,[])}; +auth_status(_) -> + {auth_status, undefined}. + +sec_status(P) when pid(P) -> + Items = [status, message_queue_len, reductions, + heap_size, stack_size, current_function], + {security_status, process_status(P,Items,[])}; +sec_status(_) -> + {security_status, undefined}. + +acceptor_status(P) when pid(P) -> + Items = [status, message_queue_len, reductions, + heap_size, stack_size, current_function], + {acceptor_status, process_status(P,Items,[])}; +acceptor_status(_) -> + {acceptor_status, undefined}. + + +manager_status(P) -> + Items = [status, message_queue_len, reductions, + heap_size, stack_size], + {manager_status, process_status(P,Items,[])}. + + +process_status(P,[],L) -> + [{pid,P}|lists:reverse(L)]; +process_status(P,[H|T],L) -> + case (catch process_info(P,H)) of + {H, Value} -> + process_status(P,T,[{H,Value}|L]); + _ -> + process_status(P,T,[{H,undefined}|L]) + end. + +make_name(Addr,Port) -> + httpd_util:make_name("httpd",Addr,Port). + + +report_error(State,String) -> + Cdb = State#state.config_db, + error_logger:error_report(String), + mod_log:report_error(Cdb,String), + mod_disk_log:report_error(Cdb,String). + + +set_verbosity(V) -> + Units = [manager_verbosity, + acceptor_verbosity, request_handler_verbosity, + security_verbosity, auth_verbosity], + case httpd_util:key1search(V, all) of + undefined -> + set_verbosity(V, Units); + Verbosity when atom(Verbosity) -> + V1 = [{Unit, Verbosity} || Unit <- Units], + set_verbosity(V1, Units) + end. + +set_verbosity(_V, []) -> + ok; +set_verbosity(V, [manager_verbosity = Unit|Units]) -> + Verbosity = httpd_util:key1search(V, Unit, ?default_verbosity), + put(verbosity, ?vvalidate(Verbosity)), + set_verbosity(V, Units); +set_verbosity(V, [Unit|Units]) -> + Verbosity = httpd_util:key1search(V, Unit, ?default_verbosity), + put(Unit, ?vvalidate(Verbosity)), + set_verbosity(V, Units). + + +set_verbosity(manager,V,_S) -> + put(verbosity,V); +set_verbosity(acceptor,V,_S) -> + put(acceptor_verbosity,V); +set_verbosity(request,V,_S) -> + put(request_handler_verbosity,V); +set_verbosity(security,V,S) -> + OldVerbosity = put(security_verbosity,V), + Addr = httpd_util:lookup(S#state.config_db, bind_address), + Port = httpd_util:lookup(S#state.config_db, port), + mod_security_server:verbosity(Addr,Port,V), + OldVerbosity; +set_verbosity(auth,V,S) -> + OldVerbosity = put(auth_verbosity,V), + Addr = httpd_util:lookup(S#state.config_db, bind_address), + Port = httpd_util:lookup(S#state.config_db, port), + mod_auth_server:verbosity(Addr,Port,V), + OldVerbosity; + +set_verbosity(all,V,S) -> + OldMv = put(verbosity,V), + OldAv = put(acceptor_verbosity,V), + OldRv = put(request_handler_verbosity,V), + OldSv = put(security_verbosity,V), + OldAv = put(auth_verbosity,V), + Addr = httpd_util:lookup(S#state.config_db, bind_address), + Port = httpd_util:lookup(S#state.config_db, port), + mod_security_server:verbosity(Addr,Port,V), + mod_auth_server:verbosity(Addr,Port,V), + [{manager,OldMv}, {request,OldRv}, {security,OldSv}, {auth, OldAv}]. + + +%% +call(ServerRef,Request) -> + gen_server:call(ServerRef,Request). + +cast(ServerRef,Message) -> + gen_server:cast(ServerRef,Message). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_misc_sup.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_misc_sup.erl new file mode 100644 index 0000000000..e671f05206 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_misc_sup.erl @@ -0,0 +1,113 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_misc_sup.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +%%---------------------------------------------------------------------- +%% Purpose: The top supervisor for the Megaco/H.248 application +%%---------------------------------------------------------------------- + +-module(httpd_misc_sup). + +-behaviour(supervisor). + +-include("httpd_verbosity.hrl"). + +%% public +-export([start/3, stop/1, init/1]). + +-export([start_auth_server/3, stop_auth_server/2, + start_sec_server/3, stop_sec_server/2]). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% supervisor callback functions + + +start(Addr, Port, MiscSupVerbosity) -> + SupName = make_name(Addr, Port), + supervisor:start_link({local, SupName}, ?MODULE, [MiscSupVerbosity]). + +stop(StartArgs) -> + ok. + +init([Verbosity]) -> % Supervisor + do_init(Verbosity); +init(BadArg) -> + {error, {badarg, BadArg}}. + +do_init(Verbosity) -> + put(verbosity,?vvalidate(Verbosity)), + put(sname,misc_sup), + ?vlog("starting", []), + Flags = {one_for_one, 0, 1}, + KillAfter = timer:seconds(1), + Workers = [], + {ok, {Flags, Workers}}. + + +%%---------------------------------------------------------------------- +%% Function: [start|stop]_[auth|sec]_server/3 +%% Description: Starts a [auth | security] worker (child) process +%%---------------------------------------------------------------------- + +start_auth_server(Addr, Port, Verbosity) -> + start_permanent_worker(mod_auth_server, Addr, Port, + Verbosity, [gen_server]). + +stop_auth_server(Addr, Port) -> + stop_permanent_worker(mod_auth_server, Addr, Port). + + +start_sec_server(Addr, Port, Verbosity) -> + start_permanent_worker(mod_security_server, Addr, Port, + Verbosity, [gen_server]). + +stop_sec_server(Addr, Port) -> + stop_permanent_worker(mod_security_server, Addr, Port). + + + +%%---------------------------------------------------------------------- +%% Function: start_permanent_worker/5 +%% Description: Starts a permanent worker (child) process +%%---------------------------------------------------------------------- + +start_permanent_worker(Mod, Addr, Port, Verbosity, Modules) -> + SupName = make_name(Addr, Port), + Spec = {{Mod, Addr, Port}, + {Mod, start_link, [Addr, Port, Verbosity]}, + permanent, timer:seconds(1), worker, [Mod] ++ Modules}, + supervisor:start_child(SupName, Spec). + + +%%---------------------------------------------------------------------- +%% Function: stop_permanent_worker/3 +%% Description: Stops a permanent worker (child) process +%%---------------------------------------------------------------------- + +stop_permanent_worker(Mod, Addr, Port) -> + SupName = make_name(Addr, Port), + Name = {Mod, Addr, Port}, + case supervisor:terminate_child(SupName, Name) of + ok -> + supervisor:delete_child(SupName, Name); + Error -> + Error + end. + + +make_name(Addr,Port) -> + httpd_util:make_name("httpd_misc_sup",Addr,Port). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_parse.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_parse.erl new file mode 100644 index 0000000000..2f4163de00 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_parse.erl @@ -0,0 +1,344 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_parse.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(httpd_parse). +-export([ + request_header/1, + hsplit/2, + get_request_record/10, + split_lines/1, + tagup_header/1]). +-include("httpd.hrl"). + + +%%---------------------------------------------------------------------- +%% request_header +%% +%% Input: The request as sent from the client (list of characters) +%% (may include part of the entity body) +%% +%% Returns: +%% {ok, Info#mod} +%% {not_implemented,Info#mod} +%% {bad_request, Reason} +%%---------------------------------------------------------------------- + +request_header(Header)-> + [RequestLine|HeaderFields] = split_lines(Header), + ?DEBUG("request ->" + "~n RequestLine: ~p" + "~n Header: ~p",[RequestLine,Header]), + ParsedHeader = tagup_header(HeaderFields), + ?DEBUG("request ->" + "~n ParseHeader: ~p",[ParsedHeader]), + case verify_request(string:tokens(RequestLine," ")) of + ["HEAD", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] -> + {ok, ["HEAD", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N], RequestLine, + ParsedHeader]}; + ["GET", RequestURI, "HTTP/0.9"] -> + {ok, ["GET", RequestURI, "HTTP/0.9", RequestLine, ParsedHeader]}; + ["GET", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] -> + {ok, ["GET", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N], RequestLine, + ParsedHeader]}; + ["POST", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] -> + {ok, ["POST", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N], RequestLine, + ParsedHeader]}; + %%HTTP must be 1.1 or higher + ["TRACE", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] when N>48-> + {ok, ["TRACE", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N], RequestLine, + ParsedHeader]}; + [Method, RequestURI] -> + {not_implemented, RequestLine, Method, RequestURI,ParsedHeader,"HTTP/0.9"}; + [Method, RequestURI, HTTPVersion] -> + {not_implemented, RequestLine, Method, RequestURI,ParsedHeader, HTTPVersion}; + {bad_request, Reason} -> + {bad_request, Reason}; + Reason -> + {bad_request, "Unknown request method"} + end. + + + + + + +%%---------------------------------------------------------------------- +%% The request is passed through the server as a record of type mod get it +%% ---------------------------------------------------------------------- + +get_request_record(Socket,SocketType,ConfigDB,Method,RequestURI, + HTTPVersion,RequestLine,ParsedHeader,EntityBody,InitData)-> + PersistentConn=get_persistens(HTTPVersion,ParsedHeader,ConfigDB), + Info=#mod{init_data=InitData, + data=[], + socket_type=SocketType, + socket=Socket, + config_db=ConfigDB, + method=Method, + absolute_uri=formatAbsoluteURI(RequestURI,ParsedHeader), + request_uri=formatRequestUri(RequestURI), + http_version=HTTPVersion, + request_line=RequestLine, + parsed_header=ParsedHeader, + entity_body=maybe_remove_nl(ParsedHeader,EntityBody), + connection=PersistentConn}, + {ok,Info}. + +%%---------------------------------------------------------------------- +%% Conmtrol wheater we shall maintain a persistent connection or not +%%---------------------------------------------------------------------- +get_persistens(HTTPVersion,ParsedHeader,ConfigDB)-> + case httpd_util:lookup(ConfigDB,persistent_conn,true) of + true-> + case HTTPVersion of + %%If it is version prio to 1.1 kill the conneciton + [$H, $T, $T, $P, $\/, $1, $.,N] -> + case httpd_util:key1search(ParsedHeader,"connection","keep-alive")of + %%if the connection isnt ordered to go down let it live + %%The keep-alive value is the older http/1.1 might be older + %%Clients that use it. + "keep-alive" when N >= 49 -> + ?DEBUG("CONNECTION MODE: ~p",[true]), + true; + "close" -> + ?DEBUG("CONNECTION MODE: ~p",[false]), + false; + Connect -> + ?DEBUG("CONNECTION MODE: ~p VALUE: ~p",[false,Connect]), + false + end; + _ -> + ?DEBUG("CONNECTION MODE: ~p VERSION: ~p",[false,HTTPVersion]), + false + + end; + _ -> + false + end. + + + + +%%---------------------------------------------------------------------- +%% Control whether the last newline of the body is a part of the message or +%%it is a part of the multipart message. +%%---------------------------------------------------------------------- +maybe_remove_nl(Header,Rest) -> + case find_content_type(Header) of + false -> + {ok,EntityBody,_}=regexp:sub(Rest,"\r\n\$",""), + EntityBody; + {ok, Value} -> + case string:str(Value, "multipart/form-data") of + 0 -> + {ok,EntityBody,_}=regexp:sub(Rest,"\r\n\$",""), + EntityBody; + _ -> + Rest + end + end. + +%%---------------------------------------------------------------------- +%% Cet the content type of the incomming request +%%---------------------------------------------------------------------- + + +find_content_type([]) -> + false; +find_content_type([{Name,Value}|Tail]) -> + case httpd_util:to_lower(Name) of + "content-type" -> + {ok, Value}; + _ -> + find_content_type(Tail) + end. + +%%---------------------------------------------------------------------- +%% Split the header to a list of strings where each string represents a +%% HTTP header-field +%%---------------------------------------------------------------------- +split_lines(Request) -> + split_lines(Request, [], []). +split_lines([], CAcc, Acc) -> + lists:reverse([lists:reverse(CAcc)|Acc]); + +%%White space in the header fields are allowed but the new line must begin with LWS se +%%rfc2616 chap 4.2. The rfc do not say what to +split_lines([$\r, $\n, $\t |Rest], CAcc, Acc) -> + split_lines(Rest, [$\r, $\n |CAcc], Acc); + +split_lines([$\r, $\n, $\s |Rest], CAcc, Acc) -> + split_lines(Rest, [$\r, $\n |CAcc], Acc); + +split_lines([$\r, $\n|Rest], CAcc, Acc) -> + split_lines(Rest, [], [lists:reverse(CAcc)|Acc]); +split_lines([Chr|Rest], CAcc, Acc) -> + split_lines(Rest, [Chr|CAcc], Acc). + + +%%---------------------------------------------------------------------- +%% This is a 'hack' to stop people from trying to access directories/files +%% relative to the ServerRoot. +%%---------------------------------------------------------------------- + + +verify_request([Request, RequestURI]) -> + verify_request([Request, RequestURI, "HTTP/0.9"]); + +verify_request([Request, RequestURI, Protocol]) -> + NewRequestURI = + case string:str(RequestURI, "?") of + 0 -> + RequestURI; + Ndx -> + string:left(RequestURI, Ndx) + end, + case string:str(NewRequestURI, "..") of + 0 -> + [Request, RequestURI, Protocol]; + _ -> + {bad_request, {forbidden, RequestURI}} + end; +verify_request(Request) -> + Request. + +%%---------------------------------------------------------------------- +%% tagup_header +%% +%% Parses the header of a HTTP request and returns a key,value tuple +%% list containing Name and Value of each header directive as of: +%% +%% Content-Type: multipart/mixed -> {"Content-Type", "multipart/mixed"} +%% +%% But in http/1.1 the field-names are case insencitive so now it must be +%% Content-Type: multipart/mixed -> {"content-type", "multipart/mixed"} +%% The standard furthermore says that leading and traling white space +%% is not a part of the fieldvalue and shall therefore be removed. +%%---------------------------------------------------------------------- + +tagup_header([]) -> []; +tagup_header([Line|Rest]) -> [tag(Line, [])|tagup_header(Rest)]. + +tag([], Tag) -> + {httpd_util:to_lower(lists:reverse(Tag)), ""}; +tag([$:|Rest], Tag) -> + {httpd_util:to_lower(lists:reverse(Tag)), httpd_util:strip(Rest)}; +tag([Chr|Rest], Tag) -> + tag(Rest, [Chr|Tag]). + + +%%---------------------------------------------------------------------- +%% There are 3 possible forms of the reuqest URI +%% +%% 1. * When the request is not for a special assset. is is instead +%% to the server itself +%% +%% 2. absoluteURI the whole servername port and asset is in the request +%% +%% 3. The most common form that http/1.0 used abs path that is a path +%% to the requested asset. +%5---------------------------------------------------------------------- +formatRequestUri("*")-> + "*"; +formatRequestUri([$h,$t,$t,$p,$:,$\/,$\/|ServerAndPath]) -> + removeServer(ServerAndPath); + +formatRequestUri([$H,$T,$T,$P,$:,$\/,$\/|ServerAndPath]) -> + removeServer(ServerAndPath); + +formatRequestUri(ABSPath) -> + ABSPath. + +removeServer([$\/|Url])-> + case Url of + []-> + "/"; + _-> + [$\/|Url] + end; +removeServer([N|Url]) -> + removeServer(Url). + + +formatAbsoluteURI([$h,$t,$t,$p,$:,$\/,$\/|Uri],ParsedHeader)-> + [$H,$T,$T,$P,$:,$\/,$\/|Uri]; + +formatAbsoluteURI([$H,$T,$T,$P,$:,$\/,$\/|Uri],ParsedHeader)-> + [$H,$T,$T,$P,$:,$\/,$\/|Uri]; + +formatAbsoluteURI(Uri,ParsedHeader)-> + case httpd_util:key1search(ParsedHeader,"host") of + undefined -> + nohost; + Host -> + Host++Uri + end. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%Code below is crap from an older version shall be removed when +%%transformation to http/1.1 is finished +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + +%request(Request) -> +% ?DEBUG("request -> entry with:" +% "~n Request: ~s",[Request]), + % {BeforeEntityBody, Rest} = hsplit([], Request), + % ?DEBUG("request ->" +% "~n BeforeEntityBody: ~p" +% "~n Rest: ~p",[BeforeEntityBody, Rest]), +% [RequestLine|Header] = split_lines(BeforeEntityBody), +% ?DEBUG("request ->" +% "~n RequestLine: ~p" +% "~n Header: ~p",[RequestLine,Header]), +% ParsedHeader = tagup_header(Header), +% ?DEBUG("request ->" +% "~n ParseHeader: ~p",[ParsedHeader]), +% EntityBody = maybe_remove_nl(ParsedHeader,Rest), +% ?DEBUG("request ->" +% "~n EntityBody: ~p",[EntityBody]), +% case verify_request(string:tokens(RequestLine," ")) of +% ["HEAD", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] -> +% {ok, ["HEAD", formatRequestUri(RequestURI), [$H,$T,$T,$P,$/,$1,$.,N], RequestLine, +% ParsedHeader, EntityBody]}; +% ["GET", RequestURI, "HTTP/0.9"] -> +% {ok, ["GET", RequestURI, "HTTP/0.9", RequestLine, ParsedHeader, +% EntityBody]}; +% ["GET", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] -> +% {ok, ["GET", formatRequestUri(RequestURI), [$H,$T,$T,$P,$/,$1,$.,N], RequestLine, +% ParsedHeader,EntityBody]}; +%% ["POST", RequestURI, [$H,$T,$T,$P,$/,$1,$.,N]] -> +% {ok, ["POST", formatRequestUri(RequestURI), [$H,$T,$T,$P,$/,$1,$.,N], RequestLine, +% ParsedHeader, EntityBody]}; +% [Method, RequestURI] -> +% {not_implemented, RequestLine, Method, RequestURI,ParsedHeader,"HTTP/0.9"}; +% [Method, RequestURI, HTTPVersion] -> +% {not_implemented, RequestLine, Method, RequestURI,ParsedHeader, HTTPVersion}; +% {bad_request, Reason} -> +% {bad_request, Reason}; +% Reason -> +% {bad_request, "Unknown request method"} +% end. + +hsplit(Accu,[]) -> + {lists:reverse(Accu), []}; +hsplit(Accu, [ $\r, $\n, $\r, $\n | Tail]) -> + {lists:reverse(Accu), Tail}; +hsplit(Accu, [H|T]) -> + hsplit([H|Accu],T). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_request_handler.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_request_handler.erl new file mode 100644 index 0000000000..b2d375ceff --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_request_handler.erl @@ -0,0 +1,994 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_request_handler.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(httpd_request_handler). + +%% app internal api +-export([start_link/2, synchronize/3]). + +%% module internal api +-export([connection/2, do_next_connection/6, read_header/7]). +-export([parse_trailers/1, newline/1]). + +-include("httpd.hrl"). +-include("httpd_verbosity.hrl"). + + +%% start_link + +start_link(Manager, ConfigDB) -> + Pid = proc_lib:spawn(?MODULE, connection, [Manager, ConfigDB]), + {ok, Pid}. + + +%% synchronize + +synchronize(Pid, SocketType, Socket) -> + Pid ! {synchronize, SocketType, Socket}. + +% connection + +connection(Manager, ConfigDB) -> + {SocketType, Socket, {Status, Verbosity}} = await_synchronize(Manager), + put(sname,self()), + put(verbosity,?vvalidate(Verbosity)), + connection1(Status, Manager, ConfigDB, SocketType, Socket). + + +connection1({reject, busy}, Manager, ConfigDB, SocketType, Socket) -> + handle_busy(Manager, ConfigDB, SocketType, Socket); + +connection1({reject, blocked}, Manager, ConfigDB, SocketType, Socket) -> + handle_blocked(Manager, ConfigDB, SocketType, Socket); + +connection1(accept, Manager, ConfigDB, SocketType, Socket) -> + handle_connection(Manager, ConfigDB, SocketType, Socket). + + +%% await_synchronize + +await_synchronize(Manager) -> + receive + {synchronize, SocketType, Socket} -> + ?vlog("received syncronize: " + "~n SocketType: ~p" + "~n Socket: ~p", [SocketType, Socket]), + {SocketType, Socket, httpd_manager:new_connection(Manager)} + after 5000 -> + exit(synchronize_timeout) + end. + + +% handle_busy + +handle_busy(Manager, ConfigDB, SocketType, Socket) -> + ?vlog("handle busy: ~p", [Socket]), + MaxClients = httpd_util:lookup(ConfigDB, max_clients, 150), + String = io_lib:format("heavy load (>~w processes)", [MaxClients]), + reject_connection(Manager, ConfigDB, SocketType, Socket, String). + + +% handle_blocked + +handle_blocked(Manager, ConfigDB, SocketType, Socket) -> + ?vlog("handle blocked: ~p", [Socket]), + String = "Server maintenance performed, try again later", + reject_connection(Manager, ConfigDB, SocketType, Socket, String). + + +% reject_connection + +reject_connection(Manager, ConfigDB, SocketType, Socket, Info) -> + String = lists:flatten(Info), + ?vtrace("send status (503) message", []), + httpd_response:send_status(SocketType, Socket, 503, String, ConfigDB), + %% This ugly thing is to make ssl deliver the message, before the close... + close_sleep(SocketType, 1000), + ?vtrace("close the socket", []), + close(SocketType, Socket, ConfigDB). + + +% handle_connection + +handle_connection(Manager, ConfigDB, SocketType, Socket) -> + ?vlog("handle connection: ~p", [Socket]), + Resolve = httpd_socket:resolve(SocketType), + Peername = httpd_socket:peername(SocketType, Socket), + InitData = #init_data{peername=Peername, resolve=Resolve}, + TimeOut = httpd_util:lookup(ConfigDB, keep_alive_timeout, 150000), + NrOfRequest = httpd_util:lookup(ConfigDB, max_keep_alive_request, forever), + ?MODULE:do_next_connection(ConfigDB, InitData, + SocketType, Socket,NrOfRequest,TimeOut), + ?vlog("handle connection: done", []), + httpd_manager:done_connection(Manager), + ?vlog("handle connection: close socket", []), + close(SocketType, Socket, ConfigDB). + + +% do_next_connection +do_next_connection(_ConfigDB, _InitData, _SocketType, _Socket, NrOfRequests, + _Timeout) when NrOfRequests < 1 -> + ?vtrace("do_next_connection: done", []), + ok; +do_next_connection(ConfigDB, InitData, SocketType, Socket, NrOfRequests, + Timeout) -> + Peername = InitData#init_data.peername, + case (catch read(ConfigDB, SocketType, Socket, InitData, Timeout)) of + {'EXIT', Reason} -> + ?vlog("exit reading from socket: ~p",[Reason]), + error_logger:error_report({'EXIT',Reason}), + String = + lists:flatten( + io_lib:format("exit reading from socket: ~p => ~n~p~n", + [Socket, Reason])), + error_log(mod_log, + SocketType, Socket, ConfigDB, Peername, String), + error_log(mod_disk_log, + SocketType, Socket, ConfigDB, Peername, String); + {error, Reason} -> + handle_read_error(Reason,SocketType,Socket,ConfigDB,Peername); + Info when record(Info, mod) -> + case Info#mod.connection of + true -> + ReqTimeout = httpd_util:lookup(ConfigDB, + keep_alive_timeout, 150000), + ?MODULE:do_next_connection(ConfigDB, InitData, + SocketType, Socket, + dec(NrOfRequests), ReqTimeout); + _ -> + ok + end; + _ -> + ok + end. + + + +%% read +read(ConfigDB, SocketType, Socket, InitData, Timeout) -> + ?vdebug("read from socket ~p with Timeout ~p",[Socket, Timeout]), + MaxHdrSz = httpd_util:lookup(ConfigDB, max_header_size, 10240), + case ?MODULE:read_header(SocketType, Socket, Timeout, MaxHdrSz, + ConfigDB, InitData, []) of + {socket_closed, Reason} -> + ?vlog("Socket closed while reading request header: " + "~n ~p", [Reason]), + socket_close; + {error, Error} -> + {error, Error}; + {ok, Info, EntityBodyPart} -> + read1(SocketType, Socket, ConfigDB, InitData, Timeout, Info, + EntityBodyPart) + end. + +%% Got the head and maybe a part of the body: read in the rest +read1(SocketType, Socket, ConfigDB, InitData, Timeout, Info, BodyPart)-> + MaxBodySz = httpd_util:lookup(ConfigDB, max_body_size, nolimit), + ContentLength = content_length(Info), + ?vtrace("ContentLength: ~p", [ContentLength]), + case read_entity_body(SocketType, Socket, Timeout, MaxBodySz, + ContentLength, BodyPart, Info, ConfigDB) of + {socket_closed, Reason} -> + ?vlog("Socket closed while reading request body: " + "~n ~p", [Reason]), + socket_close; + {ok, EntityBody} -> + finish_request(EntityBody, [], Info); + {ok, ExtraHeader, EntityBody} -> + finish_request(EntityBody, ExtraHeader, Info); + Response -> + httpd_socket:close(SocketType, Socket), + socket_closed + %% Catch up all bad return values + end. + + +%% The request is read in send it forward to the module that +%% generates the response + +finish_request(EntityBody, ExtraHeader, + #mod{parsed_header = ParsedHeader} = Info)-> + ?DEBUG("finish_request -> ~n" + " EntityBody: ~p~n" + " ExtraHeader: ~p~n" + " ParsedHeader: ~p~n", + [EntityBody, ExtraHeader, ParsedHeader]), + httpd_response:send(Info#mod{parsed_header = ParsedHeader ++ ExtraHeader, + entity_body = EntityBody}). + + +%% read_header + +%% This algorithm rely on the buffer size of the inet driver together +%% with the {active, once} socket option. Atmost one message of this +%% size will be received at a given time. When a full header has been +%% read, the body is read with the recv function (the body size is known). +%% +read_header(SocketType, Socket, Timeout, MaxHdrSz, ConfigDB, + InitData, SoFar0) -> + T = t(), + %% remove any newlines at the begining, they might be crap from ? + SoFar = remove_newline(SoFar0), + + case terminated_header(MaxHdrSz, SoFar) of + {true, Header, EntityBodyPart} -> + ?vdebug("read_header -> done reading header: " + "~n length(Header): ~p" + "~n length(EntityBodyPart): ~p", + [length(Header), length(EntityBodyPart)]), + transform_header(SocketType, Socket, Header, ConfigDB, InitData, + EntityBodyPart); + false -> + ?vtrace("read_header -> " + "~n set active = 'once' and " + "await a chunk of the header", []), + + case httpd_socket:active_once(SocketType, Socket) of + ok -> + receive + %% + %% TCP + %% + {tcp, Socket, Data} -> + ?vtrace("read_header(ip) -> got some data: ~p", + [sz(Data)]), + ?MODULE:read_header(SocketType, Socket, + Timeout - (t()-T), + MaxHdrSz, ConfigDB, + InitData, SoFar ++ Data); + {tcp_closed, Socket} -> + ?vtrace("read_header(ip) -> socket closed",[]), + {socket_closed,normal}; + {tcp_error, Socket, Reason} -> + ?vtrace("read_header(ip) -> socket error: ~p", + [Reason]), + {socket_closed, Reason}; + + %% + %% SSL + %% + {ssl, Socket, Data} -> + ?vtrace("read_header(ssl) -> got some data: ~p", + [sz(Data)]), + ?MODULE:read_header(SocketType, Socket, + Timeout - (t()-T), + MaxHdrSz, ConfigDB, + InitData, SoFar ++ Data); + {ssl_closed, Socket} -> + ?vtrace("read_header(ssl) -> socket closed", []), + {socket_closed, normal}; + {ssl_error, Socket, Reason} -> + ?vtrace("read_header(ssl) -> socket error: ~p", + [Reason]), + {socket_closed, Reason} + + after Timeout -> + ?vlog("read_header -> timeout", []), + {socket_closed, timeout} + end; + + Error -> + httpd_response:send_status(SocketType, Socket, + 500, none, ConfigDB), + Error + end + end. + + +terminated_header(MaxHdrSz, Data) -> + D1 = lists:flatten(Data), + ?vtrace("terminated_header -> Data size: ~p",[sz(D1)]), + case hsplit(MaxHdrSz,[],D1) of + not_terminated -> + false; + [Header, EntityBodyPart] -> + {true, Header++"\r\n\r\n",EntityBodyPart} + end. + + +transform_header(SocketType, Socket, Request, ConfigDB, InitData, BodyPart) -> + case httpd_parse:request_header(Request) of + {not_implemented, RequestLine, Method, RequestURI, ParsedHeader, + HTTPVersion} -> + httpd_response:send_status(SocketType, Socket, 501, + {Method, RequestURI, HTTPVersion}, + ConfigDB), + {error,"Not Implemented"}; + {bad_request, {forbidden, URI}} -> + httpd_response:send_status(SocketType, Socket, 403, URI, ConfigDB), + {error,"Forbidden Request"}; + {bad_request, Reason} -> + httpd_response:send_status(SocketType, Socket, 400, none, + ConfigDB), + {error,"Malformed request"}; + {ok,[Method, RequestURI, HTTPVersion, RequestLine, ParsedHeader]} -> + ?DEBUG("send -> ~n" + " Method: ~p~n" + " RequestURI: ~p~n" + " HTTPVersion: ~p~n" + " RequestLine: ~p~n", + [Method, RequestURI, HTTPVersion, RequestLine]), + {ok, Info} = + httpd_parse:get_request_record(Socket, SocketType, ConfigDB, + Method, RequestURI, HTTPVersion, + RequestLine, ParsedHeader, + [], InitData), + %% Control that the Host header field is provided + case Info#mod.absolute_uri of + nohost -> + case Info#mod.http_version of + "HTTP/1.1" -> + httpd_response:send_status(Info, 400, none), + {error,"No host specified"}; + _ -> + {ok, Info, BodyPart} + end; + _ -> + {ok, Info, BodyPart} + end + end. + + +hsplit(_MaxHdrSz, Accu,[]) -> + not_terminated; +hsplit(_MaxHdrSz, Accu, [ $\r, $\n, $\r, $\n | Tail]) -> + [lists:reverse(Accu), Tail]; +hsplit(nolimit, Accu, [H|T]) -> + hsplit(nolimit,[H|Accu],T); +hsplit(MaxHdrSz, Accu, [H|T]) when length(Accu) < MaxHdrSz -> + hsplit(MaxHdrSz,[H|Accu],T); +hsplit(MaxHdrSz, Accu, D) -> + throw({error,{header_too_long,length(Accu),length(D)}}). + + + +%%---------------------------------------------------------------------- +%% The http/1.1 standard chapter 8.2.3 says that a request containing +%% An Except header-field must be responded to by 100 (Continue) by +%% the server before the client sends the body. +%%---------------------------------------------------------------------- + +read_entity_body(SocketType, Socket, Timeout, Max, Length, BodyPart, Info, + ConfigDB) when integer(Max) -> + case expect(Info#mod.http_version, Info#mod.parsed_header, ConfigDB) of + continue when Max > Length -> + ?DEBUG("read_entity_body()->100 Continue ~n", []), + httpd_response:send_status(Info, 100, ""), + read_entity_body2(SocketType, Socket, Timeout, Max, Length, + BodyPart, Info, ConfigDB); + continue when Max < Length -> + httpd_response:send_status(Info, 417, "Body to big"), + httpd_socket:close(SocketType, Socket), + {socket_closed,"Expect denied according to size"}; + break -> + httpd_response:send_status(Info, 417, "Method not allowed"), + httpd_socket:close(SocketType, Socket), + {socket_closed,"Expect conditions was not fullfilled"}; + no_expect_header -> + read_entity_body2(SocketType, Socket, Timeout, Max, Length, + BodyPart, Info, ConfigDB); + http_1_0_expect_header -> + httpd_response:send_status(Info, 400, + "Only HTTP/1.1 Clients " + "may use the Expect Header"), + httpd_socket:close(SocketType, Socket), + {socket_closed,"Due to a HTTP/1.0 expect header"} + end; + +read_entity_body(SocketType, Socket, Timeout, Max, Length, BodyPart, + Info, ConfigDB) -> + case expect(Info#mod.http_version, Info#mod.parsed_header, ConfigDB) of + continue -> + ?DEBUG("read_entity_body() -> 100 Continue ~n", []), + httpd_response:send_status(Info, 100, ""), + read_entity_body2(SocketType, Socket, Timeout, Max, Length, + BodyPart, Info, ConfigDB); + break-> + httpd_response:send_status(Info, 417, "Method not allowed"), + httpd_socket:close(SocketType, Socket), + {socket_closed,"Expect conditions was not fullfilled"}; + no_expect_header -> + read_entity_body2(SocketType, Socket, Timeout, Max, Length, + BodyPart, Info, ConfigDB); + http_1_0_expect_header -> + httpd_response:send_status(Info, 400, + "HTTP/1.0 Clients are not allowed " + "to use the Expect Header"), + httpd_socket:close(SocketType, Socket), + {socket_closed,"Expect header field in an HTTP/1.0 request"} + end. + +%%---------------------------------------------------------------------- +%% control if the body is transfer encoded +%%---------------------------------------------------------------------- +read_entity_body2(SocketType, Socket, Timeout, Max, Length, BodyPart, + Info, ConfigDB) -> + ?DEBUG("read_entity_body2() -> " + "~n Max: ~p" + "~n Length: ~p" + "~n Socket: ~p", [Max, Length, Socket]), + + case transfer_coding(Info) of + {chunked, ChunkedData} -> + ?DEBUG("read_entity_body2() -> " + "Transfer-encoding: Chunked Data: BodyPart ~s", [BodyPart]), + read_chunked_entity(Info, Timeout, Max, Length, ChunkedData, [], + BodyPart); + unknown_coding -> + ?DEBUG("read_entity_body2() -> Transfer-encoding: Unknown",[]), + httpd_response:send_status(Info, 501, "Unknown Transfer-Encoding"), + httpd_socket:close(SocketType, Socket), + {socket_closed,"Expect conditions was not fullfilled"}; + none -> + ?DEBUG("read_entity_body2() -> Transfer-encoding: none",[]), + read_entity_body(SocketType, Socket, Timeout, Max, Length, + BodyPart) + end. + + +%%---------------------------------------------------------------------- +%% The body was plain read it from the socket +%% ---------------------------------------------------------------------- +read_entity_body(_SocketType, _Socket, _Timeout, _Max, 0, _BodyPart) -> + {ok, []}; + +read_entity_body(_SocketType, _Socket, _Timeout, Max, Len, _BodyPart) + when Max < Len -> + ?vlog("body to long: " + "~n Max: ~p" + "~n Len: ~p", [Max,Len]), + throw({error,{body_too_long,Max,Len}}); + +%% OTP-4409: Fixing POST problem +read_entity_body(_,_,_,_, Len, BodyPart) when Len == length(BodyPart) -> + ?vtrace("read_entity_body -> done when" + "~n Len = length(BodyPart): ~p", [Len]), + {ok, BodyPart}; + +%% OTP-4550: Fix problem with trailing garbage produced by some clients. +read_entity_body(_, _, _, _, Len, BodyPart) when Len < length(BodyPart) -> + ?vtrace("read_entity_body -> done when" + "~n Len: ~p" + "~n length(BodyPart): ~p", [Len, length(BodyPart)]), + {ok, lists:sublist(BodyPart,Len)}; + +read_entity_body(SocketType, Socket, Timeout, Max, Len, BodyPart) -> + ?vtrace("read_entity_body -> entry when" + "~n Len: ~p" + "~n length(BodyPart): ~p", [Len, length(BodyPart)]), + %% OTP-4548: + %% The length calculation was previously (inets-2.*) done in the + %% read function. As of 3.0 it was removed from read but not + %% included here. + L = Len - length(BodyPart), + case httpd_socket:recv(SocketType, Socket, L, Timeout) of + {ok, Body} -> + ?vtrace("read_entity_body -> received some data:" + "~n length(Body): ~p", [length(Body)]), + {ok, BodyPart ++ Body}; + {error,closed} -> + {socket_closed,normal}; + {error,etimedout} -> + {socket_closed, timeout}; + {error,Reason} -> + {socket_closed, Reason}; + Other -> + {socket_closed, Other} + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% If the body of the message is encoded used the chunked transfer encoding +%% it looks somethin like this: +%% METHOD URI HTTP/VSN +%% Transfer-Encoding: chunked +%% CRLF +%% ChunkSize +%% Chunk +%% ChunkSize +%% Chunk +%% 0 +%% Trailer +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +read_chunked_entity(Info, Timeout, Max, Length, ChunkedData, Body, []) -> + ?DEBUG("read_chunked_entity()->:no_chunks ~n", []), + read_chunked_entity(Info#mod.socket_type, Info#mod.socket, + Timeout, Max, Length, ChunkedData, Body, + Info#mod.config_db, Info); + +read_chunked_entity(Info, Timeout, Max, Length, ChunkedData, Body, BodyPart) -> + %% Get the size + ?DEBUG("read_chunked_entity() -> PrefetchedBodyPart: ~p ~n",[BodyPart]), + case parse_chunk_size(Info, Timeout, BodyPart) of + {ok, Size, NewBodyPart} when Size > 0 -> + ?DEBUG("read_chunked_entity() -> Size: ~p ~n", [Size]), + case parse_chunked_entity_body(Info, Timeout, Max, length(Body), + Size, NewBodyPart) of + {ok, Chunk, NewBodyPart1} -> + ?DEBUG("read_chunked_entity()->Size: ~p ~n", [Size]), + read_chunked_entity(Info, Timeout, Max, Length, + ChunkedData, Body ++ Chunk, + NewBodyPart1); + OK -> + httpd_socket:close(Info#mod.socket_type, Info#mod.socket), + {socket_closed, error} + end; + {ok, 0, Trailers} -> + ?DEBUG("read_chunked_entity()->Size: 0, Trailers: ~s Body: ~s ~n", + [Trailers, Body]), + case parse_chunk_trailer(Info, Timeout, Info#mod.config_db, + Trailers) of + {ok, TrailerFields} -> + {ok, TrailerFields, Body}; + _-> + {ok, []} + end; + Error -> + Error + end. + + +parse_chunk_size(Info, Timeout, BodyPart) -> + case httpd_util:split(remove_newline(BodyPart), "\r\n", 2) of + {ok, [Size, Body]} -> + ?DEBUG("parse_chunk_size()->Size: ~p ~n", [Size]), + {ok, httpd_util:hexlist_to_integer(Size), Body}; + {ok, [Size]} -> + ?DEBUG("parse_chunk_size()->Size: ~p ~n", [Size]), + Sz = get_chunk_size(Info#mod.socket_type, + Info#mod.socket, Timeout, + lists:reverse(Size)), + {ok, Sz, []} + end. + +%%---------------------------------------------------------------------- +%% We got the chunk size get the chunk +%% +%% Max: Max numbers of bytes to read may also be undefined +%% Length: Numbers of bytes already read +%% Size Numbers of byte to read for the chunk +%%---------------------------------------------------------------------- + +%% body to big +parse_chunked_entity_body(Info, Timeout, Max, Length, Size, BodyPart) + when Max =< (Length + Size) -> + {error, body_to_big}; + +%% Prefetched body part is bigger than the current chunk +%% (i.e. BodyPart includes more than one chunk) +parse_chunked_entity_body(Info, Timeout, Max, Length, Size, BodyPart) + when (Size+2) =< length(BodyPart) -> + Chunk = string:substr(BodyPart, 1, Size), + Rest = string:substr(BodyPart, Size+3), + ?DEBUG("parse_chunked_entity_body() -> ~nChunk: ~s ~nRest: ~s ~n", + [Chunk, Rest]), + {ok, Chunk, Rest}; + + +%% We just got a part of the current chunk +parse_chunked_entity_body(Info, Timeout, Max, Length, Size, BodyPart) -> + %% OTP-4551: + %% Subtracting BodyPart from Size does not produce an integer + %% when BodyPart is a list... + Remaining = Size - length(BodyPart), + LastPartOfChunk = read_chunked_entity_body(Info#mod.socket_type, + Info#mod.socket, + Timeout, Max, + Length, Remaining), + %% Remove newline + httpd_socket:recv(Info#mod.socket_type, Info#mod.socket, 2, Timeout), + ?DEBUG("parse_chunked_entity_body() -> " + "~nBodyPart: ~s" + "~nLastPartOfChunk: ~s ~n", + [BodyPart, LastPartOfChunk]), + {ok, BodyPart ++ LastPartOfChunk, []}. + + +%%---------------------------------------------------------------------- +%% If the data we got along with the header contained the whole chunked body +%% It may aswell contain the trailer :-( +%%---------------------------------------------------------------------- +%% Either trailer begins with \r\n and then all data is there or +%% The trailer has data then read upto \r\n\r\n +parse_chunk_trailer(Info,Timeout,ConfigDB,"\r\n")-> + {ok,[]}; +parse_chunk_trailer(Info,Timeout,ConfigDB,Trailers) -> + ?DEBUG("parse_chunk_trailer()->Trailers: ~s ~n", [Trailers]), + case string:rstr(Trailers,"\r\n\r\n") of + 0 -> + MaxHdrSz=httpd_util:lookup(ConfigDB, max_header_size, 10240), + read_trailer_end(Info,Timeout,MaxHdrSz,Trailers); + _-> + %%We got the whole header parse it up + parse_trailers(Trailers) + end. + +parse_trailers(Trailer)-> + ?DEBUG("parse_trailer()->Trailer: ~s",[Trailer]), + {ok,[Fields0|Crap]}=httpd_util:split(Trailer,"\r\n\r\n",2), + Fields=string:tokens(Fields0,"\r\n"), + [getTrailerField(X)||X<-Fields,lists:member($:,X)]. + + +read_trailer_end(Info,Timeout,MaxHdrSz,[])-> + ?DEBUG("read_trailer_end()->[]",[]), + case read_trailer(Info#mod.socket_type,Info#mod.socket, + Timeout,MaxHdrSz,[],[], + httpd_util:key1search(Info#mod.parsed_header,"trailer",[])) of + {ok,Trailers}-> + Trailers; + _-> + [] + end; +read_trailer_end(Info,Timeout,MaxHdrSz,Trailers)-> + ?DEBUG("read_trailer_end()->Trailers: ~s ~n ",[Trailers]), + %% Get the last paart of the the last headerfield + End=lists:reverse(lists:takewhile(fun(X)->case X of 10 ->false;13->false;_ ->true end end,lists:reverse(Trailers))), + Fields0=regexp:split(Trailers,"\r\n"), + %%Get rid of the last header field + [_Last|Fields]=lists:reverse(Fields0), + Headers=[getTrailerField(X)||X<-Fields,lists:member($:,X)], + case read_trailer(Info#mod.socket_type,Info#mod.socket, + Timeout,MaxHdrSz,Headers,End, + httpd_util:key1search(Info#mod.parsed_header,"trailer",[])) of + {ok,Trailers}-> + Trailers; + _-> + [] + end. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% The code below is a a good way to read in chunked encoding but +%% that require that the encoding comes from a stream and not from a list +%%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + +%%---------------------------------------------------------------------- +%% The body is encoded by chubnked encoding read it in +%% ChunkedData= Chunked extensions +%% Body= the inread chunked body +%% Max: Max numbers of bytes to read +%% Length: Numbers of bytes already readed +%% Size Numbers of byte to read for the chunk +%%---------------------------------------------------------------------- + + + +read_chunked_entity(SocketType, Socket, Timeout, Max, Length, ChunkedData, + Body, ConfigDB, Info) -> + T = t(), + case get_chunk_size(SocketType,Socket,Timeout,[]) of + Size when integer(Size), Size>0 -> + case read_chunked_entity_body(SocketType, Socket, + Timeout-(t()-T), + Max, length(Body), Size) of + {ok,Chunk} -> + ?DEBUG("read_chunked_entity/9 Got a chunk: ~p " ,[Chunk]), + %% Two bytes are left of the chunk, that is the CRLF + %% at the end that is not a part of the message + %% So we read it and do nothing with it. + httpd_socket:recv(SocketType,Socket,2,Timeout-(t()-T)), + read_chunked_entity(SocketType, Socket, Timeout-(t()-T), + Max, Length, ChunkedData, Body++Chunk, + ConfigDB, Info); + Error -> + ?DEBUG("read_chunked_entity/9 Error: ~p " ,[Error]), + httpd_socket:close(SocketType,Socket), + {socket_closed,error} + end; + Size when integer(Size), Size == 0 -> + %% Must read in any trailer fields here + read_chunk_trailer(SocketType, Socket, Timeout, + Max, Info, ChunkedData, Body, ConfigDB); + Error -> + Error + end. + + +%% If a user wants to send header data after the chunked data we +%% must pick it out +read_chunk_trailer(SocketType, Socket, Timeout, Max, Info, ChunkedData, + Body, ConfigDB) -> + ?DEBUG("read_chunk_trailer/8: ~p " ,[Body]), + MaxHdrSz = httpd_util:lookup(ConfigDB,max_header_size,10240), + case httpd_util:key1search(Info#mod.parsed_header,"trailer")of + undefined -> + {ok,Body}; + Fields -> + case read_trailer(SocketType, Socket, Timeout, + MaxHdrSz, [], [], + string:tokens( + httpd_util:to_lower(Fields),",")) of + {ok,[]} -> + {ok,Body}; + {ok,HeaderFields} -> + % ParsedExtraHeaders = + % httpd_parse:tagup_header(httpd_parse:split_lines(HeaderFields)), + {ok,HeaderFields,Body}; + Error -> + Error + end + end. + +read_chunked_entity_body(SocketType, Socket, Timeout, Max, Length, Size) + when integer(Max) -> + read_entity_body(SocketType, Socket, Timeout, Max-Length, Size, []); + +read_chunked_entity_body(SocketType, Socket, Timeout, Max, _Length, Size) -> + read_entity_body(SocketType, Socket, Timeout, Max, Size, []). + +%% If we read in the \r\n the httpd_util:hexlist_to_integer +%% Will remove it and we get rid of it emmediatly :-) +get_chunk_size(SocketType, Socket, Timeout, Size) -> + T = t(), + ?DEBUG("get_chunk_size: ~p " ,[Size]), + case httpd_socket:recv(SocketType,Socket,1,Timeout) of + {ok,[Digit]} when Digit==$\n -> + httpd_util:hexlist_to_integer(lists:reverse(Size)); + {ok,[Digit]} -> + get_chunk_size(SocketType,Socket,Timeout-(t()-T),[Digit|Size]); + {error,closed} -> + {socket_closed,normal}; + {error,etimedout} -> + {socket_closed, timeout}; + {error,Reason} -> + {socket_closed, Reason}; + Other -> + {socket_closed,Other} + end. + + + + +%%---------------------------------------------------------------------- +%% Reads the HTTP-trailer +%% Would be easy to tweak the read_head to do this but in this way +%% the chunked encoding can be updated better. +%%---------------------------------------------------------------------- + + +%% When end is reached +%% read_trailer(SocketType,Socket,Timeout,MaxHdrSz,Headers,Last,[]) -> +%% {ok,Headers}; + +%% When header to big +read_trailer(_,_,_,MaxHdrSz,Headers,Bs,_Fields) + when MaxHdrSz < length(Headers) -> + ?vlog("header to long: " + "~n MaxHdrSz: ~p" + "~n length(Bs): ~p", [MaxHdrSz,length(Bs)]), + throw({error,{header_too_long,MaxHdrSz,length(Bs)}}); + +%% The last Crlf is there +read_trailer(_, _, _, _, Headers, [$\n, $\r], _) -> + {ok,Headers}; + +read_trailer(SocketType, Socket, Timeout, MaxHdrSz, Headers, + [$\n, $\r|Rest], Fields) -> + case getTrailerField(lists:reverse(Rest))of + {error,Reason}-> + {error,"Bad trailer"}; + {HeaderField,Value}-> + case lists:member(HeaderField,Fields) of + true -> + read_trailer(SocketType,Socket,Timeout,MaxHdrSz, + [{HeaderField,Value} |Headers],[], + lists:delete(HeaderField,Fields)); + false -> + read_trailer(SocketType,Socket,Timeout,MaxHdrSz, + Headers,[],Fields) + end + end; + +% read_trailer(SocketType,Socket,Timeout,MaxHdrSz,Headers,[$\n, $\r|Rest],Fields) -> +% case Rest of +% [] -> +% read_trailer(SocketType,Socket,Timeout,MaxHdrSz,Headers,Rest,Fields); +% Field -> +% case getTrailerField(lists:reverse(Rest))of +% {error,Reason}-> +% {error,"Bad trailer"}; +% {HeaderField,Value}-> +% case lists:member(HeaderField,Fields) of +% true -> +% read_trailer(SocketType,Socket,Timeout,MaxHdrSz, +% [{HeaderField,Value} |Headers],[], +% lists:delete(HeaderField,Fields)); +% false -> +% read_trailer(SocketType,Socket,Timeout,MaxHdrSz, +% Headers,[],Fields) +% end +% end +% end; + +read_trailer(SocketType,Socket,Timeout,MaxHdrSz,Headers,Bs,Fields) -> + %% ?vlog("read_header -> entry with Timeout: ~p",[Timeout]), + T = t(), + case (catch httpd_socket:recv(SocketType,Socket,1,Timeout)) of + {ok,[B]} -> + read_trailer(SocketType, Socket, Timeout-(t()-T), + MaxHdrSz, Headers, [B|Bs], Fields); + {error,closed} -> + {socket_closed,normal}; + {error,etimedout} -> + {socket_closed, timeout}; + {error,Reason} -> + {socket_closed, Reason}; + Other -> + {socket_closed,Other} + end. + +getTrailerField(HeaderField)-> + case string:str(HeaderField,":") of + 0-> + {error,"badheaderfield"}; + Number -> + {httpd_util:to_lower(string:substr(HeaderField,1,Number-1)), + httpd_util:to_lower(string:substr(HeaderField,Number+1))} + end. + + + + +%% Time in milli seconds +t() -> + {A,B,C} = erlang:now(), + A*1000000000+B*1000+(C div 1000). + +%%---------------------------------------------------------------------- +%% If the user sends an expect header-field with the value 100-continue +%% We must send a 100 status message if he is a HTTP/1.1 client. + +%% If it is an HTTP/1.0 client it's little more difficult. +%% If expect is not defined it is easy but in the other case shall we +%% Break or the transmission or let it continue the standard is not clear +%% if to break connection or wait for data. +%%---------------------------------------------------------------------- +expect(HTTPVersion,ParsedHeader,ConfigDB)-> + case HTTPVersion of + [$H,$T,$T,$P,$\/,$1,$.,N|_Whatever]when N>=1-> + case httpd_util:key1search(ParsedHeader,"expect") of + "100-continue" -> + continue; + undefined -> + no_expect_header; + NewValue -> + break + end; + _OldVersion -> + case httpd_util:key1search(ParsedHeader,"expect") of + undefined -> + no_expect_header; + NewValue -> + case httpd_util:lookup(ConfigDB,expect,continue) of + continue-> + no_expect_header; + _ -> + http_1_0_expect_header + end + end + end. + + +%%---------------------------------------------------------------------- +%% According to the http/1.1 standard all applications must understand +%% Chunked encoded data. (Last line chapter 3.6.1). +transfer_coding(#mod{parsed_header = Ph}) -> + case httpd_util:key1search(Ph, "transfer-encoding", none) of + none -> + none; + [$c,$h,$u,$n,$k,$e,$d|Data]-> + {chunked,Data}; + _ -> + unknown_coding + end. + + + +handle_read_error({header_too_long,Max,Rem}, + SocketType,Socket,ConfigDB,Peername) -> + String = io_lib:format("header too long: ~p : ~p",[Max,Rem]), + handle_read_error(ConfigDB,String,SocketType,Socket,Peername, + max_header_action,close); +handle_read_error({body_too_long,Max,Actual}, + SocketType,Socket,ConfigDB,Peername) -> + String = io_lib:format("body too long: ~p : ~p",[Max,Actual]), + handle_read_error(ConfigDB,String,SocketType,Socket,Peername, + max_body_action,close); +handle_read_error(Error,SocketType,Socket,ConfigDB,Peername) -> + ok. + + +handle_read_error(ConfigDB, ReasonString, SocketType, Socket, Peername, + Item, Default) -> + ?vlog("error reading request: ~s",[ReasonString]), + E = lists:flatten( + io_lib:format("Error reading request: ~s",[ReasonString])), + error_log(mod_log, SocketType, Socket, ConfigDB, Peername, E), + error_log(mod_disk_log, SocketType, Socket, ConfigDB, Peername, E), + case httpd_util:lookup(ConfigDB,Item,Default) of + reply414 -> + send_read_status(SocketType, Socket, 414, ReasonString, ConfigDB); + _ -> + ok + end. + +send_read_status(SocketType, Socket, Code, ReasonString, ConfigDB) -> + httpd_response:send_status(SocketType, Socket, Code, ReasonString, + ConfigDB). + + +error_log(Mod, SocketType, Socket, ConfigDB, Peername, String) -> + Modules = httpd_util:lookup(ConfigDB, modules, + [mod_get, mod_head, mod_log]), + case lists:member(Mod, Modules) of + true -> + Mod:error_log(SocketType, Socket, ConfigDB, Peername, String); + _ -> + ok + end. + + +sz(L) when list(L) -> + length(L); +sz(B) when binary(B) -> + size(B); +sz(O) -> + {unknown_size,O}. + + +%% Socket utility functions: + +close(SocketType, Socket, ConfigDB) -> + case httpd_socket:close(SocketType, Socket) of + ok -> + ok; + {error, Reason} -> + ?vlog("error while closing socket: ~p",[Reason]), + ok + end. + +close_sleep({ssl, _}, Time) -> + sleep(Time); +close_sleep(_, _) -> + ok. + + +sleep(T) -> receive after T -> ok end. + + +dec(N) when integer(N) -> + N-1; +dec(N) -> + N. + + +content_length(#mod{parsed_header = Ph}) -> + list_to_integer(httpd_util:key1search(Ph, "content-length","0")). + + +remove_newline(List)-> + lists:dropwhile(fun newline/1,List). + +newline($\r) -> + true; +newline($\n) -> + true; +newline(_Sign) -> + false. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_response.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_response.erl new file mode 100644 index 0000000000..1685cbc129 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_response.erl @@ -0,0 +1,437 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_response.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(httpd_response). +-export([send/1, send_status/3, send_status/5]). + +%%code is the key for the statuscode ex: 200 404 ... +-define(HTTP11HEADERFIELDS,[content_length, accept_ranges, cache_control, date, + pragma, trailer, transfer_encoding, etag, location, + retry_after, server, allow, + content_encoding, content_language, + content_location, content_MD5, content_range, + content_type, expires, last_modified]). + +-define(HTTP10HEADERFIELDS,[content_length, date, pragma, transfer_encoding, + location, server, allow, content_encoding, + content_type, last_modified]). + +-define(PROCEED_RESPONSE(StatusCode, Info), + {proceed, + [{response,{already_sent, StatusCode, + httpd_util:key1search(Info#mod.data,content_lenght)}}]}). + + +-include("httpd.hrl"). + +-define(VMODULE,"RESPONSE"). +-include("httpd_verbosity.hrl"). + +%% send + +send(#mod{config_db = ConfigDB} = Info) -> + ?vtrace("send -> Request line: ~p", [Info#mod.request_line]), + Modules = httpd_util:lookup(ConfigDB,modules,[mod_get, mod_head, mod_log]), + case traverse_modules(Info, Modules) of + done -> + Info; + {proceed, Data} -> + case httpd_util:key1search(Data, status) of + {StatusCode, PhraseArgs, Reason} -> + ?vdebug("send -> proceed/status: ~n" + "~n StatusCode: ~p" + "~n PhraseArgs: ~p" + "~n Reason: ~p", + [StatusCode, PhraseArgs, Reason]), + send_status(Info, StatusCode, PhraseArgs), + Info; + + undefined -> + case httpd_util:key1search(Data, response) of + {already_sent, StatusCode, Size} -> + ?vtrace("send -> already sent: " + "~n StatusCode: ~p" + "~n Size: ~p", + [StatusCode, Size]), + Info; + {response, Header, Body} -> %% New way + send_response(Info, Header, Body), + Info; + {StatusCode, Response} -> %% Old way + send_response_old(Info, StatusCode, Response), + Info; + undefined -> + ?vtrace("send -> undefined response", []), + send_status(Info, 500, none), + Info + end + end + end. + + +%% traverse_modules + +traverse_modules(Info,[]) -> + {proceed,Info#mod.data}; +traverse_modules(Info,[Module|Rest]) -> + case (catch apply(Module,do,[Info])) of + {'EXIT', Reason} -> + ?vlog("traverse_modules -> exit reason: ~p",[Reason]), + String = + lists:flatten( + io_lib:format("traverse exit from apply: ~p:do => ~n~p", + [Module, Reason])), + report_error(mod_log, Info#mod.config_db, String), + report_error(mod_disk_log, Info#mod.config_db, String), + done; + done -> + done; + {break,NewData} -> + {proceed,NewData}; + {proceed,NewData} -> + traverse_modules(Info#mod{data=NewData},Rest) + end. + +%% send_status %% + + +send_status(#mod{socket_type = SocketType, + socket = Socket, + connection = Conn} = Info, 100, _PhraseArgs) -> + ?DEBUG("send_status -> StatusCode: ~p~n",[100]), + Header = httpd_util:header(100, Conn), + httpd_socket:deliver(SocketType, Socket, + [Header, "Content-Length:0\r\n\r\n"]); + +send_status(#mod{socket_type = SocketType, + socket = Socket, + config_db = ConfigDB} = Info, StatusCode, PhraseArgs) -> + send_status(SocketType, Socket, StatusCode, PhraseArgs, ConfigDB). + +send_status(SocketType, Socket, StatusCode, PhraseArgs, ConfigDB) -> + ?DEBUG("send_status -> ~n" + " StatusCode: ~p~n" + " PhraseArgs: ~p", + [StatusCode, PhraseArgs]), + Header = httpd_util:header(StatusCode, "text/html", false), + ReasonPhrase = httpd_util:reason_phrase(StatusCode), + Message = httpd_util:message(StatusCode, PhraseArgs, ConfigDB), + Body = get_body(ReasonPhrase, Message), + Header1 = + Header ++ + "Content-Length:" ++ + integer_to_list(length(Body)) ++ + "\r\n\r\n", + httpd_socket:deliver(SocketType, Socket, [Header1, Body]). + + +get_body(ReasonPhrase, Message)-> + "<HTML> + <HEAD> + <TITLE>"++ReasonPhrase++"</TITLE> + </HEAD> + <BODY> + <H1>"++ReasonPhrase++"</H1>\n"++Message++"\n</BODY> + </HTML>\n". + + +%%% Create a response from the Key/Val tuples In the Head List +%%% Body is a tuple {body,Fun(),Args} + +%% send_response +%% Allowed Fields + +% HTTP-Version StatusCode Reason-Phrase +% *((general-headers +% response-headers +% entity-headers)CRLF) +% CRLF +% ?(BODY) + +% General Header fields +% ====================== +% Cache-Control cache_control +% Connection %%Is set dependiong on the request +% Date +% Pramga +% Trailer +% Transfer-Encoding + +% Response Header field +% ===================== +% Accept-Ranges +% (Age) Mostly for proxys +% Etag +% Location +% (Proxy-Authenticate) Only for proxies +% Retry-After +% Server +% Vary +% WWW-Authenticate +% +% Entity Header Fields +% ==================== +% Allow +% Content-Encoding +% Content-Language +% Content-Length +% Content-Location +% Content-MD5 +% Content-Range +% Content-Type +% Expires +% Last-Modified + + +send_response(Info, Header, Body) -> + ?vtrace("send_response -> (new) entry with" + "~n Header: ~p", [Header]), + case httpd_util:key1search(Header, code) of + undefined -> + %% No status code + %% Ooops this must be very bad: + %% generate a 404 content not availible + send_status(Info, 404, "The file is not availible"); + StatusCode -> + case send_header(Info, StatusCode, Header) of + ok -> + send_body(Info, StatusCode, Body); + Error -> + ?vlog("head delivery failure: ~p", [Error]), + done + end + end. + + +send_header(#mod{socket_type = Type, socket = Sock, + http_version = Ver, connection = Conn} = Info, + StatusCode, Head0) -> + ?vtrace("send_haeder -> entry with" + "~n Ver: ~p" + "~n Conn: ~p", [Ver, Conn]), + Head1 = create_header(Ver, Head0), + StatusLine = [Ver, " ", + io_lib:write(StatusCode), " ", + httpd_util:reason_phrase(StatusCode), "\r\n"], + Connection = get_connection(Conn, Ver), + Head = list_to_binary([StatusLine, Head1, Connection,"\r\n"]), + ?vtrace("deliver head", []), + httpd_socket:deliver(Type, Sock, Head). + + +send_body(_, _, nobody) -> + ?vtrace("send_body -> no body", []), + ok; + +send_body(#mod{socket_type = Type, socket = Sock}, + StatusCode, Body) when list(Body) -> + ?vtrace("deliver body of size ~p", [length(Body)]), + httpd_socket:deliver(Type, Sock, Body); + +send_body(#mod{socket_type = Type, socket = Sock} = Info, + StatusCode, {Fun, Args}) -> + case (catch apply(Fun, Args)) of + close -> + httpd_socket:close(Type, Sock), + done; + + sent -> + ?PROCEED_RESPONSE(StatusCode, Info); + + {ok, Body} -> + ?vtrace("deliver body", []), + case httpd_socket:deliver(Type, Sock, Body) of + ok -> + ?PROCEED_RESPONSE(StatusCode, Info); + Error -> + ?vlog("body delivery failure: ~p", [Error]), + done + end; + + Error -> + ?vlog("failure of apply(~p,~p): ~p", [Fun, Args, Error]), + done + end; +send_body(I, S, B) -> + ?vinfo("BAD ARGS: " + "~n I: ~p" + "~n S: ~p" + "~n B: ~p", [I, S, B]), + exit({bad_args, {I, S, B}}). + + +%% Return a HTTP-header field that indicates that the +%% connection will be inpersistent +get_connection(true,"HTTP/1.0")-> + "Connection:close\r\n"; +get_connection(false,"HTTP/1.1") -> + "Connection:close\r\n"; +get_connection(_,_) -> + "". + + +create_header("HTTP/1.1", Data) -> + create_header1(?HTTP11HEADERFIELDS, Data); +create_header(_, Data) -> + create_header1(?HTTP10HEADERFIELDS, Data). + +create_header1(Fields, Data) -> + ?DEBUG("create_header() -> " + "~n Fields :~p~n Data: ~p ~n", [Fields, Data]), + mapfilter(fun(Field)-> + transform({Field, httpd_util:key1search(Data, Field)}) + end, Fields, undefined). + + +%% Do a map and removes the values that evaluates to RemoveVal +mapfilter(Fun,List,RemoveVal)-> + mapfilter(Fun,List,[],RemoveVal). + +mapfilter(Fun,[],[RemoveVal|Acc],RemoveVal)-> + Acc; +mapfilter(Fun,[],Acc,_RemoveVal)-> + Acc; + +mapfilter(Fun,[Elem|Rest],[RemoveVal|Acc],RemoveVal)-> + mapfilter(Fun,Rest,[Fun(Elem)|Acc],RemoveVal); +mapfilter(Fun,[Elem|Rest],Acc,RemoveVal)-> + mapfilter(Fun,Rest,[Fun(Elem)|Acc],RemoveVal). + + +transform({content_type,undefined})-> + ["Content-Type:text/plain\r\n"]; + +transform({date,undefined})-> + ["Date:",httpd_util:rfc1123_date(),"\r\n"]; + +transform({date,RFCDate})-> + ["Date:",RFCDate,"\r\n"]; + + +transform({_Key,undefined})-> + undefined; +transform({accept_ranges,Value})-> + ["Accept-Ranges:",Value,"\r\n"]; +transform({cache_control,Value})-> + ["Cache-Control:",Value,"\r\n"]; +transform({pragma,Value})-> + ["Pragma:",Value,"\r\n"]; +transform({trailer,Value})-> + ["Trailer:",Value,"\r\n"]; +transform({transfer_encoding,Value})-> + ["Pragma:",Value,"\r\n"]; +transform({etag,Value})-> + ["ETag:",Value,"\r\n"]; +transform({location,Value})-> + ["Retry-After:",Value,"\r\n"]; +transform({server,Value})-> + ["Server:",Value,"\r\n"]; +transform({allow,Value})-> + ["Allow:",Value,"\r\n"]; +transform({content_encoding,Value})-> + ["Content-Encoding:",Value,"\r\n"]; +transform({content_language,Value})-> + ["Content-Language:",Value,"\r\n"]; +transform({retry_after,Value})-> + ["Retry-After:",Value,"\r\n"]; +transform({server,Value})-> + ["Server:",Value,"\r\n"]; +transform({allow,Value})-> + ["Allow:",Value,"\r\n"]; +transform({content_encoding,Value})-> + ["Content-Encoding:",Value,"\r\n"]; +transform({content_language,Value})-> + ["Content-Language:",Value,"\r\n"]; +transform({content_location,Value})-> + ["Content-Location:",Value,"\r\n"]; +transform({content_length,Value})-> + ["Content-Length:",Value,"\r\n"]; +transform({content_MD5,Value})-> + ["Content-MD5:",Value,"\r\n"]; +transform({content_range,Value})-> + ["Content-Range:",Value,"\r\n"]; +transform({content_type,Value})-> + ["Content-Type:",Value,"\r\n"]; +transform({expires,Value})-> + ["Expires:",Value,"\r\n"]; +transform({last_modified,Value})-> + ["Last-Modified:",Value,"\r\n"]. + + + +%%---------------------------------------------------------------------- +%% This is the old way of sending data it is strongly encouraged to +%% Leave this method and go on to the newer form of response +%% OTP-4408 +%%---------------------------------------------------------------------- + +send_response_old(#mod{socket_type = Type, + socket = Sock, + method = "HEAD"} = Info, + StatusCode, Response) -> + ?vtrace("send_response_old(HEAD) -> entry with" + "~n StatusCode: ~p" + "~n Response: ~p", + [StatusCode,Response]), + case httpd_util:split(lists:flatten(Response),"\r\n\r\n|\n\n",2) of + {ok, [Head, Body]} -> + Header = + httpd_util:header(StatusCode,Info#mod.connection) ++ + "Content-Length:" ++ content_length(Body), + httpd_socket:deliver(Type, Sock, [Header,Head,"\r\n"]); + + Error -> + send_status(Info, 500, "Internal Server Error") + end; + +send_response_old(#mod{socket_type = Type, + socket = Sock} = Info, + StatusCode, Response) -> + ?vtrace("send_response_old -> entry with" + "~n StatusCode: ~p" + "~n Response: ~p", + [StatusCode,Response]), + case httpd_util:split(lists:flatten(Response),"\r\n\r\n|\n\n",2) of + {ok, [_Head, Body]} -> + Header = + httpd_util:header(StatusCode,Info#mod.connection) ++ + "Content-Length:" ++ content_length(Body), + httpd_socket:deliver(Type, Sock, [Header, Response]); + + {ok, Body} -> + Header = + httpd_util:header(StatusCode,Info#mod.connection) ++ + "Content-Length:" ++ content_length(Body) ++ "\r\n", + httpd_socket:deliver(Type, Sock, [Header, Response]); + + {error, Reason} -> + send_status(Info, 500, "Internal Server Error") + end. + +content_length(Body)-> + integer_to_list(httpd_util:flatlength(Body))++"\r\n". + + +report_error(Mod, ConfigDB, Error) -> + Modules = httpd_util:lookup(ConfigDB, modules, + [mod_get, mod_head, mod_log]), + case lists:member(Mod, Modules) of + true -> + Mod:report_error(ConfigDB, Error); + _ -> + ok + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_socket.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_socket.erl new file mode 100644 index 0000000000..375b43784b --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_socket.erl @@ -0,0 +1,381 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_socket.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(httpd_socket). +-export([start/1, + listen/2, listen/3, accept/2, accept/3, + deliver/3, send/3, recv/4, + close/2, + peername/2, resolve/1, config/1, + controlling_process/3, + active_once/2]). + +-include("httpd.hrl"). + +-define(VMODULE,"SOCKET"). +-include("httpd_verbosity.hrl"). + +-include_lib("kernel/include/inet.hrl"). + +%% start -> ok | {error,Reason} + +start(ip_comm) -> + case inet_db:start() of + {ok,_Pid} -> + ok; + {error,{already_started,_Pid}} -> + ok; + Error -> + Error + end; +start({ssl,_SSLConfig}) -> + case ssl:start() of + ok -> + ok; + {ok, _} -> + ok; + {error,{already_started,_}} -> + ok; + Error -> + Error + end. + +%% listen + +listen(SocketType,Port) -> + listen(SocketType,undefined,Port). + +listen(ip_comm,Addr,Port) -> + ?DEBUG("listening(ip_comm) to port ~p", [Port]), + Opt = sock_opt(Addr,[{backlog,128},{reuseaddr,true}]), + case gen_tcp:listen(Port,Opt) of + {ok,ListenSocket} -> + ListenSocket; + Error -> + Error + end; +listen({ssl,SSLConfig},Addr,Port) -> + ?DEBUG("listening(ssl) to port ~p" + "~n SSLConfig: ~p", [Port,SSLConfig]), + Opt = sock_opt(Addr,SSLConfig), + case ssl:listen(Port, Opt) of + {ok,ListenSocket} -> + ListenSocket; + Error -> + Error + end. + + +sock_opt(undefined,Opt) -> [{packet,0},{active,false}|Opt]; +sock_opt(Addr,Opt) -> [{ip, Addr},{packet,0},{active,false}|Opt]. + +%% -define(packet_type_http,true). +%% -define(packet_type_httph,true). + +%% -ifdef(packet_type_http). +%% sock_opt(undefined,Opt) -> [{packet,http},{active,false}|Opt]; +%% sock_opt(Addr,Opt) -> [{ip, Addr},{packet,http},{active,false}|Opt]. +%% -elif(packet_type_httph). +%% sock_opt(undefined,Opt) -> [{packet,httph},{active,false}|Opt]; +%% sock_opt(Addr,Opt) -> [{ip, Addr},{packet,httph},{active,false}|Opt]. +%% -else. +%% sock_opt(undefined,Opt) -> [{packet,0},{active,false}|Opt]; +%% sock_opt(Addr,Opt) -> [{ip, Addr},{packet,0},{active,false}|Opt]. +%% -endif. + + +%% active_once + +active_once(Type, Sock) -> + active(Type, Sock, once). + +active(ip_comm, Sock, Active) -> + inet:setopts(Sock, [{active, Active}]); +active({ssl, _SSLConfig}, Sock, Active) -> + ssl:setopts(Sock, [{active, Active}]). + +%% accept + +accept(A, B) -> + accept(A, B, infinity). + + +accept(ip_comm,ListenSocket, T) -> + ?DEBUG("accept(ip_comm) on socket ~p", [ListenSocket]), + case gen_tcp:accept(ListenSocket, T) of + {ok,Socket} -> + Socket; + Error -> + ?vtrace("accept(ip_comm) failed for reason:" + "~n Error: ~p",[Error]), + Error + end; +accept({ssl,_SSLConfig},ListenSocket, T) -> + ?DEBUG("accept(ssl) on socket ~p", [ListenSocket]), + case ssl:accept(ListenSocket, T) of + {ok,Socket} -> + Socket; + Error -> + ?vtrace("accept(ssl) failed for reason:" + "~n Error: ~p",[Error]), + Error + end. + + +%% controlling_process + +controlling_process(ip_comm, Socket, Pid) -> + gen_tcp:controlling_process(Socket, Pid); +controlling_process({ssl, _}, Socket, Pid) -> + ssl:controlling_process(Socket, Pid). + + +%% deliver + +deliver(SocketType, Socket, IOListOrBinary) -> + case send(SocketType, Socket, IOListOrBinary) of +% {error, einval} -> +% ?vlog("deliver failed for reason: einval" +% "~n SocketType: ~p" +% "~n Socket: ~p" +% "~n Data: ~p", +% [SocketType, Socket, type(IOListOrBinary)]), +% (catch close(SocketType, Socket)), +% socket_closed; + {error, _Reason} -> + ?vlog("deliver(~p) failed for reason:" + "~n Reason: ~p",[SocketType,_Reason]), + (catch close(SocketType, Socket)), + socket_closed; + _ -> + ok + end. + +% type(L) when list(L) -> +% {list, L}; +% type(B) when binary(B) -> +% Decoded = +% case (catch binary_to_term(B)) of +% {'EXIT', _} -> +% %% Oups, not a term, try list +% case (catch binary_to_list(B)) of +% %% Oups, not a list either, give up +% {'EXIT', _} -> +% {size, size(B)}; +% L -> +% {list, L} +% end; + +% T -> +% {term, T} +% end, +% {binary, Decoded}; +% type(T) when tuple(T) -> +% {tuple, T}; +% type(I) when integer(I) -> +% {integer, I}; +% type(F) when float(F) -> +% {float, F}; +% type(P) when pid(P) -> +% {pid, P}; +% type(P) when port(P) -> +% {port, P}; +% type(R) when reference(R) -> +% {reference, R}; +% type(T) -> +% {term, T}. + + + +send(ip_comm,Socket,Data) -> + ?DEBUG("send(ip_comm) -> ~p bytes on socket ~p",[data_size(Data),Socket]), + gen_tcp:send(Socket,Data); +send({ssl,SSLConfig},Socket,Data) -> + ?DEBUG("send(ssl) -> ~p bytes on socket ~p",[data_size(Data),Socket]), + ssl:send(Socket, Data). + +recv(ip_comm,Socket,Length,Timeout) -> + ?DEBUG("recv(ip_comm) -> read from socket ~p",[Socket]), + gen_tcp:recv(Socket,Length,Timeout); +recv({ssl,SSLConfig},Socket,Length,Timeout) -> + ?DEBUG("recv(ssl) -> read from socket ~p",[Socket]), + ssl:recv(Socket,Length,Timeout). + +-ifdef(inets_debug). +data_size(L) when list(L) -> + httpd_util:flatlength(L); +data_size(B) when binary(B) -> + size(B); +data_size(O) -> + {unknown_size,O}. +-endif. + + +%% peername + +peername(ip_comm, Socket) -> + case inet:peername(Socket) of + {ok,{{A,B,C,D},Port}} -> + PeerName = integer_to_list(A)++"."++integer_to_list(B)++"."++ + integer_to_list(C)++"."++integer_to_list(D), + ?DEBUG("peername(ip_comm) on socket ~p: ~p", + [Socket,{Port,PeerName}]), + {Port,PeerName}; + {error,Reason} -> + ?vlog("failed getting peername:" + "~n Reason: ~p" + "~n Socket: ~p", + [Reason,Socket]), + {-1,"unknown"} + end; +peername({ssl,_SSLConfig},Socket) -> + case ssl:peername(Socket) of + {ok,{{A,B,C,D},Port}} -> + PeerName = integer_to_list(A)++"."++integer_to_list(B)++"."++ + integer_to_list(C)++"."++integer_to_list(D), + ?DEBUG("peername(ssl) on socket ~p: ~p", + [Socket, {Port,PeerName}]), + {Port,PeerName}; + {error,_Reason} -> + {-1,"unknown"} + end. + +%% resolve + +resolve(_) -> + {ok,Name} = inet:gethostname(), + Name. + +%% close + +close(ip_comm,Socket) -> + Res = + case (catch gen_tcp:close(Socket)) of + ok -> ok; + {error,Reason} -> {error,Reason}; + {'EXIT',{noproc,_}} -> {error,closed}; + {'EXIT',Reason} -> {error,Reason}; + Otherwise -> {error,Otherwise} + end, + ?vtrace("close(ip_comm) result: ~p",[Res]), + Res; +close({ssl,_SSLConfig},Socket) -> + Res = + case (catch ssl:close(Socket)) of + ok -> ok; + {error,Reason} -> {error,Reason}; + {'EXIT',{noproc,_}} -> {error,closed}; + {'EXIT',Reason} -> {error,Reason}; + Otherwise -> {error,Otherwise} + end, + ?vtrace("close(ssl) result: ~p",[Res]), + Res. + +%% config (debug: {certfile, "/var/tmp/server_root/conf/ssl_server.pem"}) + +config(ConfigDB) -> + case httpd_util:lookup(ConfigDB,com_type,ip_comm) of + ssl -> + case ssl_certificate_file(ConfigDB) of + undefined -> + {error, + ?NICE("Directive SSLCertificateFile " + "not found in the config file")}; + SSLCertificateFile -> + {ssl, + SSLCertificateFile++ + ssl_certificate_key_file(ConfigDB)++ + ssl_verify_client(ConfigDB)++ + ssl_ciphers(ConfigDB)++ + ssl_password(ConfigDB)++ + ssl_verify_depth(ConfigDB)++ + ssl_ca_certificate_file(ConfigDB)} + end; + ip_comm -> + ip_comm + end. + +ssl_certificate_file(ConfigDB) -> + case httpd_util:lookup(ConfigDB,ssl_certificate_file) of + undefined -> + undefined; + SSLCertificateFile -> + [{certfile,SSLCertificateFile}] + end. + +ssl_certificate_key_file(ConfigDB) -> + case httpd_util:lookup(ConfigDB,ssl_certificate_key_file) of + undefined -> + []; + SSLCertificateKeyFile -> + [{keyfile,SSLCertificateKeyFile}] + end. + +ssl_verify_client(ConfigDB) -> + case httpd_util:lookup(ConfigDB,ssl_verify_client) of + undefined -> + []; + SSLVerifyClient -> + [{verify,SSLVerifyClient}] + end. + +ssl_ciphers(ConfigDB) -> + case httpd_util:lookup(ConfigDB,ssl_ciphers) of + undefined -> + []; + Ciphers -> + [{ciphers, Ciphers}] + end. + +ssl_password(ConfigDB) -> + case httpd_util:lookup(ConfigDB,ssl_password_callback_module) of + undefined -> + []; + Module -> + case httpd_util:lookup(ConfigDB, ssl_password_callback_function) of + undefined -> + []; + Function -> + case catch apply(Module, Function, []) of + Password when list(Password) -> + [{password, Password}]; + Error -> + error_report(ssl_password,Module,Function,Error), + [] + end + end + end. + +ssl_verify_depth(ConfigDB) -> + case httpd_util:lookup(ConfigDB, ssl_verify_client_depth) of + undefined -> + []; + Depth -> + [{depth, Depth}] + end. + +ssl_ca_certificate_file(ConfigDB) -> + case httpd_util:lookup(ConfigDB, ssl_ca_certificate_file) of + undefined -> + []; + File -> + [{cacertfile, File}] + end. + + +error_report(Where,M,F,Error) -> + error_logger:error_report([{?MODULE, Where}, {apply, {M, F, []}}, Error]). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_sup.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_sup.erl new file mode 100644 index 0000000000..e7a3557c9d --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_sup.erl @@ -0,0 +1,202 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_sup.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +%%---------------------------------------------------------------------- +%% Purpose: The top supervisor for the inets application +%%---------------------------------------------------------------------- + +-module(httpd_sup). + +-behaviour(supervisor). + +-include("httpd_verbosity.hrl"). + +%% public +-export([start/2, start_link/2, start2/2, start_link2/2, stop/1, stop/2, stop2/1]). +-export([init/1]). + + +-define(D(F, A), io:format("~p:" ++ F ++ "~n", [?MODULE|A])). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% supervisor callback functions + +start(ConfigFile, Verbosity) -> + case start_link(ConfigFile, Verbosity) of + {ok, Pid} -> + unlink(Pid), + {ok, Pid}; + + Else -> + Else + end. + + +start_link(ConfigFile, Verbosity) -> + case get_addr_and_port(ConfigFile) of + {ok, ConfigList, Addr, Port} -> + Name = make_name(Addr, Port), + SupName = {local, Name}, + supervisor:start_link(SupName, ?MODULE, + [ConfigFile, ConfigList, + Verbosity, Addr, Port]); + + {error, Reason} -> + error_logger:error_report(Reason), + {stop, Reason}; + + Else -> + error_logger:error_report(Else), + {stop, Else} + end. + + +start2(ConfigList, Verbosity) -> + case start_link2(ConfigList, Verbosity) of + {ok, Pid} -> + unlink(Pid), + {ok, Pid}; + + Else -> + Else + end. + + +start_link2(ConfigList, Verbosity) -> + case get_addr_and_port2(ConfigList) of + {ok, Addr, Port} -> + Name = make_name(Addr, Port), + SupName = {local, Name}, + supervisor:start_link(SupName, ?MODULE, + [undefined, ConfigList, Verbosity, Addr, Port]); + + {error, Reason} -> + error_logger:error_report(Reason), + {stop, Reason}; + + Else -> + error_logger:error_report(Else), + {stop, Else} + end. + + + +stop(Pid) when pid(Pid) -> + do_stop(Pid); +stop(ConfigFile) when list(ConfigFile) -> + case get_addr_and_port(ConfigFile) of + {ok, _, Addr, Port} -> + stop(Addr, Port); + + Error -> + Error + end; +stop(StartArgs) -> + ok. + + +stop(Addr, Port) when integer(Port) -> + Name = make_name(Addr, Port), + case whereis(Name) of + Pid when pid(Pid) -> + do_stop(Pid), + ok; + _ -> + not_started + end. + +stop2(ConfigList) when list(ConfigList) -> + {ok, Addr, Port} = get_addr_and_port2(ConfigList), + stop(Addr, Port). + + +do_stop(Pid) -> + exit(Pid, shutdown). + + +init([ConfigFile, ConfigList, Verbosity, Addr, Port]) -> + init(ConfigFile, ConfigList, Verbosity, Addr, Port); +init(BadArg) -> + {error, {badarg, BadArg}}. + +init(ConfigFile, ConfigList, Verbosity, Addr, Port) -> + Flags = {one_for_one, 0, 1}, + AccSupVerbosity = get_acc_sup_verbosity(Verbosity), + MiscSupVerbosity = get_misc_sup_verbosity(Verbosity), + Sups = [sup_spec(httpd_acceptor_sup, Addr, Port, AccSupVerbosity), + sup_spec(httpd_misc_sup, Addr, Port, MiscSupVerbosity), + worker_spec(httpd_manager, Addr, Port, ConfigFile, ConfigList, + Verbosity, [gen_server])], + {ok, {Flags, Sups}}. + + +sup_spec(Name, Addr, Port, Verbosity) -> + {{Name, Addr, Port}, + {Name, start, [Addr, Port, Verbosity]}, + permanent, 2000, supervisor, [Name, supervisor]}. + +worker_spec(Name, Addr, Port, ConfigFile, ConfigList, Verbosity, Modules) -> + {{Name, Addr, Port}, + {Name, start_link, [ConfigFile, ConfigList, Verbosity]}, + permanent, 2000, worker, [Name] ++ Modules}. + + +make_name(Addr,Port) -> + httpd_util:make_name("httpd_sup",Addr,Port). + + +%% get_addr_and_port + +get_addr_and_port(ConfigFile) -> + case httpd_conf:load(ConfigFile) of + {ok, ConfigList} -> + {ok, Addr, Port} = get_addr_and_port2(ConfigList), + {ok, ConfigList, Addr, Port}; + Error -> + Error + end. + + +get_addr_and_port2(ConfigList) -> + Port = httpd_util:key1search(ConfigList, port, 80), + Addr = httpd_util:key1search(ConfigList, bind_address), + {ok, Addr, Port}. + +get_acc_sup_verbosity(V) -> + case key1search(V, all) of + undefined -> + key1search(V, acceptor_sup_verbosity, ?default_verbosity); + Verbosity -> + Verbosity + end. + + +get_misc_sup_verbosity(V) -> + case key1search(V, all) of + undefined -> + key1search(V, misc_sup_verbosity, ?default_verbosity); + Verbosity -> + Verbosity + end. + + +key1search(L, K) -> + httpd_util:key1search(L, K). + +key1search(L, K, D) -> + httpd_util:key1search(L, K, D). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_util.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_util.erl new file mode 100644 index 0000000000..045e6f6516 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_util.erl @@ -0,0 +1,773 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_util.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(httpd_util). +-export([key1search/2, key1search/3, lookup/2, lookup/3, multi_lookup/2, + lookup_mime/2, lookup_mime/3, lookup_mime_default/2, + lookup_mime_default/3, reason_phrase/1, message/3, rfc1123_date/0, + rfc1123_date/1, day/1, month/1, decode_hex/1, decode_base64/1, encode_base64/1, + flatlength/1, split_path/1, split_script_path/1, suffix/1, to_upper/1, + to_lower/1, split/3, header/2, header/3, header/4, uniq/1, + make_name/2,make_name/3,make_name/4,strip/1, + hexlist_to_integer/1,integer_to_hexlist/1, + convert_request_date/1,create_etag/1,create_etag/2,getSize/1, + response_generated/1]). + +%%Since hexlist_to_integer is a lousy name make a name convert +-export([encode_hex/1]). +-include("httpd.hrl"). + +%% key1search + +key1search(TupleList,Key) -> + key1search(TupleList,Key,undefined). + +key1search(TupleList,Key,Undefined) -> + case lists:keysearch(Key,1,TupleList) of + {value,{Key,Value}} -> + Value; + false -> + Undefined + end. + +%% lookup + +lookup(Table,Key) -> + lookup(Table,Key,undefined). + +lookup(Table,Key,Undefined) -> + case catch ets:lookup(Table,Key) of + [{Key,Value}|_] -> + Value; + _-> + Undefined + end. + +%% multi_lookup + +multi_lookup(Table,Key) -> + remove_key(ets:lookup(Table,Key)). + +remove_key([]) -> + []; +remove_key([{_Key,Value}|Rest]) -> + [Value|remove_key(Rest)]. + +%% lookup_mime + +lookup_mime(ConfigDB,Suffix) -> + lookup_mime(ConfigDB,Suffix,undefined). + +lookup_mime(ConfigDB,Suffix,Undefined) -> + [{mime_types,MimeTypesDB}|_]=ets:lookup(ConfigDB,mime_types), + case ets:lookup(MimeTypesDB,Suffix) of + [] -> + Undefined; + [{Suffix,MimeType}|_] -> + MimeType + end. + +%% lookup_mime_default + +lookup_mime_default(ConfigDB,Suffix) -> + lookup_mime_default(ConfigDB,Suffix,undefined). + +lookup_mime_default(ConfigDB,Suffix,Undefined) -> + [{mime_types,MimeTypesDB}|_]=ets:lookup(ConfigDB,mime_types), + case ets:lookup(MimeTypesDB,Suffix) of + [] -> + case ets:lookup(ConfigDB,default_type) of + [] -> + Undefined; + [{default_type,DefaultType}|_] -> + DefaultType + end; + [{Suffix,MimeType}|_] -> + MimeType + end. + +%% reason_phrase +reason_phrase(100) -> "Continue"; +reason_phrase(101) -> "Swithing protocol"; +reason_phrase(200) -> "OK"; +reason_phrase(201) -> "Created"; +reason_phrase(202) -> "Accepted"; +reason_phrase(204) -> "No Content"; +reason_phrase(205) -> "Reset Content"; +reason_phrase(206) -> "Partial Content"; +reason_phrase(301) -> "Moved Permanently"; +reason_phrase(302) -> "Moved Temporarily"; +reason_phrase(304) -> "Not Modified"; +reason_phrase(400) -> "Bad Request"; +reason_phrase(401) -> "Unauthorized"; +reason_phrase(402) -> "Payment Required"; +reason_phrase(403) -> "Forbidden"; +reason_phrase(404) -> "Not Found"; +reason_phrase(405) -> "Method Not Allowed"; +reason_phrase(408) -> "Request Timeout"; +reason_phrase(411) -> "Length Required"; +reason_phrase(414) -> "Request-URI Too Long"; +reason_phrase(412) -> "Precondition Failed"; +reason_phrase(416) -> "request Range Not Satisfiable"; +reason_phrase(417) -> "Expectation failed"; +reason_phrase(500) -> "Internal Server Error"; +reason_phrase(501) -> "Not Implemented"; +reason_phrase(502) -> "Bad Gateway"; +reason_phrase(503) -> "Service Unavailable"; +reason_phrase(_) -> "Internal Server Error". + +%% message + +message(301,URL,_) -> + "The document has moved <A HREF=\""++URL++"\">here</A>."; +message(304,_URL,_) -> + "The document has not been changed."; +message(400,none,_) -> + "Your browser sent a query that this server could not understand."; +message(401,none,_) -> + "This server could not verify that you +are authorized to access the document you +requested. Either you supplied the wrong +credentials (e.g., bad password), or your +browser does not understand how to supply +the credentials required."; +message(403,RequestURI,_) -> + "You do not have permission to access "++RequestURI++" on this server."; +message(404,RequestURI,_) -> + "The requested URL "++RequestURI++" was not found on this server."; +message(412,none,_) -> + "The requested preconditions where false"; +message(414,ReasonPhrase,_) -> + "Message "++ReasonPhrase++"."; +message(416,ReasonPhrase,_) -> + ReasonPhrase; + +message(500,none,ConfigDB) -> + ServerAdmin=lookup(ConfigDB,server_admin,"unknown@unknown"), + "The server encountered an internal error or +misconfiguration and was unable to complete +your request. +<P>Please contact the server administrator "++ServerAdmin++", +and inform them of the time the error occurred +and anything you might have done that may have +caused the error."; +message(501,{Method,RequestURI,HTTPVersion},_ConfigDB) -> + Method++" to "++RequestURI++" ("++HTTPVersion++") not supported."; +message(503,String,_ConfigDB) -> + "This service in unavailable due to: "++String. + +%%convert_rfc_date(Date)->{{YYYY,MM,DD},{HH,MIN,SEC}} + +convert_request_date([D,A,Y,DateType|Rest]) -> + Func=case DateType of + $\, -> + fun convert_rfc1123_date/1; + $\ -> + fun convert_ascii_date/1; + _ -> + fun convert_rfc850_date/1 + end, + case catch Func([D,A,Y,DateType|Rest])of + {ok,Date} -> + Date; + _Error -> + bad_date + end. + +convert_rfc850_date(DateStr) -> + case string:tokens(DateStr," ") of + [_WeekDay,Date,Time,_TimeZone|_Rest] -> + convert_rfc850_date(Date,Time); + _Error -> + bad_date + end. + +convert_rfc850_date([D1,D2,_,M,O,N,_,Y1,Y2|_Rest],[H1,H2,_Col,M1,M2,_Col,S1,S2|_Rest2])-> + Year=list_to_integer([50,48,Y1,Y2]), + Day=list_to_integer([D1,D2]), + Month=convert_month([M,O,N]), + Hour=list_to_integer([H1,H2]), + Min=list_to_integer([M1,M2]), + Sec=list_to_integer([S1,S2]), + {ok,{{Year,Month,Day},{Hour,Min,Sec}}}; +convert_rfc850_date(_BadDate,_BadTime)-> + bad_date. + +convert_ascii_date([_D,_A,_Y,_SP,M,O,N,_SP,D1,D2,_SP,H1,H2,_Col,M1,M2,_Col,S1,S2,_SP,Y1,Y2,Y3,Y4|_Rest])-> + Year=list_to_integer([Y1,Y2,Y3,Y4]), + Day=case D1 of + $\ -> + list_to_integer([D2]); + _-> + list_to_integer([D1,D2]) + end, + Month=convert_month([M,O,N]), + Hour=list_to_integer([H1,H2]), + Min=list_to_integer([M1,M2]), + Sec=list_to_integer([S1,S2]), + {ok,{{Year,Month,Day},{Hour,Min,Sec}}}; +convert_ascii_date(BadDate)-> + bad_date. +convert_rfc1123_date([_D,_A,_Y,_C,_SP,D1,D2,_SP,M,O,N,_SP,Y1,Y2,Y3,Y4,_SP,H1,H2,_Col,M1,M2,_Col,S1,S2|Rest])-> + Year=list_to_integer([Y1,Y2,Y3,Y4]), + Day=list_to_integer([D1,D2]), + Month=convert_month([M,O,N]), + Hour=list_to_integer([H1,H2]), + Min=list_to_integer([M1,M2]), + Sec=list_to_integer([S1,S2]), + {ok,{{Year,Month,Day},{Hour,Min,Sec}}}; +convert_rfc1123_date(BadDate)-> + bad_date. + +convert_month("Jan")->1; +convert_month("Feb") ->2; +convert_month("Mar") ->3; +convert_month("Apr") ->4; +convert_month("May") ->5; +convert_month("Jun") ->6; +convert_month("Jul") ->7; +convert_month("Aug") ->8; +convert_month("Sep") ->9; +convert_month("Oct") ->10; +convert_month("Nov") ->11; +convert_month("Dec") ->12. + + +%% rfc1123_date + +rfc1123_date() -> + {{YYYY,MM,DD},{Hour,Min,Sec}}=calendar:universal_time(), + DayNumber=calendar:day_of_the_week({YYYY,MM,DD}), + lists:flatten(io_lib:format("~s, ~2.2.0w ~3.s ~4.4.0w ~2.2.0w:~2.2.0w:~2.2.0w GMT", + [day(DayNumber),DD,month(MM),YYYY,Hour,Min,Sec])). + +rfc1123_date({{YYYY,MM,DD},{Hour,Min,Sec}}) -> + DayNumber=calendar:day_of_the_week({YYYY,MM,DD}), + lists:flatten(io_lib:format("~s, ~2.2.0w ~3.s ~4.4.0w ~2.2.0w:~2.2.0w:~2.2.0w GMT", + [day(DayNumber),DD,month(MM),YYYY,Hour,Min,Sec])). + +%% uniq + +uniq([]) -> + []; +uniq([First,First|Rest]) -> + uniq([First|Rest]); +uniq([First|Rest]) -> + [First|uniq(Rest)]. + + +%% day + +day(1) -> "Mon"; +day(2) -> "Tue"; +day(3) -> "Wed"; +day(4) -> "Thu"; +day(5) -> "Fri"; +day(6) -> "Sat"; +day(7) -> "Sun". + +%% month + +month(1) -> "Jan"; +month(2) -> "Feb"; +month(3) -> "Mar"; +month(4) -> "Apr"; +month(5) -> "May"; +month(6) -> "Jun"; +month(7) -> "Jul"; +month(8) -> "Aug"; +month(9) -> "Sep"; +month(10) -> "Oct"; +month(11) -> "Nov"; +month(12) -> "Dec". + +%% decode_hex + +decode_hex([$%,Hex1,Hex2|Rest]) -> + [hex2dec(Hex1)*16+hex2dec(Hex2)|decode_hex(Rest)]; +decode_hex([First|Rest]) -> + [First|decode_hex(Rest)]; +decode_hex([]) -> + []. + +hex2dec(X) when X>=$0,X=<$9 -> X-$0; +hex2dec(X) when X>=$A,X=<$F -> X-$A+10; +hex2dec(X) when X>=$a,X=<$f -> X-$a+10. + +%% decode_base64 (DEBUG STRING: QWxhZGRpbjpvcGVuIHNlc2FtZQ==) + +decode_base64([]) -> + []; +decode_base64([Sextet1,Sextet2,$=,$=|Rest]) -> + Bits2x6= + (d(Sextet1) bsl 18) bor + (d(Sextet2) bsl 12), + Octet1=Bits2x6 bsr 16, + [Octet1|decode_base64(Rest)]; +decode_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)]; +decode_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)]; +decode_base64(CatchAll) -> + "BAD!". + +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}). + + +%% flatlength + +flatlength(List) -> + flatlength(List, 0). + +flatlength([H|T],L) when list(H) -> + flatlength(H,flatlength(T,L)); +flatlength([H|T],L) when binary(H) -> + flatlength(T,L+size(H)); +flatlength([H|T],L) -> + flatlength(T,L+1); +flatlength([],L) -> + L. + +%% split_path + +split_path(Path) -> + case regexp:match(Path,"[\?].*\$") of + %% A QUERY_STRING exists! + {match,Start,Length} -> + {httpd_util:decode_hex(string:substr(Path,1,Start-1)), + string:substr(Path,Start,Length)}; + %% A possible PATH_INFO exists! + nomatch -> + split_path(Path,[]) + end. + +split_path([],SoFar) -> + {httpd_util:decode_hex(lists:reverse(SoFar)),[]}; +split_path([$/|Rest],SoFar) -> + Path=httpd_util:decode_hex(lists:reverse(SoFar)), + case file:read_file_info(Path) of + {ok,FileInfo} when FileInfo#file_info.type == regular -> + {Path,[$/|Rest]}; + {ok,FileInfo} -> + split_path(Rest,[$/|SoFar]); + {error,Reason} -> + split_path(Rest,[$/|SoFar]) + end; +split_path([C|Rest],SoFar) -> + split_path(Rest,[C|SoFar]). + +%% split_script_path + +split_script_path(Path) -> + case split_script_path(Path, []) of + {Script, AfterPath} -> + {PathInfo, QueryString} = pathinfo_querystring(AfterPath), + {Script, {PathInfo, QueryString}}; + not_a_script -> + not_a_script + end. + +pathinfo_querystring(Str) -> + pathinfo_querystring(Str, []). +pathinfo_querystring([], SoFar) -> + {lists:reverse(SoFar), []}; +pathinfo_querystring([$?|Rest], SoFar) -> + {lists:reverse(SoFar), Rest}; +pathinfo_querystring([C|Rest], SoFar) -> + pathinfo_querystring(Rest, [C|SoFar]). + +split_script_path([$?|QueryString], SoFar) -> + Path = httpd_util:decode_hex(lists:reverse(SoFar)), + case file:read_file_info(Path) of + {ok,FileInfo} when FileInfo#file_info.type == regular -> + {Path, [$?|QueryString]}; + {ok,FileInfo} -> + not_a_script; + {error,Reason} -> + not_a_script + end; +split_script_path([], SoFar) -> + Path = httpd_util:decode_hex(lists:reverse(SoFar)), + case file:read_file_info(Path) of + {ok,FileInfo} when FileInfo#file_info.type == regular -> + {Path, []}; + {ok,FileInfo} -> + not_a_script; + {error,Reason} -> + not_a_script + end; +split_script_path([$/|Rest], SoFar) -> + Path = httpd_util:decode_hex(lists:reverse(SoFar)), + case file:read_file_info(Path) of + {ok, FileInfo} when FileInfo#file_info.type == regular -> + {Path, [$/|Rest]}; + {ok, _FileInfo} -> + split_script_path(Rest, [$/|SoFar]); + {error, _Reason} -> + split_script_path(Rest, [$/|SoFar]) + end; +split_script_path([C|Rest], SoFar) -> + split_script_path(Rest,[C|SoFar]). + +%% suffix + +suffix(Path) -> + case filename:extension(Path) of + [] -> + []; + Extension -> + tl(Extension) + end. + +%% to_upper + +to_upper([C|Cs]) when C >= $a, C =< $z -> + [C-($a-$A)|to_upper(Cs)]; +to_upper([C|Cs]) -> + [C|to_upper(Cs)]; +to_upper([]) -> + []. + +%% to_lower + +to_lower([C|Cs]) when C >= $A, C =< $Z -> + [C+($a-$A)|to_lower(Cs)]; +to_lower([C|Cs]) -> + [C|to_lower(Cs)]; +to_lower([]) -> + []. + + +%% strip +strip(Value)-> + lists:reverse(remove_ws(lists:reverse(remove_ws(Value)))). + +remove_ws([$\s|Rest])-> + remove_ws(Rest); +remove_ws([$\t|Rest]) -> + remove_ws(Rest); +remove_ws(Rest) -> + Rest. + +%% split + +split(String,RegExp,Limit) -> + case regexp:parse(RegExp) of + {error,Reason} -> + {error,Reason}; + {ok,_} -> + {ok,do_split(String,RegExp,Limit)} + end. + +do_split(String,RegExp,1) -> + [String]; + +do_split(String,RegExp,Limit) -> + case regexp:first_match(String,RegExp) of + {match,Start,Length} -> + [string:substr(String,1,Start-1)| + do_split(lists:nthtail(Start+Length-1,String),RegExp,Limit-1)]; + nomatch -> + [String] + end. + +%% header +header(StatusCode,Date)when list(Date)-> + header(StatusCode,"text/plain",false); + +header(StatusCode, PersistentConnection) when integer(StatusCode)-> + Date = rfc1123_date(), + Connection = + case PersistentConnection of + true -> + ""; + _ -> + "Connection: close \r\n" + end, + io_lib:format("HTTP/1.1 ~w ~s \r\nDate: ~s\r\nServer: ~s\r\n~s", + [StatusCode, httpd_util:reason_phrase(StatusCode), + Date, ?SERVER_SOFTWARE, Connection]). + +%%---------------------------------------------------------------------- + +header(StatusCode, MimeType, Date) when list(Date) -> + header(StatusCode, MimeType, false,rfc1123_date()); + + +header(StatusCode, MimeType, PersistentConnection) when integer(StatusCode) -> + header(StatusCode, MimeType, PersistentConnection,rfc1123_date()). + + +%%---------------------------------------------------------------------- + +header(416, MimeType,PersistentConnection,Date)-> + Connection = + case PersistentConnection of + true -> + ""; + _ -> + "Connection: close \r\n" + end, + io_lib:format("HTTP/1.1 ~w ~s \r\nDate: ~s\r\nServer: ~s\r\n" + "Content-Range:bytes *" + "Content-Type: ~s\r\n~s", + [416, httpd_util:reason_phrase(416), + Date, ?SERVER_SOFTWARE, MimeType, Connection]); + + +header(StatusCode, MimeType,PersistentConnection,Date) when integer(StatusCode)-> + Connection = + case PersistentConnection of + true -> + ""; + _ -> + "Connection: close \r\n" + end, + io_lib:format("HTTP/1.1 ~w ~s \r\nDate: ~s\r\nServer: ~s\r\n" + "Content-Type: ~s\r\n~s", + [StatusCode, httpd_util:reason_phrase(StatusCode), + Date, ?SERVER_SOFTWARE, MimeType, Connection]). + + + +%% make_name/2, make_name/3 +%% Prefix -> string() +%% First part of the name, e.g. "httpd" +%% Addr -> {A,B,C,D} | string() | undefined +%% The address part of the name. +%% e.g. "123.234.55.66" or {123,234,55,66} or "otp.ericsson.se" +%% for a host address or undefined if local host. +%% Port -> integer() +%% Last part of the name, such as the HTTPD server port +%% number (80). +%% Postfix -> Any string that will be added last to the name +%% +%% Example: +%% make_name("httpd","otp.ericsson.se",80) => httpd__otp_ericsson_se__80 +%% make_name("httpd",undefined,8088) => httpd_8088 + +make_name(Prefix,Port) -> + make_name(Prefix,undefined,Port,""). + +make_name(Prefix,Addr,Port) -> + make_name(Prefix,Addr,Port,""). + +make_name(Prefix,"*",Port,Postfix) -> + make_name(Prefix,undefined,Port,Postfix); + +make_name(Prefix,any,Port,Postfix) -> + make_name1(io_lib:format("~s_~w~s",[Prefix,Port,Postfix])); + +make_name(Prefix,undefined,Port,Postfix) -> + make_name1(io_lib:format("~s_~w~s",[Prefix,Port,Postfix])); + +make_name(Prefix,Addr,Port,Postfix) -> + NameString = + Prefix ++ "__" ++ make_name2(Addr) ++ "__" ++ + integer_to_list(Port) ++ Postfix, + make_name1(NameString). + +make_name1(String) -> + list_to_atom(lists:flatten(String)). + +make_name2({A,B,C,D}) -> + io_lib:format("~w_~w_~w_~w",[A,B,C,D]); +make_name2(Addr) -> + search_and_replace(Addr,$.,$_). + +search_and_replace(S,A,B) -> + Fun = fun(What) -> + case What of + A -> B; + O -> O + end + end, + lists:map(Fun,S). + + + +%%---------------------------------------------------------------------- +%% Converts a string that constists of 0-9,A-F,a-f to a +%% integer +%%---------------------------------------------------------------------- + +hexlist_to_integer([])-> + empty; + + +%%When the string only contains one value its eaasy done. +%% 0-9 +hexlist_to_integer([Size]) when Size>=48 , Size=<57 -> + Size-48; +%% A-F +hexlist_to_integer([Size]) when Size>=65 , Size=<70 -> + Size-55; +%% a-f +hexlist_to_integer([Size]) when Size>=97 , Size=<102 -> + Size-87; +hexlist_to_integer([Size]) -> + not_a_num; + +hexlist_to_integer(Size) -> + Len=string:span(Size,"1234567890abcdefABCDEF"), + hexlist_to_integer2(Size,16 bsl (4 *(Len-2)),0). + +hexlist_to_integer2([],_Pos,Sum)-> + Sum; +hexlist_to_integer2([HexVal|HexString],Pos,Sum)when HexVal>=48,HexVal=<57-> + hexlist_to_integer2(HexString,Pos bsr 4,Sum+((HexVal-48)*Pos)); + +hexlist_to_integer2([HexVal|HexString],Pos,Sum)when HexVal>=65,HexVal=<70-> + hexlist_to_integer2(HexString,Pos bsr 4,Sum+((HexVal-55)*Pos)); + +hexlist_to_integer2([HexVal|HexString],Pos,Sum)when HexVal>=97,HexVal=<102-> + hexlist_to_integer2(HexString,Pos bsr 4,Sum+((HexVal-87)*Pos)); + +hexlist_to_integer2(_AfterHexString,_Pos,Sum)-> + Sum. + +%%---------------------------------------------------------------------- +%%Converts an integer to an hexlist +%%---------------------------------------------------------------------- +encode_hex(Num)-> + integer_to_hexlist(Num). + + +integer_to_hexlist(Num)-> + integer_to_hexlist(Num,getSize(Num),[]). + +integer_to_hexlist(Num,Pot,Res) when Pot<0 -> + convert_to_ascii([Num|Res]); + +integer_to_hexlist(Num,Pot,Res) -> + Position=(16 bsl (Pot*4)), + PosVal=Num div Position, + integer_to_hexlist(Num-(PosVal*Position),Pot-1,[PosVal|Res]). +convert_to_ascii(RevesedNum)-> + convert_to_ascii(RevesedNum,[]). + +convert_to_ascii([],Num)-> + Num; +convert_to_ascii([Num|Reversed],Number)when Num>-1, Num<10 -> + convert_to_ascii(Reversed,[Num+48|Number]); +convert_to_ascii([Num|Reversed],Number)when Num>9, Num<16 -> + convert_to_ascii(Reversed,[Num+55|Number]); +convert_to_ascii(NumReversed,Number) -> + error. + + + +getSize(Num)-> + getSize(Num,0). + +getSize(Num,Pot)when Num<(16 bsl(Pot *4)) -> + Pot-1; + +getSize(Num,Pot) -> + getSize(Num,Pot+1). + + + + + +create_etag(FileInfo)-> + create_etag(FileInfo#file_info.mtime,FileInfo#file_info.size). + +create_etag({{Year,Month,Day},{Hour,Min,Sec}},Size)-> + create_part([Year,Month,Day,Hour,Min,Sec])++io_lib:write(Size); + +create_etag(FileInfo,Size)-> + create_etag(FileInfo#file_info.mtime,Size). + +create_part(Values)-> + lists:map(fun(Val0)-> + Val=Val0 rem 60, + if + Val=<25 -> + 65+Val; % A-Z + Val=<50 -> + 72+Val; % a-z + %%Since no date s + true -> + Val-3 + end + end,Values). + + + +%%---------------------------------------------------------------------- +%%Function that controls whether a response is generated or not +%%---------------------------------------------------------------------- +response_generated(Info)-> + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason}-> + true; + %%No status code control repsonsxe + undefined -> + case httpd_util:key1search(Info#mod.data, response) of + %% No response has been generated! + undefined -> + false; + %% A response has been generated or sent! + Response -> + true + end + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_verbosity.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_verbosity.erl new file mode 100644 index 0000000000..f676eb4c99 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_verbosity.erl @@ -0,0 +1,93 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_verbosity.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(httpd_verbosity). + +-include_lib("stdlib/include/erl_compile.hrl"). + +-export([print/4,print/5,printc/4,validate/1]). + +print(silence,_Severity,_Format,_Arguments) -> + ok; +print(Verbosity,Severity,Format,Arguments) -> + print1(printable(Verbosity,Severity),Format,Arguments). + + +print(silence,_Severity,_Module,_Format,_Arguments) -> + ok; +print(Verbosity,Severity,Module,Format,Arguments) -> + print1(printable(Verbosity,Severity),Module,Format,Arguments). + + +printc(silence,Severity,Format,Arguments) -> + ok; +printc(Verbosity,Severity,Format,Arguments) -> + print2(printable(Verbosity,Severity),Format,Arguments). + + +print1(false,_Format,_Arguments) -> ok; +print1(Verbosity,Format,Arguments) -> + V = image_of_verbosity(Verbosity), + S = image_of_sname(get(sname)), + io:format("** HTTPD ~s ~s: " ++ Format ++ "~n",[S,V]++Arguments). + +print1(false,_Module,_Format,_Arguments) -> ok; +print1(Verbosity,Module,Format,Arguments) -> + V = image_of_verbosity(Verbosity), + S = image_of_sname(get(sname)), + io:format("** HTTPD ~s ~s ~s: " ++ Format ++ "~n",[S,Module,V]++Arguments). + + +print2(false,_Format,_Arguments) -> ok; +print2(_Verbosity,Format,Arguments) -> + io:format(Format ++ "~n",Arguments). + + +%% printable(Verbosity,Severity) +printable(info,info) -> info; +printable(log,info) -> info; +printable(log,log) -> log; +printable(debug,info) -> info; +printable(debug,log) -> log; +printable(debug,debug) -> debug; +printable(trace,V) -> V; +printable(_Verb,_Sev) -> false. + + +image_of_verbosity(info) -> "INFO"; +image_of_verbosity(log) -> "LOG"; +image_of_verbosity(debug) -> "DEBUG"; +image_of_verbosity(trace) -> "TRACE"; +image_of_verbosity(_) -> "". + +%% ShortName +image_of_sname(acc) -> "ACCEPTOR"; +image_of_sname(acc_sup) -> "ACCEPTOR_SUP"; +image_of_sname(auth) -> "AUTH"; +image_of_sname(man) -> "MANAGER"; +image_of_sname(misc_sup) -> "MISC_SUP"; +image_of_sname(sec) -> "SECURITY"; +image_of_sname(P) when pid(P) -> io_lib:format("REQUEST_HANDLER(~p)",[P]); +image_of_sname(undefined) -> ""; +image_of_sname(V) -> io_lib:format("~p",[V]). + + +validate(info) -> info; +validate(log) -> log; +validate(debug) -> debug; +validate(trace) -> trace; +validate(_) -> silence. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_verbosity.hrl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_verbosity.hrl new file mode 100644 index 0000000000..cecaf693d3 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/httpd_verbosity.hrl @@ -0,0 +1,62 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: httpd_verbosity.hrl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% + +-ifndef(dont_use_verbosity). + +-ifndef(default_verbosity). +-define(default_verbosity,silence). +-endif. + +-define(vvalidate(V), httpd_verbosity:validate(V)). + +-ifdef(VMODULE). + +-define(vinfo(F,A), httpd_verbosity:print(get(verbosity),info, ?VMODULE,F,A)). +-define(vlog(F,A), httpd_verbosity:print(get(verbosity),log, ?VMODULE,F,A)). +-define(vdebug(F,A),httpd_verbosity:print(get(verbosity),debug,?VMODULE,F,A)). +-define(vtrace(F,A),httpd_verbosity:print(get(verbosity),trace,?VMODULE,F,A)). + +-else. + +-define(vinfo(F,A), httpd_verbosity:print(get(verbosity),info, F,A)). +-define(vlog(F,A), httpd_verbosity:print(get(verbosity),log, F,A)). +-define(vdebug(F,A),httpd_verbosity:print(get(verbosity),debug,F,A)). +-define(vtrace(F,A),httpd_verbosity:print(get(verbosity),trace,F,A)). + +-endif. + +-define(vinfoc(F,A), httpd_verbosity:printc(get(verbosity),info, F,A)). +-define(vlogc(F,A), httpd_verbosity:printc(get(verbosity),log, F,A)). +-define(vdebugc(F,A),httpd_verbosity:printc(get(verbosity),debug,F,A)). +-define(vtracec(F,A),httpd_verbosity:printc(get(verbosity),trace,F,A)). + +-else. + +-define(vvalidate(V),ok). + +-define(vinfo(F,A),ok). +-define(vlog(F,A),ok). +-define(vdebug(F,A),ok). +-define(vtrace(F,A),ok). + +-define(vinfoc(F,A),ok). +-define(vlogc(F,A),ok). +-define(vdebugc(F,A),ok). +-define(vtracec(F,A),ok). + +-endif. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets.app.src b/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets.app.src new file mode 100644 index 0000000000..750dbc6dba --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets.app.src @@ -0,0 +1,56 @@ +{application,inets, + [{description,"INETS CXC 138 49"}, + {vsn,"%VSN%"}, + {modules,[ + %% FTP + ftp, + + %% HTTP client: + http, + http_lib, + httpc_handler, + httpc_manager, + uri, + + %% HTTP server: + httpd, + httpd_acceptor, + httpd_acceptor_sup, + httpd_conf, + httpd_example, + httpd_manager, + httpd_misc_sup, + httpd_parse, + httpd_request_handler, + httpd_response, + httpd_socket, + httpd_sup, + httpd_util, + httpd_verbosity, + inets_sup, + mod_actions, + mod_alias, + mod_auth, + mod_auth_dets, + mod_auth_mnesia, + mod_auth_plain, + mod_auth_server, + mod_browser, + mod_cgi, + mod_dir, + mod_disk_log, + mod_esi, + mod_get, + mod_head, + mod_htaccess, + mod_include, + mod_log, + mod_range, + mod_responsecontrol, + mod_security, + mod_security_server, + mod_trace + ]}, + {registered,[inets_sup]}, + {applications,[kernel,stdlib]}, + {mod,{inets_sup,[]}}]}. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets.appup.src b/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets.appup.src new file mode 100644 index 0000000000..e9ad0d0fe2 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets.appup.src @@ -0,0 +1,133 @@ +{"%VSN%", + [{"3.0.5", + [ + {load_module, ftp, soft_purge, soft_purge, []} + ] + }, + {"3.0.4", + [ + {update, httpd_acceptor, soft, soft_purge, soft_purge, []} + ] + }, + {"3.0.3", + [{load_module, httpd, soft_purge, soft_purge, [httpd_conf, httpd_sup]}, + {load_module, httpd_conf, soft_purge, soft_purge, []}, + {load_module, httpd_socket, soft_purge, soft_purge, []}, + {load_module, httpd_response, soft_purge, soft_purge, [mod_disk_log]}, + {load_module, mod_disk_log, soft_purge, soft_purge, []}, + {update, httpd_acceptor, soft, soft_purge, soft_purge, []}, + {update, httpd_sup, soft, soft_purge, soft_purge, [httpd_manager]}, + {update, httpd_manager, soft, soft_purge, soft_purge, + [mod_disk_log, httpd_conf, httpd_socket]}] + }, + {"3.0.2", + [{load_module, httpd, soft_purge, soft_purge, [httpd_conf, httpd_sup]}, + {load_module, httpd_conf, soft_purge, soft_purge, []}, + {load_module, httpd_socket, soft_purge, soft_purge, []}, + {load_module, mod_disk_log, soft_purge, soft_purge, []}, + {load_module, httpd_response, soft_purge, soft_purge, [mod_disk_log]}, + {update, httpd_sup, soft, soft_purge, soft_purge, [httpd_manager]}, + {update, httpd_acceptor, soft, soft_purge, soft_purge, []}, + {update, httpd_manager, soft, soft_purge, soft_purge, + [httpd_request_handler, httpd_conf, httpd_socket]}, + {update, httpd_request_handler, soft, soft_purge, soft_purge, + [httpd_response]}] + }, + {"3.0.1", + [{load_module, httpd, soft_purge, soft_purge, [httpd_conf, httpd_sup]}, + {load_module, httpd_conf, soft_purge, soft_purge, []}, + {load_module, httpd_socket, soft_purge, soft_purge, []}, + {load_module, httpd_response, soft_purge, soft_purge, + [mod_auth, mod_disk_log]}, + {load_module, mod_disk_log, soft_purge, soft_purge, []}, + {load_module, mod_auth, soft_purge, soft_purge, []}, + {update, httpd_sup, soft, soft_purge, soft_purge, [httpd_manager]}, + {update, httpd_acceptor, soft, soft_purge, soft_purge, []}, + {update, httpd_manager, soft, soft_purge, soft_purge, + [httpd_request_handler, httpd_conf, httpd_socket]}, + {update, httpd_request_handler, soft, soft_purge, soft_purge, + [httpd_response]}] + }, + {"3.0", + [{load_module, httpd, soft_purge, soft_purge, [httpd_conf, httpd_sup]}, + {load_module, httpd_conf, soft_purge, soft_purge, []}, + {load_module, httpd_socket, soft_purge, soft_purge, []}, + {load_module, httpd_response, soft_purge, soft_purge, + [mod_auth, mod_disk_log]}, + {load_module, mod_disk_log, soft_purge, soft_purge, []}, + {load_module, mod_auth, soft_purge, soft_purge, []}, + {update, httpd_sup, soft, soft_purge, soft_purge, + [httpd_manager, httpd_misc_sup]}, + {update, httpd_misc_sup, soft, soft_purge, soft_purge, []}, + {update, httpd_acceptor, soft, soft_purge, soft_purge, []}, + {update, httpd_manager, soft, soft_purge, soft_purge, + [httpd_request_handler, httpd_conf, httpd_socket]}, + {update, httpd_request_handler, soft, soft_purge, soft_purge, + [httpd_response]}] + } + ], + [{"3.0.5", + [ + {load_module, ftp, soft_purge, soft_purge, []} + ] + }, + {"3.0.4", + [{update, httpd_acceptor, soft, soft_purge, soft_purge, []}] + }, + {"3.0.3", + [{load_module, httpd, soft_purge, soft_purge, [httpd_conf, httpd_sup]}, + {load_module, httpd_conf, soft_purge, soft_purge, []}, + {load_module, httpd_socket, soft_purge, soft_purge, []}, + {load_module, httpd_response, soft_purge, soft_purge, [mod_disk_log]}, + {load_module, mod_disk_log, soft_purge, soft_purge, []}, + {update, httpd_sup, soft, soft_purge, soft_purge, [httpd_manager]}, + {update, httpd_manager, soft, soft_purge, soft_purge, + [mod_disk_log, httpd_conf, httpd_socket]}] + }, + {"3.0.2", + [{load_module, httpd, soft_purge, soft_purge, [httpd_conf, httpd_sup]}, + {load_module, httpd_conf, soft_purge, soft_purge, []}, + {load_module, httpd_socket, soft_purge, soft_purge, []}, + {load_module, httpd_response, soft_purge, soft_purge, [mod_disk_log]}, + {load_module, mod_disk_log, soft_purge, soft_purge, []}, + {update, httpd_sup, soft, soft_purge, soft_purge, [httpd_manager]}, + {update, httpd_acceptor, soft, soft_purge, soft_purge, []}, + {update, httpd_manager, soft, soft_purge, soft_purge, + [httpd_request_handler, httpd_conf, httpd_socket]}, + {update, httpd_request_handler, soft, soft_purge, soft_purge, + [httpd_response]}] + }, + {"3.0.1", + [{load_module, httpd, soft_purge, soft_purge, [httpd_conf, httpd_sup]}, + {load_module, httpd_conf, soft_purge, soft_purge, []}, + {load_module, httpd_socket, soft_purge, soft_purge, []}, + {load_module, httpd_response, soft_purge, soft_purge, + [mod_auth, mod_disk_log]}, + {load_module, mod_disk_log, soft_purge, soft_purge, []}, + {load_module, mod_auth, soft_purge, soft_purge, []}, + {update, httpd_sup, soft, soft_purge, soft_purge, [httpd_manager]}, + {update, httpd_acceptor, soft, soft_purge, soft_purge, []}, + {update, httpd_manager, soft, soft_purge, soft_purge, + [httpd_request_handler, httpd_conf, httpd_socket]}, + {update, httpd_request_handler, soft, soft_purge, soft_purge, + [httpd_response]}] + }, + {"3.0", + [{load_module, httpd, soft_purge, soft_purge, [httpd_conf, httpd_sup]}, + {load_module, httpd_conf, soft_purge, soft_purge, []}, + {load_module, httpd_socket, soft_purge, soft_purge, []}, + {load_module, httpd_response, soft_purge, soft_purge, + [mod_auth, mod_disk_log]}, + {load_module, mod_disk_log, soft_purge, soft_purge, []}, + {load_module, mod_auth, soft_purge, soft_purge, []}, + {update, httpd_sup, soft, soft_purge, soft_purge, + [httpd_manager, httpd_misc_sup]}, + {update, httpd_misc_sup, soft, soft_purge, soft_purge, []}, + {update, httpd_acceptor, soft, soft_purge, soft_purge, []}, + {update, httpd_manager, soft, soft_purge, soft_purge, + [httpd_request_handler, httpd_conf, httpd_socket]}, + {update, httpd_request_handler, soft, soft_purge, soft_purge, + [httpd_response]}] + } + ] +}. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets.config b/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets.config new file mode 100644 index 0000000000..814ddd9fc0 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets.config @@ -0,0 +1,2 @@ +[{inets,[{services,[{httpd,"/var/tmp/server_root/conf/8888.conf"}, + {httpd,"/var/tmp/server_root/conf/8080.conf"}]}]}]. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets_sup.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets_sup.erl new file mode 100644 index 0000000000..878fa2c54b --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/inets_sup.erl @@ -0,0 +1,158 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: inets_sup.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(inets_sup). + +-export([crock/0]). +-export([start/2, stop/1, init/1]). +-export([start_child/2, stop_child/2, which_children/0]). + + +%% crock (Used for debugging!) + +crock() -> + application:start(sasl), + application:start(inets). + + +%% start + +start(Type, State) -> + supervisor:start_link({local, ?MODULE}, ?MODULE, []). + + +%% stop + +stop(State) -> + ok. + + +%% start_child + +start_child(ConfigFile, Verbosity) -> + {ok, Spec} = httpd_child_spec(ConfigFile, Verbosity), + supervisor:start_child(?MODULE, Spec). + + +%% stop_child + +stop_child(Addr, Port) -> + Name = {httpd_sup, Addr, Port}, + case supervisor:terminate_child(?MODULE, Name) of + ok -> + supervisor:delete_child(?MODULE, Name); + Error -> + Error + end. + + +%% which_children + +which_children() -> + supervisor:which_children(?MODULE). + + +%% init + +init([]) -> + case get_services() of + {error, Reason} -> + {error,Reason}; + Services -> + SupFlags = {one_for_one, 10, 3600}, + {ok, {SupFlags, child_spec(Services, [])}} + end. + +get_services() -> + case (catch application:get_env(inets, services)) of + {ok, Services} -> + Services; + _ -> + [] + end. + + +child_spec([], Acc) -> + Acc; +child_spec([{httpd, ConfigFile, Verbosity}|Rest], Acc) -> + case httpd_child_spec(ConfigFile, Verbosity) of + {ok, Spec} -> + child_spec(Rest, [Spec | Acc]); + {error, Reason} -> + error_msg("Failed creating child spec " + "using ~p for reason: ~p", [ConfigFile, Reason]), + child_spec(Rest, Acc) + end; +child_spec([{httpd, ConfigFile}|Rest], Acc) -> + case httpd_child_spec(ConfigFile, []) of + {ok, Spec} -> + child_spec(Rest, [Spec | Acc]); + {error, Reason} -> + error_msg("Failed creating child spec " + "using ~p for reason: ~p", [ConfigFile, Reason]), + child_spec(Rest, Acc) + end. + + +httpd_child_spec(ConfigFile, Verbosity) -> + case httpd_conf:load(ConfigFile) of + {ok, ConfigList} -> + Port = httpd_util:key1search(ConfigList, port, 80), + Addr = httpd_util:key1search(ConfigList, bind_address), + {ok, httpd_child_spec(ConfigFile, Addr, Port, Verbosity)}; + Error -> + Error + end. + + +httpd_child_spec(ConfigFile, Addr, Port, Verbosity) -> + {{httpd_sup, Addr, Port},{httpd_sup, start_link,[ConfigFile, Verbosity]}, + permanent, 20000, supervisor, + [ftp, + httpd, + httpd_conf, + httpd_example, + httpd_manager, + httpd_misc_sup, + httpd_listener, + httpd_parse, + httpd_request, + httpd_response, + httpd_socket, + httpd_sup, + httpd_util, + httpd_verbosity, + inets_sup, + mod_actions, + mod_alias, + mod_auth, + mod_cgi, + mod_dir, + mod_disk_log, + mod_esi, + mod_get, + mod_head, + mod_include, + mod_log, + mod_auth_mnesia, + mod_auth_plain, + mod_auth_dets, + mod_security]}. + + +error_msg(F, A) -> + error_logger:error_msg(F ++ "~n", A). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/jnets_httpd.hrl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/jnets_httpd.hrl new file mode 100644 index 0000000000..0a96560c92 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/jnets_httpd.hrl @@ -0,0 +1,138 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Mobile Arts AB +%% Portions created by Mobile Arts are Copyright 2002, Mobile Arts AB +%% All Rights Reserved.'' +%% +%% + +-include_lib("kernel/include/file.hrl"). + +-define(SOCKET_CHUNK_SIZE,8192). +-define(SOCKET_MAX_POLL,25). +-define(FILE_CHUNK_SIZE,64*1024). +-define(NICE(Reason),lists:flatten(atom_to_list(?MODULE)++": "++Reason)). +-define(DEFAULT_CONTEXT, + [{errmsg,"[an error occurred while processing this directive]"}, + {timefmt,"%A, %d-%b-%y %T %Z"}, + {sizefmt,"abbrev"}]). + + +-ifdef(inets_debug). +-define(DEBUG(Format, Args), io:format("D(~p:~p:~p) : "++Format++"~n", + [self(),?MODULE,?LINE]++Args)). +-else. +-define(DEBUG(F,A),[]). +-endif. + +-define(MAXBODYSIZE,16#ffffffff). + +-define(HTTP_VERSION_10,0). +-define(HTTP_VERSION_11,1). + +-define(CR,13). +-define(LF,10). + + +-record(init_data,{peername,resolve}). + + +-record(mod,{ + init_data, % + data= [], % list() Used to propagate data between modules + socket_type=ip_comm, % socket_type() IP or SSL socket + socket, % socket() Actual socket + config_db, % ets() {key,val} db with config entries + method, % atom() HTTP method, e.g. 'GET' +% request_uri, % string() Request URI + path, % string() Absolute path. May include query etc + http_version, % int() HTTP minor version number, e.g. 0 or 1 +% request_line, % string() Request Line + headers, % #req_headers{} Parsed request headers + entity_body= <<>>, % binary() Body of request + connection, % boolean() true if persistant connection + status_code, % int() Status code + logging % int() 0=No logging + % 1=Only mod_log present + % 2=Only mod_disk_log present + % 3=Both mod_log and mod_disk_log present + }). + +% -record(ssl,{ +% certfile, % +% keyfile, % +% verify= 0, % +% ciphers, % +% password, % +% depth = 1, % +% cacertfile, % + +% cachetimeout % Found in yaws.... +% }). + + +-record(http_request,{ + method, % atom() if known else string() HTTP methd + path, % {abs_path,string()} URL path + version % {int(),int()} {Major,Minor} HTTP version + }). + +-record(http_response,{ + version, % {int(),int()} {Major,Minor} HTTP version + status, % int() Status code + phrase % string() HTTP Reason phrase + }). + + +%%% Request headers +-record(req_headers,{ +%%% --- Standard "General" headers +% cache_control, + connection="keep-alive", +% date, +% pragma, +% trailer, + transfer_encoding, +% upgrade, +% via, +% warning, +%%% --- Standard "Request" headers +% accept, +% accept_charset, +% accept_encoding, +% accept_language, + authorization, + expect, %% FIXME! Update inet_drv.c!! +% from, + host, + if_match, + if_modified_since, + if_none_match, + if_range, + if_unmodified_since, +% max_forwards, +% proxy_authorization, + range, +% referer, +% te, %% FIXME! Update inet_drv.c!! + user_agent, +%%% --- Standard "Entity" headers +% content_encoding, +% content_language, + content_length="0", +% content_location, +% content_md5, +% content_range, + content_type, +% last_modified, + other=[] % (list) Key/Value list with other headers + }). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_actions.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_actions.erl new file mode 100644 index 0000000000..47395d4c12 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_actions.erl @@ -0,0 +1,92 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_actions.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(mod_actions). +-export([do/1,load/2]). + +-include("httpd.hrl"). + +%% do + +do(Info) -> + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + {proceed,Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data,response) of + %% No response has been generated! + undefined -> + Path=mod_alias:path(Info#mod.data,Info#mod.config_db, + Info#mod.request_uri), + Suffix=httpd_util:suffix(Path), + MimeType=httpd_util:lookup_mime(Info#mod.config_db,Suffix, + "text/plain"), + Actions=httpd_util:multi_lookup(Info#mod.config_db,action), + case action(Info#mod.request_uri,MimeType,Actions) of + {yes,RequestURI} -> + {proceed,[{new_request_uri,RequestURI}|Info#mod.data]}; + no -> + Scripts=httpd_util:multi_lookup(Info#mod.config_db,script), + case script(Info#mod.request_uri,Info#mod.method,Scripts) of + {yes,RequestURI} -> + {proceed,[{new_request_uri,RequestURI}|Info#mod.data]}; + no -> + {proceed,Info#mod.data} + end + end; + %% A response has been generated or sent! + Response -> + {proceed,Info#mod.data} + end + end. + +action(RequestURI,MimeType,[]) -> + no; +action(RequestURI,MimeType,[{MimeType,CGIScript}|Rest]) -> + {yes,CGIScript++RequestURI}; +action(RequestURI,MimeType,[_|Rest]) -> + action(RequestURI,MimeType,Rest). + +script(RequestURI,Method,[]) -> + no; +script(RequestURI,Method,[{Method,CGIScript}|Rest]) -> + {yes,CGIScript++RequestURI}; +script(RequestURI,Method,[_|Rest]) -> + script(RequestURI,Method,Rest). + +%% +%% Configuration +%% + +%% load + +load([$A,$c,$t,$i,$o,$n,$ |Action],[]) -> + case regexp:split(Action," ") of + {ok,[MimeType,CGIScript]} -> + {ok,[],{action,{MimeType,CGIScript}}}; + {ok,_} -> + {error,?NICE(httpd_conf:clean(Action)++" is an invalid Action")} + end; +load([$S,$c,$r,$i,$p,$t,$ |Script],[]) -> + case regexp:split(Script," ") of + {ok,[Method,CGIScript]} -> + {ok,[],{script,{Method,CGIScript}}}; + {ok,_} -> + {error,?NICE(httpd_conf:clean(Script)++" is an invalid Script")} + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_alias.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_alias.erl new file mode 100644 index 0000000000..6b8f7210c4 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_alias.erl @@ -0,0 +1,175 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_alias.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(mod_alias). +-export([do/1,real_name/3,real_script_name/3,default_index/2,load/2,path/3]). + +-include("httpd.hrl"). + +%% do + +do(Info) -> + ?DEBUG("do -> entry",[]), + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + {proceed,Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data,response) of + %% No response has been generated! + undefined -> + do_alias(Info); + %% A response has been generated or sent! + Response -> + {proceed,Info#mod.data} + end + end. + +do_alias(Info) -> + ?DEBUG("do_alias -> Request URI: ~p",[Info#mod.request_uri]), + {ShortPath,Path,AfterPath} = + real_name(Info#mod.config_db,Info#mod.request_uri, + httpd_util:multi_lookup(Info#mod.config_db,alias)), + %% Relocate if a trailing slash is missing else proceed! + LastChar = lists:last(ShortPath), + case file:read_file_info(ShortPath) of + {ok,FileInfo} when FileInfo#file_info.type == directory,LastChar /= $/ -> + ?LOG("do_alias -> ~n" + " ShortPath: ~p~n" + " LastChar: ~p~n" + " FileInfo: ~p", + [ShortPath,LastChar,FileInfo]), + ServerName = httpd_util:lookup(Info#mod.config_db,server_name), + Port = port_string(httpd_util:lookup(Info#mod.config_db,port,80)), + URL = "http://"++ServerName++Port++Info#mod.request_uri++"/", + ReasonPhrase = httpd_util:reason_phrase(301), + Message = httpd_util:message(301,URL,Info#mod.config_db), + {proceed, + [{response, + {301, ["Location: ", URL, "\r\n" + "Content-Type: text/html\r\n", + "\r\n", + "<HTML>\n<HEAD>\n<TITLE>",ReasonPhrase, + "</TITLE>\n</HEAD>\n" + "<BODY>\n<H1>",ReasonPhrase, + "</H1>\n", Message, + "\n</BODY>\n</HTML>\n"]}}| + [{real_name,{Path,AfterPath}}|Info#mod.data]]}; + NoFile -> + {proceed,[{real_name,{Path,AfterPath}}|Info#mod.data]} + end. + +port_string(80) -> + ""; +port_string(Port) -> + ":"++integer_to_list(Port). + +%% real_name + +real_name(ConfigDB, RequestURI,[]) -> + DocumentRoot = httpd_util:lookup(ConfigDB, document_root, ""), + RealName = DocumentRoot++RequestURI, + {ShortPath, _AfterPath} = httpd_util:split_path(RealName), + {Path, AfterPath}=httpd_util:split_path(default_index(ConfigDB,RealName)), + {ShortPath, Path, AfterPath}; +real_name(ConfigDB, RequestURI, [{FakeName,RealName}|Rest]) -> + case regexp:match(RequestURI, "^"++FakeName) of + {match, _, _} -> + {ok, ActualName, _} = regexp:sub(RequestURI, + "^"++FakeName, RealName), + {ShortPath, _AfterPath} = httpd_util:split_path(ActualName), + {Path, AfterPath} = + httpd_util:split_path(default_index(ConfigDB, ActualName)), + {ShortPath, Path, AfterPath}; + nomatch -> + real_name(ConfigDB,RequestURI,Rest) + end. + +%% real_script_name + +real_script_name(ConfigDB,RequestURI,[]) -> + not_a_script; +real_script_name(ConfigDB,RequestURI,[{FakeName,RealName}|Rest]) -> + case regexp:match(RequestURI,"^"++FakeName) of + {match,_,_} -> + {ok,ActualName,_}=regexp:sub(RequestURI,"^"++FakeName,RealName), + httpd_util:split_script_path(default_index(ConfigDB,ActualName)); + nomatch -> + real_script_name(ConfigDB,RequestURI,Rest) + end. + +%% default_index + +default_index(ConfigDB, Path) -> + case file:read_file_info(Path) of + {ok, FileInfo} when FileInfo#file_info.type == directory -> + DirectoryIndex = httpd_util:lookup(ConfigDB, directory_index, []), + append_index(Path, DirectoryIndex); + _ -> + Path + end. + +append_index(RealName, []) -> + RealName; +append_index(RealName, [Index|Rest]) -> + case file:read_file_info(filename:join(RealName, Index)) of + {error,Reason} -> + append_index(RealName, Rest); + _ -> + filename:join(RealName,Index) + end. + +%% path + +path(Data, ConfigDB, RequestURI) -> + case httpd_util:key1search(Data,real_name) of + undefined -> + DocumentRoot = httpd_util:lookup(ConfigDB, document_root, ""), + {Path,AfterPath} = + httpd_util:split_path(DocumentRoot++RequestURI), + Path; + {Path,AfterPath} -> + Path + end. + +%% +%% Configuration +%% + +%% load + +load([$D,$i,$r,$e,$c,$t,$o,$r,$y,$I,$n,$d,$e,$x,$ |DirectoryIndex],[]) -> + {ok, DirectoryIndexes} = regexp:split(DirectoryIndex," "), + {ok,[], {directory_index, DirectoryIndexes}}; +load([$A,$l,$i,$a,$s,$ |Alias],[]) -> + case regexp:split(Alias," ") of + {ok, [FakeName, RealName]} -> + {ok,[],{alias,{FakeName,RealName}}}; + {ok, _} -> + {error,?NICE(httpd_conf:clean(Alias)++" is an invalid Alias")} + end; +load([$S,$c,$r,$i,$p,$t,$A,$l,$i,$a,$s,$ |ScriptAlias],[]) -> + case regexp:split(ScriptAlias," ") of + {ok, [FakeName, RealName]} -> + %% Make sure the path always has a trailing slash.. + RealName1 = filename:join(filename:split(RealName)), + {ok, [], {script_alias,{FakeName, RealName1++"/"}}}; + {ok, _} -> + {error, ?NICE(httpd_conf:clean(ScriptAlias)++ + " is an invalid ScriptAlias")} + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth.erl new file mode 100644 index 0000000000..9f3289c826 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth.erl @@ -0,0 +1,748 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_auth.erl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% +-module(mod_auth). + + +%% The functions that the webbserver call on startup stop +%% and when the server traverse the modules. +-export([do/1, load/2, store/2, remove/1]). + +%% User entries to the gen-server. +-export([add_user/2, add_user/5, add_user/6, + add_group_member/3, add_group_member/4, add_group_member/5, + list_users/1, list_users/2, list_users/3, + delete_user/2, delete_user/3, delete_user/4, + delete_group_member/3, delete_group_member/4, delete_group_member/5, + list_groups/1, list_groups/2, list_groups/3, + delete_group/2, delete_group/3, delete_group/4, + get_user/2, get_user/3, get_user/4, + list_group_members/2, list_group_members/3, list_group_members/4, + update_password/6, update_password/5]). + +-include("httpd.hrl"). +-include("mod_auth.hrl"). + +-define(VMODULE,"AUTH"). +-include("httpd_verbosity.hrl"). + +-define(NOPASSWORD,"NoPassword"). + + +%% do +do(Info) -> + ?vtrace("do", []), + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + {proceed, Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data,response) of + %% No response has been generated! + undefined -> + Path = mod_alias:path(Info#mod.data,Info#mod.config_db, + Info#mod.request_uri), + %% Is it a secret area? + case secretp(Path,Info#mod.config_db) of + {yes, Directory, DirectoryData} -> + %% Authenticate (allow) + case allow((Info#mod.init_data)#init_data.peername, + Info#mod.socket_type,Info#mod.socket, + DirectoryData) of + allowed -> + case deny((Info#mod.init_data)#init_data.peername, + Info#mod.socket_type, Info#mod.socket, + DirectoryData) of + not_denied -> + case httpd_util:key1search(DirectoryData, + auth_type) of + undefined -> + {proceed, Info#mod.data}; + none -> + {proceed, Info#mod.data}; + AuthType -> + do_auth(Info, + Directory, + DirectoryData, + AuthType) + end; + {denied, Reason} -> + {proceed, + [{status,{403,Info#mod.request_uri,Reason}}| + Info#mod.data]} + end; + {not_allowed, Reason} -> + {proceed,[{status,{403,Info#mod.request_uri,Reason}}| + Info#mod.data]} + end; + no -> + {proceed, Info#mod.data} + end; + %% A response has been generated or sent! + Response -> + {proceed, Info#mod.data} + end + end. + + +do_auth(Info, Directory, DirectoryData, AuthType) -> + %% Authenticate (require) + case require(Info, Directory, DirectoryData) of + authorized -> + {proceed,Info#mod.data}; + {authorized, User} -> + {proceed, [{remote_user,User}|Info#mod.data]}; + {authorization_failed, Reason} -> + ?vtrace("do_auth -> authorization_failed: ~p",[Reason]), + {proceed, [{status,{401,none,Reason}}|Info#mod.data]}; + {authorization_required, Realm} -> + ?vtrace("do_auth -> authorization_required: ~p",[Realm]), + ReasonPhrase = httpd_util:reason_phrase(401), + Message = httpd_util:message(401,none,Info#mod.config_db), + {proceed, + [{response, + {401, + ["WWW-Authenticate: Basic realm=\"",Realm, + "\"\r\n\r\n","<HTML>\n<HEAD>\n<TITLE>", + ReasonPhrase,"</TITLE>\n", + "</HEAD>\n<BODY>\n<H1>",ReasonPhrase, + "</H1>\n",Message,"\n</BODY>\n</HTML>\n"]}}| + Info#mod.data]}; + {status, {StatusCode,PhraseArgs,Reason}} -> + {proceed, [{status,{StatusCode,PhraseArgs,Reason}}| + Info#mod.data]} + end. + + +%% require + +require(Info, Directory, DirectoryData) -> + ParsedHeader = Info#mod.parsed_header, + ValidUsers = httpd_util:key1search(DirectoryData, require_user), + ValidGroups = httpd_util:key1search(DirectoryData, require_group), + + %% Any user or group restrictions? + case ValidGroups of + undefined when ValidUsers == undefined -> + authorized; + _ -> + case httpd_util:key1search(ParsedHeader, "authorization") of + %% Authorization required! + undefined -> + case httpd_util:key1search(DirectoryData, auth_name) of + undefined -> + {status,{500,none,?NICE("AuthName directive not specified")}}; + Realm -> + {authorization_required, Realm} + end; + %% Check credentials! + [$B,$a,$s,$i,$c,$ | EncodedString] -> + DecodedString = httpd_util:decode_base64(EncodedString), + case a_valid_user(Info, DecodedString, + ValidUsers, ValidGroups, + Directory, DirectoryData) of + {yes, User} -> + {authorized, User}; + {no, Reason} -> + {authorization_failed, Reason}; + {status, {StatusCode,PhraseArgs,Reason}} -> + {status,{StatusCode,PhraseArgs,Reason}} + end; + %% Bad credentials! + BadCredentials -> + {status,{401,none,?NICE("Bad credentials "++BadCredentials)}} + end + end. + +a_valid_user(Info,DecodedString,ValidUsers,ValidGroups,Dir,DirData) -> + case httpd_util:split(DecodedString,":",2) of + {ok,[SupposedUser, Password]} -> + case user_accepted(SupposedUser, ValidUsers) of + true -> + check_password(SupposedUser, Password, Dir, DirData); + false -> + case group_accepted(Info,SupposedUser,ValidGroups,Dir,DirData) of + true -> + check_password(SupposedUser,Password,Dir,DirData); + false -> + {no,?NICE("No such user exists")} + end + end; + {ok,BadCredentials} -> + {status,{401,none,?NICE("Bad credentials "++BadCredentials)}} + end. + +user_accepted(SupposedUser, undefined) -> + false; +user_accepted(SupposedUser, ValidUsers) -> + lists:member(SupposedUser, ValidUsers). + + +group_accepted(Info, User, undefined, Dir, DirData) -> + false; +group_accepted(Info, User, [], Dir, DirData) -> + false; +group_accepted(Info, User, [Group|Rest], Dir, DirData) -> + Ret = int_list_group_members(Group, Dir, DirData), + case Ret of + {ok, UserList} -> + case lists:member(User, UserList) of + true -> + true; + false -> + group_accepted(Info, User, Rest, Dir, DirData) + end; + Other -> + false + end. + +check_password(User, Password, Dir, DirData) -> + case int_get_user(DirData, User) of + {ok, UStruct} -> + case UStruct#httpd_user.password of + Password -> + %% FIXME + {yes, UStruct#httpd_user.username}; + Other -> + {no, "No such user"} % Don't say 'Bad Password' !!! + end; + _ -> + {no, "No such user"} + end. + + +%% Middle API. Theese functions call the appropriate authentication module. +int_get_user(DirData, User) -> + AuthMod = auth_mod_name(DirData), + apply(AuthMod, get_user, [DirData, User]). + +int_list_group_members(Group, Dir, DirData) -> + AuthMod = auth_mod_name(DirData), + apply(AuthMod, list_group_members, [DirData, Group]). + +auth_mod_name(DirData) -> + case httpd_util:key1search(DirData, auth_type, plain) of + plain -> mod_auth_plain; + mnesia -> mod_auth_mnesia; + dets -> mod_auth_dets + end. + + +%% +%% Is it a secret area? +%% + +%% secretp + +secretp(Path,ConfigDB) -> + Directories = ets:match(ConfigDB,{directory,'$1','_'}), + case secret_path(Path, Directories) of + {yes,Directory} -> + {yes,Directory, + lists:flatten(ets:match(ConfigDB,{directory,Directory,'$1'}))}; + no -> + no + end. + +secret_path(Path,Directories) -> + secret_path(Path, httpd_util:uniq(lists:sort(Directories)),to_be_found). + +secret_path(Path,[],to_be_found) -> + no; +secret_path(Path,[],Directory) -> + {yes,Directory}; +secret_path(Path,[[NewDirectory]|Rest],Directory) -> + case regexp:match(Path,NewDirectory) of + {match,_,_} when Directory == to_be_found -> + secret_path(Path,Rest,NewDirectory); + {match,_,Length} when Length > length(Directory)-> + secret_path(Path,Rest,NewDirectory); + {match,_,Length} -> + secret_path(Path,Rest,Directory); + nomatch -> + secret_path(Path,Rest,Directory) + end. + +%% +%% Authenticate +%% + +%% allow + +allow({_,RemoteAddr},SocketType,Socket,DirectoryData) -> + Hosts = httpd_util:key1search(DirectoryData, allow_from, all), + case validate_addr(RemoteAddr,Hosts) of + true -> + allowed; + false -> + {not_allowed, ?NICE("Connection from your host is not allowed")} + end. + +validate_addr(RemoteAddr,all) -> % When called from 'allow' + true; +validate_addr(RemoteAddr,none) -> % When called from 'deny' + false; +validate_addr(RemoteAddr,[]) -> + false; +validate_addr(RemoteAddr,[HostRegExp|Rest]) -> + ?DEBUG("validate_addr -> RemoteAddr: ~p HostRegExp: ~p", + [RemoteAddr, HostRegExp]), + case regexp:match(RemoteAddr, HostRegExp) of + {match,_,_} -> + true; + nomatch -> + validate_addr(RemoteAddr,Rest) + end. + +%% deny + +deny({_,RemoteAddr},SocketType,Socket,DirectoryData) -> + ?DEBUG("deny -> RemoteAddr: ~p",[RemoteAddr]), + Hosts = httpd_util:key1search(DirectoryData, deny_from, none), + ?DEBUG("deny -> Hosts: ~p",[Hosts]), + case validate_addr(RemoteAddr,Hosts) of + true -> + {denied, ?NICE("Connection from your host is not allowed")}; + false -> + not_denied + end. + +%% +%% Configuration +%% + +%% load/2 +%% + +%% mod_auth recognizes the following Configuration Directives: +%% <Directory /path/to/directory> +%% AuthDBType +%% AuthName +%% AuthUserFile +%% AuthGroupFile +%% AuthAccessPassword +%% require +%% allow +%% </Directory> + +%% When a <Directory> directive is found, a new context is set to +%% [{directory, Directory, DirData}|OtherContext] +%% DirData in this case is a key-value list of data belonging to the +%% directory in question. +%% +%% When the </Directory> statement is found, the Context created earlier +%% will be returned as a ConfigList and the context will return to the +%% state it was previously. + +load([$<,$D,$i,$r,$e,$c,$t,$o,$r,$y,$ |Directory],[]) -> + Dir = httpd_conf:custom_clean(Directory,"",">"), + {ok,[{directory, Dir, [{path, Dir}]}]}; +load(eof,[{directory,Directory, DirData}|_]) -> + {error, ?NICE("Premature end-of-file in "++Directory)}; + +load([$A,$u,$t,$h,$N,$a,$m,$e,$ |AuthName], [{directory,Directory, DirData}|Rest]) -> + {ok, [{directory,Directory, + [ {auth_name, httpd_conf:clean(AuthName)}|DirData]} | Rest ]}; + +load([$A,$u,$t,$h,$U,$s,$e,$r,$F,$i,$l,$e,$ |AuthUserFile0], + [{directory, Directory, DirData}|Rest]) -> + AuthUserFile = httpd_conf:clean(AuthUserFile0), + {ok,[{directory,Directory, + [ {auth_user_file, AuthUserFile}|DirData]} | Rest ]}; + +load([$A,$u,$t,$h,$G,$r,$o,$u,$p,$F,$i,$l,$e,$ |AuthGroupFile0], + [{directory,Directory, DirData}|Rest]) -> + AuthGroupFile = httpd_conf:clean(AuthGroupFile0), + {ok,[{directory,Directory, + [ {auth_group_file, AuthGroupFile}|DirData]} | Rest]}; + +%AuthAccessPassword +load([$A,$u,$t,$h,$A,$c,$c,$e,$s,$s,$P,$a,$s,$s,$w,$o,$r,$d,$ |AuthAccessPassword0], + [{directory,Directory, DirData}|Rest]) -> + AuthAccessPassword = httpd_conf:clean(AuthAccessPassword0), + {ok,[{directory,Directory, + [{auth_access_password, AuthAccessPassword}|DirData]} | Rest]}; + + + + +load([$A,$u,$t,$h,$D,$B,$T,$y,$p,$e,$ |Type], + [{directory, Dir, DirData}|Rest]) -> + case httpd_conf:clean(Type) of + "plain" -> + {ok, [{directory, Dir, [{auth_type, plain}|DirData]} | Rest ]}; + "mnesia" -> + {ok, [{directory, Dir, [{auth_type, mnesia}|DirData]} | Rest ]}; + "dets" -> + {ok, [{directory, Dir, [{auth_type, dets}|DirData]} | Rest ]}; + _ -> + {error, ?NICE(httpd_conf:clean(Type)++" is an invalid AuthDBType")} + end; + +load([$r,$e,$q,$u,$i,$r,$e,$ |Require],[{directory,Directory, DirData}|Rest]) -> + case regexp:split(Require," ") of + {ok,["user"|Users]} -> + {ok,[{directory,Directory, + [{require_user,Users}|DirData]} | Rest]}; + {ok,["group"|Groups]} -> + {ok,[{directory,Directory, + [{require_group,Groups}|DirData]} | Rest]}; + {ok,_} -> + {error,?NICE(httpd_conf:clean(Require)++" is an invalid require")} + end; + +load([$a,$l,$l,$o,$w,$ |Allow],[{directory,Directory, DirData}|Rest]) -> + case regexp:split(Allow," ") of + {ok,["from","all"]} -> + {ok,[{directory,Directory, + [{allow_from,all}|DirData]} | Rest]}; + {ok,["from"|Hosts]} -> + {ok,[{directory,Directory, + [{allow_from,Hosts}|DirData]} | Rest]}; + {ok,_} -> + {error,?NICE(httpd_conf:clean(Allow)++" is an invalid allow")} + end; + +load([$d,$e,$n,$y,$ |Deny],[{directory,Directory, DirData}|Rest]) -> + case regexp:split(Deny," ") of + {ok, ["from", "all"]} -> + {ok,[{directory, Directory, + [{deny_from, all}|DirData]} | Rest]}; + {ok, ["from"|Hosts]} -> + {ok,[{directory, Directory, + [{deny_from, Hosts}|DirData]} | Rest]}; + {ok, _} -> + {error,?NICE(httpd_conf:clean(Deny)++" is an invalid deny")} + end; + +load("</Directory>",[{directory,Directory, DirData}|Rest]) -> + {ok, Rest, {directory, Directory, DirData}}; + +load([$A,$u,$t,$h,$M,$n,$e,$s,$i,$a,$D,$B,$ |AuthMnesiaDB], + [{directory, Dir, DirData}|Rest]) -> + case httpd_conf:clean(AuthMnesiaDB) of + "On" -> + {ok,[{directory,Dir,[{auth_type,mnesia}|DirData]}|Rest]}; + "Off" -> + {ok,[{directory,Dir,[{auth_type,plain}|DirData]}|Rest]}; + _ -> + {error, ?NICE(httpd_conf:clean(AuthMnesiaDB)++" is an invalid AuthMnesiaDB")} + end. + +%% store + +store({directory,Directory0, DirData0}, ConfigList) -> + Port = httpd_util:key1search(ConfigList, port), + DirData = case httpd_util:key1search(ConfigList, bind_address) of + undefined -> + [{port, Port}|DirData0]; + Addr -> + [{port, Port},{bind_address,Addr}|DirData0] + end, + Directory = + case filename:pathtype(Directory0) of + relative -> + SR = httpd_util:key1search(ConfigList, server_root), + filename:join(SR, Directory0); + _ -> + Directory0 + end, + AuthMod = + case httpd_util:key1search(DirData0, auth_type) of + mnesia -> mod_auth_mnesia; + dets -> mod_auth_dets; + plain -> mod_auth_plain; + _ -> no_module_at_all + end, + case AuthMod of + no_module_at_all -> + {ok, {directory, Directory, DirData}}; + _ -> + %% Control that there are a password or add a standard password: + %% "NoPassword" + %% In this way a user must select to use a noPassword + Pwd = case httpd_util:key1search(DirData,auth_access_password)of + undefined-> + ?NOPASSWORD; + PassW-> + PassW + end, + DirDataLast = lists:keydelete(auth_access_password,1,DirData), + case catch AuthMod:store_directory_data(Directory, DirDataLast) of + ok -> + add_auth_password(Directory,Pwd,ConfigList), + {ok, {directory, Directory, DirDataLast}}; + {ok, NewDirData} -> + add_auth_password(Directory,Pwd,ConfigList), + {ok, {directory, Directory, NewDirData}}; + {error, Reason} -> + {error, Reason}; + Other -> + ?ERROR("unexpected result: ~p",[Other]), + {error, Other} + end + end. + + +add_auth_password(Dir, Pwd0, ConfigList) -> + Addr = httpd_util:key1search(ConfigList, bind_address), + Port = httpd_util:key1search(ConfigList, port), + mod_auth_server:start(Addr, Port), + mod_auth_server:add_password(Addr, Port, Dir, Pwd0). + +%% remove + + +remove(ConfigDB) -> + lists:foreach(fun({directory, Dir, DirData}) -> + AuthMod = auth_mod_name(DirData), + (catch apply(AuthMod, remove, [DirData])) + end, + ets:match_object(ConfigDB,{directory,'_','_'})), + Addr = case lookup(ConfigDB, bind_address) of + [] -> + undefined; + [{bind_address, Address}] -> + Address + end, + [{port, Port}] = lookup(ConfigDB, port), + mod_auth_server:stop(Addr, Port), + ok. + + + + +%% -------------------------------------------------------------------- + +%% update_password + +update_password(Port, Dir, Old, New, New)-> + update_password(undefined, Port, Dir, Old, New, New). + +update_password(Addr, Port, Dir, Old, New, New) when list(New) -> + mod_auth_server:update_password(Addr, Port, Dir, Old, New); + +update_password(_Addr, _Port, _Dir, _Old, New, New) -> + {error, badtype}; +update_password(_Addr, _Port, _Dir, _Old, New, New1) -> + {error, notqeual}. + + +%% add_user + +add_user(UserName, Opt) -> + case get_options(Opt, mandatory) of + {Addr, Port, Dir, AuthPwd}-> + case get_options(Opt, userData) of + {error, Reason}-> + {error, Reason}; + {UserData, Password}-> + User = [#httpd_user{username = UserName, + password = Password, + user_data = UserData}], + mod_auth_server:add_user(Addr, Port, Dir, User, AuthPwd); + {error, Reason} -> + {error, Reason} + end + end. + + +add_user(UserName, Password, UserData, Port, Dir) -> + add_user(UserName, Password, UserData, undefined, Port, Dir). +add_user(UserName, Password, UserData, Addr, Port, Dir) -> + User = [#httpd_user{username = UserName, + password = Password, + user_data = UserData}], + mod_auth_server:add_user(Addr, Port, Dir, User, ?NOPASSWORD). + + +%% get_user + +get_user(UserName, Opt) -> + case get_options(Opt, mandatory) of + {Addr, Port, Dir, AuthPwd} -> + mod_auth_server:get_user(Addr, Port, Dir, UserName, AuthPwd); + {error, Reason} -> + {error, Reason} + end. + +get_user(UserName, Port, Dir) -> + get_user(UserName, undefined, Port, Dir). +get_user(UserName, Addr, Port, Dir) -> + mod_auth_server:get_user(Addr, Port, Dir, UserName, ?NOPASSWORD). + + +%% add_group_member + +add_group_member(GroupName, UserName, Opt)-> + case get_options(Opt, mandatory) of + {Addr, Port, Dir, AuthPwd}-> + mod_auth_server:add_group_member(Addr, Port, Dir, + GroupName, UserName, AuthPwd); + {error, Reason} -> + {error, Reason} + end. + +add_group_member(GroupName, UserName, Port, Dir) -> + add_group_member(GroupName, UserName, undefined, Port, Dir). + +add_group_member(GroupName, UserName, Addr, Port, Dir) -> + mod_auth_server:add_group_member(Addr, Port, Dir, + GroupName, UserName, ?NOPASSWORD). + + +%% delete_group_member + +delete_group_member(GroupName, UserName, Opt) -> + case get_options(Opt, mandatory) of + {Addr, Port, Dir, AuthPwd} -> + mod_auth_server:delete_group_member(Addr, Port, Dir, + GroupName, UserName, AuthPwd); + {error, Reason} -> + {error, Reason} + end. + +delete_group_member(GroupName, UserName, Port, Dir) -> + delete_group_member(GroupName, UserName, undefined, Port, Dir). +delete_group_member(GroupName, UserName, Addr, Port, Dir) -> + mod_auth_server:delete_group_member(Addr, Port, Dir, + GroupName, UserName, ?NOPASSWORD). + + +%% list_users + +list_users(Opt) -> + case get_options(Opt, mandatory) of + {Addr, Port, Dir, AuthPwd} -> + mod_auth_server:list_users(Addr, Port, Dir, AuthPwd); + {error, Reason} -> + {error, Reason} + end. + +list_users(Port, Dir) -> + list_users(undefined, Port, Dir). +list_users(Addr, Port, Dir) -> + mod_auth_server:list_users(Addr, Port, Dir, ?NOPASSWORD). + + +%% delete_user + +delete_user(UserName, Opt) -> + case get_options(Opt, mandatory) of + {Addr, Port, Dir, AuthPwd} -> + mod_auth_server:delete_user(Addr, Port, Dir, UserName, AuthPwd); + {error, Reason} -> + {error, Reason} + end. + +delete_user(UserName, Port, Dir) -> + delete_user(UserName, undefined, Port, Dir). +delete_user(UserName, Addr, Port, Dir) -> + mod_auth_server:delete_user(Addr, Port, Dir, UserName, ?NOPASSWORD). + + +%% delete_group + +delete_group(GroupName, Opt) -> + case get_options(Opt, mandatory) of + {Addr, Port, Dir, AuthPwd}-> + mod_auth_server:delete_group(Addr, Port, Dir, GroupName, AuthPwd); + {error, Reason} -> + {error, Reason} + end. + +delete_group(GroupName, Port, Dir) -> + delete_group(GroupName, undefined, Port, Dir). +delete_group(GroupName, Addr, Port, Dir) -> + mod_auth_server:delete_group(Addr, Port, Dir, GroupName, ?NOPASSWORD). + + +%% list_groups + +list_groups(Opt) -> + case get_options(Opt, mandatory) of + {Addr, Port, Dir, AuthPwd}-> + mod_auth_server:list_groups(Addr, Port, Dir, AuthPwd); + {error, Reason} -> + {error, Reason} + end. + +list_groups(Port, Dir) -> + list_groups(undefined, Port, Dir). +list_groups(Addr, Port, Dir) -> + mod_auth_server:list_groups(Addr, Port, Dir, ?NOPASSWORD). + + +%% list_group_members + +list_group_members(GroupName,Opt) -> + case get_options(Opt, mandatory) of + {Addr, Port, Dir, AuthPwd} -> + mod_auth_server:list_group_members(Addr, Port, Dir, GroupName, + AuthPwd); + {error, Reason} -> + {error, Reason} + end. + +list_group_members(GroupName, Port, Dir) -> + list_group_members(GroupName, undefined, Port, Dir). +list_group_members(GroupName, Addr, Port, Dir) -> + mod_auth_server:list_group_members(Addr, Port, Dir, GroupName, ?NOPASSWORD). + + + +%% Opt = [{port, Port}, +%% {addr, Addr}, +%% {dir, Dir}, +%% {authPassword, AuthPassword} | FunctionSpecificData] +get_options(Opt, mandatory)-> + case httpd_util:key1search(Opt, port, undefined) of + Port when integer(Port) -> + case httpd_util:key1search(Opt, dir, undefined) of + Dir when list(Dir) -> + Addr = httpd_util:key1search(Opt, + addr, + undefined), + AuthPwd = httpd_util:key1search(Opt, + authPassword, + ?NOPASSWORD), + {Addr, Port, Dir, AuthPwd}; + _-> + {error, bad_dir} + end; + _ -> + {error, bad_dir} + end; + +%% FunctionSpecificData = {userData, UserData} | {password, Password} +get_options(Opt, userData)-> + case httpd_util:key1search(Opt, userData, undefined) of + undefined -> + {error, no_userdata}; + UserData -> + case httpd_util:key1search(Opt, password, undefined) of + undefined-> + {error, no_password}; + Pwd -> + {UserData, Pwd} + end + end. + + +lookup(Db, Key) -> + ets:lookup(Db, Key). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth.hrl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth.hrl new file mode 100644 index 0000000000..2b8ea6657f --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth.hrl @@ -0,0 +1,26 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_auth.hrl,v 1.1 2008/12/17 09:53:34 mikpe Exp $ +%% + +-record(httpd_user, + {username, + password, + user_data}). + +-record(httpd_group, + {name, + userlist}). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_dets.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_dets.erl new file mode 100644 index 0000000000..d947d6cf49 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_dets.erl @@ -0,0 +1,222 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_auth_dets.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_auth_dets). + +%% dets authentication storage + +-export([get_user/2, + list_group_members/2, + add_user/2, + add_group_member/3, + list_users/1, + delete_user/2, + list_groups/1, + delete_group_member/3, + delete_group/2, + remove/1]). + +-export([store_directory_data/2]). + +-include("httpd.hrl"). +-include("mod_auth.hrl"). + +store_directory_data(Directory, DirData) -> + ?CDEBUG("store_directory_data -> ~n" + " Directory: ~p~n" + " DirData: ~p", + [Directory, DirData]), + + PWFile = httpd_util:key1search(DirData, auth_user_file), + GroupFile = httpd_util:key1search(DirData, auth_group_file), + Addr = httpd_util:key1search(DirData, bind_address), + Port = httpd_util:key1search(DirData, port), + + PWName = httpd_util:make_name("httpd_dets_pwdb",Addr,Port), + case dets:open_file(PWName,[{type,set},{file,PWFile},{repair,true}]) of + {ok, PWDB} -> + GDBName = httpd_util:make_name("httpd_dets_groupdb",Addr,Port), + case dets:open_file(GDBName,[{type,set},{file,GroupFile},{repair,true}]) of + {ok, GDB} -> + NDD1 = lists:keyreplace(auth_user_file, 1, DirData, + {auth_user_file, PWDB}), + NDD2 = lists:keyreplace(auth_group_file, 1, NDD1, + {auth_group_file, GDB}), + {ok, NDD2}; + {error, Err}-> + {error, {{file, GroupFile},Err}} + end; + {error, Err2} -> + {error, {{file, PWFile},Err2}} + end. + +%% +%% Storage format of users in the dets table: +%% {{UserName, Addr, Port, Dir}, Password, UserData} +%% + +add_user(DirData, UStruct) -> + {Addr, Port, Dir} = lookup_common(DirData), + PWDB = httpd_util:key1search(DirData, auth_user_file), + Record = {{UStruct#httpd_user.username, Addr, Port, Dir}, + UStruct#httpd_user.password, UStruct#httpd_user.user_data}, + case dets:lookup(PWDB, UStruct#httpd_user.username) of + [Record] -> + {error, user_already_in_db}; + _ -> + dets:insert(PWDB, Record), + true + end. + +get_user(DirData, UserName) -> + {Addr, Port, Dir} = lookup_common(DirData), + PWDB = httpd_util:key1search(DirData, auth_user_file), + User = {UserName, Addr, Port, Dir}, + case dets:lookup(PWDB, User) of + [{User, Password, UserData}] -> + {ok, #httpd_user{username=UserName, password=Password, user_data=UserData}}; + Other -> + {error, no_such_user} + end. + +list_users(DirData) -> + ?DEBUG("list_users -> ~n" + " DirData: ~p", [DirData]), + {Addr, Port, Dir} = lookup_common(DirData), + PWDB = httpd_util:key1search(DirData, auth_user_file), + case dets:traverse(PWDB, fun(X) -> {continue, X} end) of %% SOOOO Ugly ! + Records when list(Records) -> + ?DEBUG("list_users -> ~n" + " Records: ~p", [Records]), + {ok, [UserName || {{UserName, AnyAddr, AnyPort, AnyDir}, Password, _Data} <- Records, + AnyAddr == Addr, AnyPort == Port, AnyDir == Dir]}; + O -> + ?DEBUG("list_users -> ~n" + " O: ~p", [O]), + {ok, []} + end. + +delete_user(DirData, UserName) -> + {Addr, Port, Dir} = lookup_common(DirData), + PWDB = httpd_util:key1search(DirData, auth_user_file), + User = {UserName, Addr, Port, Dir}, + case dets:lookup(PWDB, User) of + [{User, SomePassword, UserData}] -> + dets:delete(PWDB, User), + lists:foreach(fun(Group) -> delete_group_member(DirData, Group, UserName) end, + list_groups(DirData)), + true; + _ -> + {error, no_such_user} + end. + +%% +%% Storage of groups in the dets table: +%% {Group, UserList} where UserList is a list of strings. +%% +add_group_member(DirData, GroupName, UserName) -> + {Addr, Port, Dir} = lookup_common(DirData), + GDB = httpd_util:key1search(DirData, auth_group_file), + Group = {GroupName, Addr, Port, Dir}, + case dets:lookup(GDB, Group) of + [{Group, Users}] -> + case lists:member(UserName, Users) of + true -> + true; + false -> + dets:insert(GDB, {Group, [UserName|Users]}), + true + end; + [] -> + dets:insert(GDB, {Group, [UserName]}), + true; + Other -> + {error, Other} + end. + +list_group_members(DirData, GroupName) -> + {Addr, Port, Dir} = lookup_common(DirData), + GDB = httpd_util:key1search(DirData, auth_group_file), + Group = {GroupName, Addr, Port, Dir}, + case dets:lookup(GDB, Group) of + [{Group, Users}] -> + {ok, Users}; + Other -> + {error, no_such_group} + end. + +list_groups(DirData) -> + {Addr, Port, Dir} = lookup_common(DirData), + GDB = httpd_util:key1search(DirData, auth_group_file), + case dets:match(GDB, {'$1', '_'}) of + [] -> + {ok, []}; + List when list(List) -> + Groups = lists:flatten(List), + {ok, [GroupName || {GroupName, AnyAddr, AnyPort, AnyDir} <- Groups, + AnyAddr == Addr, AnyPort == Port, AnyDir == Dir]}; + _ -> + {ok, []} + end. + +delete_group_member(DirData, GroupName, UserName) -> + {Addr, Port, Dir} = lookup_common(DirData), + GDB = httpd_util:key1search(DirData, auth_group_file), + Group = {GroupName, Addr, Port, Dir}, + case dets:lookup(GDB, GroupName) of + [{Group, Users}] -> + case lists:member(UserName, Users) of + true -> + dets:delete(GDB, Group), + dets:insert(GDB, {Group, + lists:delete(UserName, Users)}), + true; + false -> + {error, no_such_group_member} + end; + _ -> + {error, no_such_group} + end. + +delete_group(DirData, GroupName) -> + {Addr, Port, Dir} = lookup_common(DirData), + GDB = httpd_util:key1search(DirData, auth_group_file), + Group = {GroupName, Addr, Port, Dir}, + case dets:lookup(GDB, Group) of + [{Group, Users}] -> + dets:delete(GDB, Group), + true; + _ -> + {error, no_such_group} + end. + +lookup_common(DirData) -> + Dir = httpd_util:key1search(DirData, path), + Port = httpd_util:key1search(DirData, port), + Addr = httpd_util:key1search(DirData, bind_address), + {Addr, Port, Dir}. + +%% remove/1 +%% +%% Closes dets tables used by this auth mod. +%% +remove(DirData) -> + PWDB = httpd_util:key1search(DirData, auth_user_file), + GDB = httpd_util:key1search(DirData, auth_group_file), + dets:close(GDB), + dets:close(PWDB), + ok. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_mnesia.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_mnesia.erl new file mode 100644 index 0000000000..ea2f0cb905 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_mnesia.erl @@ -0,0 +1,269 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_auth_mnesia.erl,v 1.2 2010/03/04 13:54:19 maria Exp $ +%% +-module(mod_auth_mnesia). +-export([get_user/2, + list_group_members/2, + add_user/2, + add_group_member/3, + list_users/1, + delete_user/2, + list_groups/1, + delete_group_member/3, + delete_group/2]). + +-export([store_user/5, store_user/6, + store_group_member/5, store_group_member/6, + list_group_members/3, list_group_members/4, + list_groups/2, list_groups/3, + list_users/2, list_users/3, + remove_user/4, remove_user/5, + remove_group_member/5, remove_group_member/6, + remove_group/4, remove_group/5]). + +-export([store_directory_data/2]). + +-include("httpd.hrl"). +-include("mod_auth.hrl"). + + + +store_directory_data(Directory, DirData) -> + %% We don't need to do anything here, we could ofcourse check that the appropriate + %% mnesia tables has been created prior to starting the http server. + ok. + + +%% +%% API +%% + +%% Compability API + + +store_user(UserName, Password, Port, Dir, AccessPassword) -> + %% AccessPassword is ignored - was not used in previous version + DirData = [{path,Dir},{port,Port}], + UStruct = #httpd_user{username = UserName, + password = Password}, + add_user(DirData, UStruct). + +store_user(UserName, Password, Addr, Port, Dir, AccessPassword) -> + %% AccessPassword is ignored - was not used in previous version + DirData = [{path,Dir},{bind_address,Addr},{port,Port}], + UStruct = #httpd_user{username = UserName, + password = Password}, + add_user(DirData, UStruct). + +store_group_member(GroupName, UserName, Port, Dir, AccessPassword) -> + DirData = [{path,Dir},{port,Port}], + add_group_member(DirData, GroupName, UserName). + +store_group_member(GroupName, UserName, Addr, Port, Dir, AccessPassword) -> + DirData = [{path,Dir},{bind_address,Addr},{port,Port}], + add_group_member(DirData, GroupName, UserName). + +list_group_members(GroupName, Port, Dir) -> + DirData = [{path,Dir},{port,Port}], + list_group_members(DirData, GroupName). + +list_group_members(GroupName, Addr, Port, Dir) -> + DirData = [{path,Dir},{bind_address,Addr},{port,Port}], + list_group_members(DirData, GroupName). + +list_groups(Port, Dir) -> + DirData = [{path,Dir},{port,Port}], + list_groups(DirData). + +list_groups(Addr, Port, Dir) -> + DirData = [{path,Dir},{bind_address,Addr},{port,Port}], + list_groups(DirData). + +list_users(Port, Dir) -> + DirData = [{path,Dir},{port,Port}], + list_users(DirData). + +list_users(Addr, Port, Dir) -> + DirData = [{path,Dir},{bind_address,Addr},{port,Port}], + list_users(DirData). + +remove_user(UserName, Port, Dir, _AccessPassword) -> + DirData = [{path,Dir},{port,Port}], + delete_user(DirData, UserName). + +remove_user(UserName, Addr, Port, Dir, _AccessPassword) -> + DirData = [{path,Dir},{bind_address,Addr},{port,Port}], + delete_user(DirData, UserName). + +remove_group_member(GroupName,UserName,Port,Dir,_AccessPassword) -> + DirData = [{path,Dir},{port,Port}], + delete_group_member(DirData, GroupName, UserName). + +remove_group_member(GroupName,UserName,Addr,Port,Dir,_AccessPassword) -> + DirData = [{path,Dir},{bind_address,Addr},{port,Port}], + delete_group_member(DirData, GroupName, UserName). + +remove_group(GroupName,Port,Dir,_AccessPassword) -> + DirData = [{path,Dir},{port,Port}], + delete_group(DirData, GroupName). + +remove_group(GroupName,Addr,Port,Dir,_AccessPassword) -> + DirData = [{path,Dir},{bind_address,Addr},{port,Port}], + delete_group(DirData, GroupName). + +%% +%% Storage format of users in the mnesia table: +%% httpd_user records +%% + +add_user(DirData, UStruct) -> + {Addr, Port, Dir} = lookup_common(DirData), + UserName = UStruct#httpd_user.username, + Password = UStruct#httpd_user.password, + Data = UStruct#httpd_user.user_data, + User=#httpd_user{username={UserName,Addr,Port,Dir}, + password=Password, + user_data=Data}, + case mnesia:transaction(fun() -> mnesia:write(User) end) of + {aborted,Reason} -> + {error,Reason}; + _ -> + true + end. + +get_user(DirData, UserName) -> + {Addr, Port, Dir} = lookup_common(DirData), + case mnesia:transaction(fun() -> + mnesia:read({httpd_user, + {UserName,Addr,Port,Dir}}) + end) of + {aborted,Reason} -> + {error, Reason}; + {'atomic',[]} -> + {error, no_such_user}; + {'atomic', [Record]} when record(Record, httpd_user) -> + {ok, Record#httpd_user{username=UserName}}; + Other -> + {error, no_such_user} + end. + +list_users(DirData) -> + {Addr, Port, Dir} = lookup_common(DirData), + case mnesia:transaction(fun() -> + mnesia:match_object({httpd_user, + {'_',Addr,Port,Dir},'_','_'}) + end) of + {aborted,Reason} -> + {error,Reason}; + {'atomic',Users} -> + {ok, + lists:foldr(fun({httpd_user, {UserName, AnyAddr, AnyPort, AnyDir}, + Password, Data}, Acc) -> + [UserName|Acc] + end, + [], Users)} + end. + +delete_user(DirData, UserName) -> + {Addr, Port, Dir} = lookup_common(DirData), + case mnesia:transaction(fun() -> + mnesia:delete({httpd_user, + {UserName,Addr,Port,Dir}}) + end) of + {aborted,Reason} -> + {error,Reason}; + _ -> + true + end. + +%% +%% Storage of groups in the mnesia table: +%% Multiple instances of {#httpd_group, User} +%% + +add_group_member(DirData, GroupName, User) -> + {Addr, Port, Dir} = lookup_common(DirData), + Group=#httpd_group{name={GroupName, Addr, Port, Dir}, userlist=User}, + case mnesia:transaction(fun() -> mnesia:write(Group) end) of + {aborted,Reason} -> + {error,Reason}; + _ -> + true + end. + +list_group_members(DirData, GroupName) -> + {Addr, Port, Dir} = lookup_common(DirData), + case mnesia:transaction(fun() -> + mnesia:read({httpd_group, + {GroupName,Addr,Port,Dir}}) + end) of + {aborted, Reason} -> + {error,Reason}; + {'atomic', Members} -> + {ok,[UserName || {httpd_group,{AnyGroupName,AnyAddr,AnyPort,AnyDir},UserName} <- Members, + AnyGroupName == GroupName, AnyAddr == Addr, + AnyPort == Port, AnyDir == Dir]} + end. + +list_groups(DirData) -> + {Addr, Port, Dir} = lookup_common(DirData), + case mnesia:transaction(fun() -> + mnesia:match_object({httpd_group, + {'_',Addr,Port,Dir},'_'}) + end) of + {aborted, Reason} -> + {error, Reason}; + {'atomic', Groups} -> + GroupNames= + [GroupName || {httpd_group,{GroupName,AnyAddr,AnyPort,AnyDir}, UserName} <- Groups, + AnyAddr == Addr, AnyPort == AnyPort, AnyDir == Dir], + {ok, httpd_util:uniq(lists:sort(GroupNames))} + end. + +delete_group_member(DirData, GroupName, UserName) -> + {Addr, Port, Dir} = lookup_common(DirData), + Group = #httpd_group{name={GroupName, Addr, Port, Dir}, userlist=UserName}, + case mnesia:transaction(fun() -> mnesia:delete_object(Group) end) of + {aborted,Reason} -> + {error,Reason}; + _ -> + true + end. + +%% THIS IS WRONG (?) ! +%% Should first match out all httpd_group records for this group and then +%% do mnesia:delete on those. Or ? + +delete_group(DirData, GroupName) -> + {Addr, Port, Dir} = lookup_common(DirData), + case mnesia:transaction(fun() -> + mnesia:delete({httpd_group, + {GroupName,Addr,Port,Dir}}) + end) of + {aborted,Reason} -> + {error,Reason}; + _ -> + true + end. + +%% Utility functions. + +lookup_common(DirData) -> + Dir = httpd_util:key1search(DirData, path), + Port = httpd_util:key1search(DirData, port), + Addr = httpd_util:key1search(DirData, bind_address), + {Addr, Port, Dir}. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_plain.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_plain.erl new file mode 100644 index 0000000000..75cc60f288 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_plain.erl @@ -0,0 +1,338 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_auth_plain.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_auth_plain). + +-include("httpd.hrl"). +-include("mod_auth.hrl"). + +-define(VMODULE,"AUTH_PLAIN"). +-include("httpd_verbosity.hrl"). + + +%% Internal API +-export([store_directory_data/2]). + + +-export([get_user/2, + list_group_members/2, + add_user/2, + add_group_member/3, + list_users/1, + delete_user/2, + list_groups/1, + delete_group_member/3, + delete_group/2, + remove/1]). + +%% +%% API +%% + +%% +%% Storage format of users in the ets table: +%% {UserName, Password, UserData} +%% + +add_user(DirData, #httpd_user{username = User} = UStruct) -> + ?vtrace("add_user -> entry with:" + "~n User: ~p",[User]), + PWDB = httpd_util:key1search(DirData, auth_user_file), + Record = {User, + UStruct#httpd_user.password, + UStruct#httpd_user.user_data}, + case ets:lookup(PWDB, User) of + [{User, _SomePassword, _SomeData}] -> + {error, user_already_in_db}; + _ -> + ets:insert(PWDB, Record), + true + end. + +get_user(DirData, User) -> + ?vtrace("get_user -> entry with:" + "~n User: ~p",[User]), + PWDB = httpd_util:key1search(DirData, auth_user_file), + case ets:lookup(PWDB, User) of + [{User, PassWd, Data}] -> + {ok, #httpd_user{username=User, password=PassWd, user_data=Data}}; + _ -> + {error, no_such_user} + end. + +list_users(DirData) -> + PWDB = httpd_util:key1search(DirData, auth_user_file), + case ets:match(PWDB, '$1') of + Records when list(Records) -> + {ok, lists:foldr(fun({User,PassWd,Data}, A) -> [User|A] end, + [], lists:flatten(Records))}; + O -> + {ok, []} + end. + +delete_user(DirData, UserName) -> + ?vtrace("delete_user -> entry with:" + "~n UserName: ~p",[UserName]), + PWDB = httpd_util:key1search(DirData, auth_user_file), + case ets:lookup(PWDB, UserName) of + [{UserName, SomePassword, SomeData}] -> + ets:delete(PWDB, UserName), + case list_groups(DirData) of + {ok,Groups}-> + lists:foreach(fun(Group) -> + delete_group_member(DirData, Group, UserName) + end,Groups), + true; + _-> + true + end; + _ -> + {error, no_such_user} + end. + +%% +%% Storage of groups in the ets table: +%% {Group, UserList} where UserList is a list of strings. +%% + +add_group_member(DirData, Group, UserName) -> + ?DEBUG("add_group_members -> ~n" + " Group: ~p~n" + " UserName: ~p",[Group,UserName]), + GDB = httpd_util:key1search(DirData, auth_group_file), + case ets:lookup(GDB, Group) of + [{Group, Users}] -> + case lists:member(UserName, Users) of + true -> + ?DEBUG("add_group_members -> already member in group",[]), + true; + false -> + ?DEBUG("add_group_members -> add",[]), + ets:insert(GDB, {Group, [UserName|Users]}), + true + end; + [] -> + ?DEBUG("add_group_members -> create grouo",[]), + ets:insert(GDB, {Group, [UserName]}), + true; + Other -> + ?ERROR("add_group_members -> Other: ~p",[Other]), + {error, Other} + end. + +list_group_members(DirData, Group) -> + ?DEBUG("list_group_members -> Group: ~p",[Group]), + GDB = httpd_util:key1search(DirData, auth_group_file), + case ets:lookup(GDB, Group) of + [{Group, Users}] -> + ?DEBUG("list_group_members -> Users: ~p",[Users]), + {ok, Users}; + _ -> + {error, no_such_group} + end. + +list_groups(DirData) -> + ?DEBUG("list_groups -> entry",[]), + GDB = httpd_util:key1search(DirData, auth_group_file), + case ets:match(GDB, '$1') of + [] -> + ?DEBUG("list_groups -> []",[]), + {ok, []}; + Groups0 when list(Groups0) -> + ?DEBUG("list_groups -> Groups0: ~p",[Groups0]), + {ok, httpd_util:uniq(lists:foldr(fun({G, U}, A) -> [G|A] end, + [], lists:flatten(Groups0)))}; + _ -> + {ok, []} + end. + +delete_group_member(DirData, Group, User) -> + ?DEBUG("list_group_members -> ~n" + " Group: ~p~n" + " User: ~p",[Group,User]), + GDB = httpd_util:key1search(DirData, auth_group_file), + UDB = httpd_util:key1search(DirData, auth_user_file), + case ets:lookup(GDB, Group) of + [{Group, Users}] when list(Users) -> + case lists:member(User, Users) of + true -> + ?DEBUG("list_group_members -> deleted from group",[]), + ets:delete(GDB, Group), + ets:insert(GDB, {Group, lists:delete(User, Users)}), + true; + false -> + ?DEBUG("list_group_members -> not member",[]), + {error, no_such_group_member} + end; + _ -> + ?ERROR("list_group_members -> no such group",[]), + {error, no_such_group} + end. + +delete_group(DirData, Group) -> + ?DEBUG("list_group_members -> Group: ~p",[Group]), + GDB = httpd_util:key1search(DirData, auth_group_file), + case ets:lookup(GDB, Group) of + [{Group, Users}] -> + ?DEBUG("list_group_members -> delete",[]), + ets:delete(GDB, Group), + true; + _ -> + ?ERROR("delete_group -> no such group",[]), + {error, no_such_group} + end. + + +store_directory_data(Directory, DirData) -> + PWFile = httpd_util:key1search(DirData, auth_user_file), + GroupFile = httpd_util:key1search(DirData, auth_group_file), + case load_passwd(PWFile) of + {ok, PWDB} -> + case load_group(GroupFile) of + {ok, GRDB} -> + %% Address and port is included in the file names... + Addr = httpd_util:key1search(DirData, bind_address), + Port = httpd_util:key1search(DirData, port), + {ok, PasswdDB} = store_passwd(Addr,Port,PWDB), + {ok, GroupDB} = store_group(Addr,Port,GRDB), + NDD1 = lists:keyreplace(auth_user_file, 1, DirData, + {auth_user_file, PasswdDB}), + NDD2 = lists:keyreplace(auth_group_file, 1, NDD1, + {auth_group_file, GroupDB}), + {ok, NDD2}; + Err -> + ?ERROR("failed storing directory data: " + "load group error: ~p",[Err]), + {error, Err} + end; + Err2 -> + ?ERROR("failed storing directory data: " + "load passwd error: ~p",[Err2]), + {error, Err2} + end. + + + +%% load_passwd + +load_passwd(AuthUserFile) -> + case file:open(AuthUserFile, [read]) of + {ok,Stream} -> + parse_passwd(Stream, []); + {error, _} -> + {error, ?NICE("Can't open "++AuthUserFile)} + end. + +parse_passwd(Stream,PasswdList) -> + Line = + case io:get_line(Stream, '') of + eof -> + eof; + String -> + httpd_conf:clean(String) + end, + parse_passwd(Stream, PasswdList, Line). + +parse_passwd(Stream, PasswdList, eof) -> + file:close(Stream), + {ok, PasswdList}; +parse_passwd(Stream, PasswdList, "") -> + parse_passwd(Stream, PasswdList); +parse_passwd(Stream, PasswdList, [$#|_]) -> + parse_passwd(Stream, PasswdList); +parse_passwd(Stream, PasswdList, Line) -> + case regexp:split(Line,":") of + {ok, [User,Password]} -> + parse_passwd(Stream, [{User,Password, []}|PasswdList]); + {ok,_} -> + {error, ?NICE(Line)} + end. + +%% load_group + +load_group(AuthGroupFile) -> + case file:open(AuthGroupFile, [read]) of + {ok, Stream} -> + parse_group(Stream,[]); + {error, _} -> + {error, ?NICE("Can't open "++AuthGroupFile)} + end. + +parse_group(Stream, GroupList) -> + Line= + case io:get_line(Stream,'') of + eof -> + eof; + String -> + httpd_conf:clean(String) + end, + parse_group(Stream, GroupList, Line). + +parse_group(Stream, GroupList, eof) -> + file:close(Stream), + {ok, GroupList}; +parse_group(Stream, GroupList, "") -> + parse_group(Stream, GroupList); +parse_group(Stream, GroupList, [$#|_]) -> + parse_group(Stream, GroupList); +parse_group(Stream, GroupList, Line) -> + case regexp:split(Line, ":") of + {ok, [Group,Users]} -> + {ok, UserList} = regexp:split(Users," "), + parse_group(Stream, [{Group,UserList}|GroupList]); + {ok, _} -> + {error, ?NICE(Line)} + end. + + +%% store_passwd + +store_passwd(Addr,Port,PasswdList) -> + Name = httpd_util:make_name("httpd_passwd",Addr,Port), + PasswdDB = ets:new(Name, [set, public]), + store_passwd(PasswdDB, PasswdList). + +store_passwd(PasswdDB, []) -> + {ok, PasswdDB}; +store_passwd(PasswdDB, [User|Rest]) -> + ets:insert(PasswdDB, User), + store_passwd(PasswdDB, Rest). + +%% store_group + +store_group(Addr,Port,GroupList) -> + Name = httpd_util:make_name("httpd_group",Addr,Port), + GroupDB = ets:new(Name, [set, public]), + store_group(GroupDB, GroupList). + + +store_group(GroupDB,[]) -> + {ok, GroupDB}; +store_group(GroupDB,[User|Rest]) -> + ets:insert(GroupDB, User), + store_group(GroupDB, Rest). + + +%% remove/1 +%% +%% Deletes ets tables used by this auth mod. +%% +remove(DirData) -> + PWDB = httpd_util:key1search(DirData, auth_user_file), + GDB = httpd_util:key1search(DirData, auth_group_file), + ets:delete(PWDB), + ets:delete(GDB). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_server.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_server.erl new file mode 100644 index 0000000000..59402ac169 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_auth_server.erl @@ -0,0 +1,422 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_auth_server.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% + +-module(mod_auth_server). + +-include("httpd.hrl"). +%% -include("mod_auth.hrl"). +-include("httpd_verbosity.hrl"). + +-behaviour(gen_server). + + +%% mod_auth exports +-export([start/2, stop/2, + add_password/4, update_password/5, + add_user/5, delete_user/5, get_user/5, list_users/4, + add_group_member/6, delete_group_member/6, list_group_members/5, + delete_group/5, list_groups/4]). + +%% Management exports +-export([verbosity/3]). + +%% gen_server exports +-export([start_link/3, + init/1, + handle_call/3, handle_cast/2, handle_info/2, + terminate/2, code_change/3]). + + +-record(state,{tab}). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% External API %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% start_link/3 +%% +%% NOTE: This is called by httpd_misc_sup when the process is started +%% +start_link(Addr, Port, Verbosity)-> + ?vlog("start_link -> entry with" + "~n Addr: ~p" + "~n Port: ~p", [Addr, Port]), + Name = make_name(Addr, Port), + gen_server:start_link({local, Name}, ?MODULE, [Verbosity], + [{timeout, infinity}]). + + +%% start/2 + +start(Addr, Port)-> + ?vtrace("start -> entry with" + "~n Addr: ~p" + "~n Port: ~p", [Addr, Port]), + Name = make_name(Addr, Port), + case whereis(Name) of + undefined -> + Verbosity = get(auth_verbosity), + case (catch httpd_misc_sup:start_auth_server(Addr, Port, + Verbosity)) of + {ok, Pid} -> + put(auth_server, Pid), + ok; + {error, Reason} -> + exit({failed_start_auth_server, Reason}); + Error -> + exit({failed_start_auth_server, Error}) + end; + _ -> %% Already started... + ok + end. + + +%% stop/2 + +stop(Addr, Port)-> + ?vtrace("stop -> entry with" + "~n Addr: ~p" + "~n Port: ~p", [Addr, Port]), + Name = make_name(Addr, Port), + case whereis(Name) of + undefined -> %% Already stopped + ok; + _ -> + (catch httpd_misc_sup:stop_auth_server(Addr, Port)) + end. + + +%% verbosity/3 + +verbosity(Addr, Port, Verbosity) -> + Name = make_name(Addr, Port), + Req = {verbosity, Verbosity}, + call(Name, Req). + + +%% add_password/4 + +add_password(Addr, Port, Dir, Password)-> + Name = make_name(Addr, Port), + Req = {add_password, Dir, Password}, + call(Name, Req). + + +%% update_password/6 + +update_password(Addr, Port, Dir, Old, New) when list(New) -> + Name = make_name(Addr, Port), + Req = {update_password, Dir, Old, New}, + call(Name, Req). + + +%% add_user/5 + +add_user(Addr, Port, Dir, User, Password) -> + Name = make_name(Addr, Port), + Req = {add_user, Addr, Port, Dir, User, Password}, + call(Name, Req). + + +%% delete_user/5 + +delete_user(Addr, Port, Dir, UserName, Password) -> + Name = make_name(Addr, Port), + Req = {delete_user, Addr, Port, Dir, UserName, Password}, + call(Name, Req). + + +%% get_user/5 + +get_user(Addr, Port, Dir, UserName, Password) -> + Name = make_name(Addr, Port), + Req = {get_user, Addr, Port, Dir, UserName, Password}, + call(Name, Req). + + +%% list_users/4 + +list_users(Addr, Port, Dir, Password) -> + Name = make_name(Addr,Port), + Req = {list_users, Addr, Port, Dir, Password}, + call(Name, Req). + + +%% add_group_member/6 + +add_group_member(Addr, Port, Dir, GroupName, UserName, Password) -> + Name = make_name(Addr,Port), + Req = {add_group_member, Addr, Port, Dir, GroupName, UserName, Password}, + call(Name, Req). + + +%% delete_group_member/6 + +delete_group_member(Addr, Port, Dir, GroupName, UserName, Password) -> + Name = make_name(Addr,Port), + Req = {delete_group_member, Addr, Port, Dir, GroupName, UserName, Password}, + call(Name, Req). + + +%% list_group_members/4 + +list_group_members(Addr, Port, Dir, Group, Password) -> + Name = make_name(Addr, Port), + Req = {list_group_members, Addr, Port, Dir, Group, Password}, + call(Name, Req). + + +%% delete_group/5 + +delete_group(Addr, Port, Dir, GroupName, Password) -> + Name = make_name(Addr, Port), + Req = {delete_group, Addr, Port, Dir, GroupName, Password}, + call(Name, Req). + + +%% list_groups/4 + +list_groups(Addr, Port, Dir, Password) -> + Name = make_name(Addr, Port), + Req = {list_groups, Addr, Port, Dir, Password}, + call(Name, Req). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% Server call-back functions %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% init + +init([undefined]) -> + init([?default_verbosity]); + +init([Verbosity]) -> + put(sname,auth), + put(verbosity,Verbosity), + ?vlog("starting",[]), + {ok,#state{tab = ets:new(auth_pwd,[set,protected])}}. + + +%% handle_call + +%% Add a user +handle_call({add_user, Addr, Port, Dir, User, AuthPwd}, _From, State) -> + Reply = api_call(Addr, Port, Dir, add_user, User, AuthPwd, State), + {reply, Reply, State}; + +%% Get data about a user +handle_call({get_user, Addr, Port, Dir, User, AuthPwd}, _From, State) -> + Reply = api_call(Addr, Port, Dir, get_user, [User], AuthPwd, State), + {reply, Reply, State}; + +%% Add a group member +handle_call({add_group_member, Addr, Port, Dir, Group, User, AuthPwd}, + _From, State) -> + Reply = api_call(Addr, Port, Dir, add_group_member, [Group, User], + AuthPwd, State), + {reply, Reply, State}; + +%% delete a group +handle_call({delete_group_member, Addr, Port, Dir, Group, User, AuthPwd}, + _From, State)-> + Reply = api_call(Addr, Port, Dir, delete_group_member, [Group, User], + AuthPwd, State), + {reply, Reply, State}; + +%% List all users thats standalone users +handle_call({list_users, Addr, Port, Dir, AuthPwd}, _From, State)-> + Reply = api_call(Addr, Port, Dir, list_users, [], AuthPwd, State), + {reply, Reply, State}; + +%% Delete a user +handle_call({delete_user, Addr, Port, Dir, User, AuthPwd}, _From, State)-> + Reply = api_call(Addr, Port, Dir, delete_user, [User], AuthPwd, State), + {reply, Reply, State}; + +%% Delete a group +handle_call({delete_group, Addr, Port, Dir, Group, AuthPwd}, _From, State)-> + Reply = api_call(Addr, Port, Dir, delete_group, [Group], AuthPwd, State), + {reply, Reply, State}; + +%% List the current groups +handle_call({list_groups, Addr, Port, Dir, AuthPwd}, _From, State)-> + Reply = api_call(Addr, Port, Dir, list_groups, [], AuthPwd, State), + {reply, Reply, State}; + +%% List the members of the given group +handle_call({list_group_members, Addr, Port, Dir, Group, AuthPwd}, + _From, State)-> + Reply = api_call(Addr, Port, Dir, list_group_members, [Group], + AuthPwd, State), + {reply, Reply, State}; + + +%% Add password for a directory +handle_call({add_password, Dir, Password}, _From, State)-> + Reply = do_add_password(Dir, Password, State), + {reply, Reply, State}; + + +%% Update the password for a directory + +handle_call({update_password, Dir, Old, New},_From,State)-> + Reply = + case getPassword(State, Dir) of + OldPwd when binary(OldPwd)-> + case erlang:md5(Old) of + OldPwd -> + %% The old password is right => + %% update the password to the new + do_update_password(Dir,New,State), + ok; + _-> + {error, error_new} + end; + _-> + {error, error_old} + end, + {reply, Reply, State}; + +handle_call(stop, _From, State)-> + {stop, normal, State}; + +handle_call({verbosity,Verbosity},_From,State)-> + OldVerbosity = put(verbosity,Verbosity), + ?vlog("set verbosity: ~p -> ~p",[Verbosity,OldVerbosity]), + {reply,OldVerbosity,State}. + +handle_info(Info,State)-> + {noreply,State}. + +handle_cast(Request,State)-> + {noreply,State}. + + +terminate(Reason,State) -> + ets:delete(State#state.tab), + ok. + + +%% code_change({down, ToVsn}, State, Extra) +%% +code_change({down, _}, #state{tab = Tab}, downgrade_to_2_6_0) -> + ?vlog("downgrade to 2.6.0", []), + {ok, {state, Tab, undefined}}; + + +%% code_change(FromVsn, State, Extra) +%% +code_change(_, {state, Tab, _}, upgrade_from_2_6_0) -> + ?vlog("upgrade from 2.6.0", []), + {ok, #state{tab = Tab}}. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% The functions that really changes the data in the database %% +%% of users to different directories %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% API gateway + +api_call(Addr, Port, Dir, Func, Args,Password,State) -> + case controlPassword(Password,State,Dir) of + ok-> + ConfigName = httpd_util:make_name("httpd_conf",Addr,Port), + case ets:match_object(ConfigName, {directory, Dir, '$1'}) of + [{directory, Dir, DirData}] -> + AuthMod = auth_mod_name(DirData), + ?DEBUG("api_call -> call ~p:~p",[AuthMod,Func]), + Ret = (catch apply(AuthMod, Func, [DirData|Args])), + ?DEBUG("api_call -> Ret: ~p",[ret]), + Ret; + O -> + ?DEBUG("api_call -> O: ~p",[O]), + {error, no_such_directory} + end; + bad_password -> + {error,bad_password} + end. + +controlPassword(Password,State,Dir)when Password=:="DummyPassword"-> + bad_password; + +controlPassword(Password,State,Dir)-> + case getPassword(State,Dir) of + Pwd when binary(Pwd)-> + case erlang:md5(Password) of + Pwd -> + ok; + _-> + bad_password + end; + _ -> + bad_password + end. + + +getPassword(State,Dir)-> + case lookup(State#state.tab, Dir) of + [{_,Pwd}]-> + Pwd; + _ -> + {error,bad_password} + end. + +do_update_password(Dir, New, State) -> + ets:insert(State#state.tab, {Dir, erlang:md5(New)}). + +do_add_password(Dir, Password, State) -> + case getPassword(State,Dir) of + PwdExists when binary(PwdExists) -> + {error, dir_protected}; + {error, _} -> + do_update_password(Dir, Password, State) + end. + + +auth_mod_name(DirData) -> + case httpd_util:key1search(DirData, auth_type, plain) of + plain -> mod_auth_plain; + mnesia -> mod_auth_mnesia; + dets -> mod_auth_dets + end. + + +lookup(Db, Key) -> + ets:lookup(Db, Key). + + +make_name(Addr,Port) -> + httpd_util:make_name("httpd_auth",Addr,Port). + + +call(Name, Req) -> + case (catch gen_server:call(Name, Req)) of + {'EXIT', Reason} -> + {error, Reason}; + Reply -> + Reply + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_browser.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_browser.erl new file mode 100644 index 0000000000..1153a5fc47 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_browser.erl @@ -0,0 +1,213 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_browser.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +%% ---------------------------------------------------------------------- +%% +%% Browsers sends a string to the webbserver +%% to identify themsevles. They are a bit nasty +%% since the only thing that the specification really +%% is strict about is that they shall be short +%% tree axamples: +%% +%% Netscape Mozilla/4.75 [en] (X11; U; SunOS 5.8 sun4u) +%% IE5 Mozilla/4.0 (compatible; MSIE 5.0; SP1B; SunOS 5.8 sun4u; X11) +%% Lynx Lynx/2.8.3rel.1 libwww-FM/2.142 +%% +%% ---------------------------------------------------------------------- + +-module(mod_browser). + +%% Remember that the order of the mozilla browsers are +%% important since some browsers include others to behave +%% as they were something else +-define(MOZILLA_BROWSERS,[{opera,"opera"},{msie,"msie"}]). + + +%% If your operatingsystem is not recognized add it to this list. +-define(OPERATIVE_SYSTEMS,[{win3x,["win16","windows 3","windows 16-bit"]}, + {win95,["win95","windows 95"]}, + {win98,["win98", "windows 98"]}, + {winnt,["winnt", "windows nt"]}, + {win2k,["nt 5"]}, + {sunos4,["sunos 4"]}, + {sunos5,["sunos 5"]}, + {sun,["sunos"]}, + {aix,["aix"]}, + {linux,["linux"]}, + {sco,["sco","unix_sv"]}, + {freebsd,["freebsd"]}, + {bsd,["bsd"]}]). + +-define(LYNX,lynx). +-define(MOZILLA,mozilla). +-define(EMACS,emacs). +-define(STAROFFICE,soffice). +-define(MOSAIC,mosaic). +-define(NETSCAPE,netscape). +-define(UNKOWN,unknown). + +-include("httpd.hrl"). + +-export([do/1, test/0, getBrowser/1]). + + +do(Info) -> + case httpd_util:key1search(Info#mod.data,status) of + {Status_code,PhraseArgs,Reason} -> + {proceed,Info#mod.data}; + undefined -> + {proceed,[{'user-agent',getBrowser1(Info)}|Info#mod.data]} + end. + +getBrowser1(Info) -> + PHead=Info#mod.parsed_header, + case httpd_util:key1search(PHead,"User-Agent") of + undefined-> + undefined; + AgentString -> + getBrowser(AgentString) + end. + +getBrowser(AgentString) -> + LAgentString = httpd_util:to_lower(AgentString), + case regexp:first_match(LAgentString,"^[^ ]*") of + {match,Start,Length} -> + Browser=lists:sublist(LAgentString,Start,Length), + case browserType(Browser) of + {mozilla,Vsn} -> + {getMozilla(LAgentString, + ?MOZILLA_BROWSERS,{?NETSCAPE,Vsn}), + operativeSystem(LAgentString)}; + AnyBrowser -> + {AnyBrowser,operativeSystem(LAgentString)} + end; + nomatch -> + browserType(LAgentString) + end. + +browserType([$l,$y,$n,$x|Version]) -> + {?LYNX,browserVersion(Version)}; +browserType([$m,$o,$z,$i,$l,$l,$a|Version]) -> + {?MOZILLA,browserVersion(Version)}; +browserType([$e,$m,$a,$c,$s|Version]) -> + {?EMACS,browserVersion(Version)}; +browserType([$e,$t,$a,$r,$o,$f,$f,$i,$c,$e|Version]) -> + {?STAROFFICE,browserVersion(Version)}; +browserType([$m,$o,$s,$a,$i,$c|Version]) -> + {?MOSAIC,browserVersion(Version)}; +browserType(Unknown)-> + unknown. + + +browserVersion([$/|VsnString]) -> + case catch list_to_float(VsnString) of + Number when float(Number) -> + Number; + Whatever -> + case string:span(VsnString,"1234567890.") of + 0 -> + unknown; + VLength -> + Vsn = string:substr(VsnString,1,VLength), + case string:tokens(Vsn,".") of + [Number] -> + list_to_float(Number++".0"); + [Major,Minor|_MinorMinor] -> + list_to_float(Major++"."++Minor) + end + end + end; +browserVersion(VsnString) -> + browserVersion([$/|VsnString]). + +operativeSystem(OpString) -> + operativeSystem(OpString, ?OPERATIVE_SYSTEMS). + +operativeSystem(OpString,[]) -> + unknown; +operativeSystem(OpString,[{RetVal,RegExps}|Rest]) -> + case controlOperativeSystem(OpString,RegExps) of + true-> + RetVal; + _ -> + operativeSystem(OpString,Rest) + end. + +controlOperativeSystem(OpString,[]) -> + false; +controlOperativeSystem(OpString,[Regexp|Regexps]) -> + case regexp:match(OpString,Regexp) of + {match,_,_}-> + true; + nomatch-> + controlOperativeSystem(OpString,Regexps) + end. + + +%% OK this is ugly but thats the only way since +%% all browsers dont conform to the name/vsn standard +%% First we check if it is one of the browsers that +%% not are the default mozillaborwser against the regexp +%% for the different browsers. if no match it a mozilla +%% browser i.e opera netscape or internet explorer + +getMozilla(AgentString,[],Default) -> + Default; +getMozilla(AgentString,[{Agent,AgentRegExp}|Rest],Default) -> + case regexp:match(AgentString,AgentRegExp) of + {match,_,_} -> + {Agent,getVersion(AgentString,AgentRegExp)}; + nomatch -> + getMozilla(AgentString,Rest,Default) + end. + +getVersion(AgentString,AgentRegExp) -> + case regexp:match(AgentString,AgentRegExp++"[0-9\.\ ]*") of + {match,Start,Length} when length(AgentRegExp) < Length -> + %% Ok we got the number split it out + RealStart=Start+length(AgentRegExp), + RealLength=Length-length(AgentRegExp), + VsnString=string:substr(AgentString,RealStart,RealLength), + case string:strip(VsnString,both,$\ ) of + [] -> + unknown; + Vsn -> + case string:tokens(Vsn,".") of + [Number]-> + list_to_float(Number++".0"); + [Major,Minor|_MinorMinor]-> + list_to_float(Major++"."++Minor) + end + end; + nomatch -> + unknown + end. + + +test()-> + io:format("~n--------------------------------------------------------~n"), + Res1=getBrowser("Mozilla/4.75 [en] (X11; U; SunOS 5.8 sun4u)"), + io:format("~p",[Res1]), + io:format("~n--------------------------------------------------------~n"), + io:format("~n--------------------------------------------------------~n"), + Res2=getBrowser("Mozilla/4.0 (compatible; MSIE 5.0; SP1B; SunOS 5.8 sun4u; X11)"), + io:format("~p",[Res2]), + io:format("~n--------------------------------------------------------~n"), + io:format("~n--------------------------------------------------------~n"), + Res3=getBrowser("Lynx/2.8.3rel.1 libwww-FM/2.142"), + io:format("~p",[Res3]), + io:format("~n--------------------------------------------------------~n"). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_cgi.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_cgi.erl new file mode 100644 index 0000000000..d3f67eb77a --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_cgi.erl @@ -0,0 +1,692 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_cgi.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_cgi). +-export([do/1,env/3,status_code/1,load/2]). + +%%Exports to the interface for sending chunked data +%% to http/1.1 users and full responses to http/1.0 +-export([send/5,final_send/4, update_status_code/2,get_new_size/2]). +-include("httpd.hrl"). + +-define(VMODULE,"CGI"). +-include("httpd_verbosity.hrl"). + +-define(GATEWAY_INTERFACE,"CGI/1.1"). +-define(DEFAULT_CGI_TIMEOUT,15000). + +%% do + +do(Info) -> + ?vtrace("do",[]), + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode, PhraseArgs, Reason} -> + {proceed, Info#mod.data}; + %% No status code has been generated! + undefined -> + ?vtrace("do -> no status code has been generated", []), + case httpd_util:key1search(Info#mod.data,response) of + %% No response has been generated! + undefined -> + ?vtrace("do -> no response has been generated", []), + RequestURI = + case httpd_util:key1search(Info#mod.data, + new_request_uri) of + undefined -> + Info#mod.request_uri; + Value -> + Value + end, + ?vtrace("do -> RequestURI: ~p", [RequestURI]), + ScriptAliases = + httpd_util:multi_lookup(Info#mod.config_db, + script_alias), + ?vtrace("do -> ScriptAliases: ~p", [ScriptAliases]), + case mod_alias:real_script_name(Info#mod.config_db, + RequestURI, + ScriptAliases) of + {Script, AfterScript} -> + exec_script(Info, Script, AfterScript, RequestURI); + not_a_script -> + {proceed,Info#mod.data} + end; + %% A response has been generated or sent! + Response -> + {proceed,Info#mod.data} + end + end. + + +%% is_executable(File) -> +%% ?DEBUG("is_executable -> entry with~n" +%% " File: ~s",[File]), +%% Dir = filename:dirname(File), +%% FileName = filename:basename(File), +%% is_executable(FileName,Dir). +%% +%% is_executable(FileName,Dir) -> +%% ?DEBUG("is_executable -> entry with~n" +%% " Dir: ~s~n" +%% " FileName: ~s",[Dir,FileName]), +%% case os:find_executable(FileName, Dir) of +%% false -> +%% false; +%% _ -> +%% true +%% end. + + +%% ------------------------- +%% Start temporary (hopefully) fix for win32 +%% OTP-3627 +%% + +is_executable(File) -> + Dir = filename:dirname(File), + FileName = filename:basename(File), + case os:type() of + {win32,_} -> + is_win32_executable(Dir,FileName); + _ -> + is_other_executable(Dir,FileName) + end. + + +is_win32_executable(D,F) -> + case ends_with(F,[".bat",".exe",".com"]) of + false -> + %% This is why we cant use 'os:find_executable' directly. + %% It assumes that executable files is given without extension + case os:find_executable(F,D) of + false -> + false; + _ -> + true + end; + true -> + case file:read_file_info(D ++ "/" ++ F) of + {ok,_} -> + true; + _ -> + false + end + end. + + +is_other_executable(D,F) -> + case os:find_executable(F,D) of + false -> + false; + _ -> + true + end. + + +ends_with(File,[]) -> + false; +ends_with(File,[Ext|Rest]) -> + case ends_with1(File,Ext) of + true -> + true; + false -> + ends_with(File,Rest) + end. + +ends_with1(S,E) when length(S) >= length(E) -> + case to_lower(string:right(S,length(E))) of + E -> + true; + _ -> + false + end; +ends_with1(_S,_E) -> + false. + + +to_lower(S) -> to_lower(S,[]). + +to_lower([],L) -> lists:reverse(L); +to_lower([H|T],L) -> to_lower(T,[to_lower1(H)|L]). + +to_lower1(C) when C >= $A, C =< $Z -> + C + ($a - $A); +to_lower1(C) -> + C. + +%% +%% End fix +%% --------------------------------- + + +env(VarName, Value) -> + {VarName, Value}. + +env(Info, Script, AfterScript) -> + ?vtrace("env -> entry with" + "~n Script: ~p" + "~n AfterScript: ~p", + [Script, AfterScript]), + {_, RemoteAddr} = (Info#mod.init_data)#init_data.peername, + ServerName = (Info#mod.init_data)#init_data.resolve, + PH = parsed_header(Info#mod.parsed_header), + Env = + [env("SERVER_SOFTWARE",?SERVER_SOFTWARE), + env("SERVER_NAME",ServerName), + env("GATEWAY_INTERFACE",?GATEWAY_INTERFACE), + env("SERVER_PROTOCOL",?SERVER_PROTOCOL), + env("SERVER_PORT", + integer_to_list(httpd_util:lookup(Info#mod.config_db,port,80))), + env("REQUEST_METHOD",Info#mod.method), + env("REMOTE_ADDR",RemoteAddr), + env("SCRIPT_NAME",Script)], + Env1 = + case Info#mod.method of + "GET" -> + case AfterScript of + {[], QueryString} -> + [env("QUERY_STRING", QueryString)|Env]; + {PathInfo, []} -> + Aliases = httpd_util:multi_lookup( + Info#mod.config_db,alias), + {_, PathTranslated, _} = + mod_alias:real_name( + Info#mod.config_db, PathInfo, Aliases), + [Env| + [env("PATH_INFO","/"++httpd_util:decode_hex(PathInfo)), + env("PATH_TRANSLATED",PathTranslated)]]; + {PathInfo, QueryString} -> + Aliases = httpd_util:multi_lookup( + Info#mod.config_db,alias), + {_, PathTranslated, _} = + mod_alias:real_name( + Info#mod.config_db, PathInfo, Aliases), + [Env| + [env("PATH_INFO", + httpd_util:decode_hex(PathInfo)), + env("PATH_TRANSLATED",PathTranslated), + env("QUERY_STRING", QueryString)]]; + [] -> + Env + end; + "POST" -> + [env("CONTENT_LENGTH", + integer_to_list(httpd_util:flatlength( + Info#mod.entity_body)))|Env]; + _ -> + Env + end, + Env2 = + case httpd_util:key1search(Info#mod.data,remote_user) of + undefined -> + Env1; + RemoteUser -> + [env("REMOTE_USER",RemoteUser)|Env1] %% OTP-4416 + end, + lists:flatten([Env2|PH]). + + +parsed_header(List) -> + parsed_header(List, []). + +parsed_header([], SoFar) -> + SoFar; +parsed_header([{Name,[Value|R1]}|R2], SoFar) when list(Value)-> + NewName=lists:map(fun(X) -> if X == $- -> $_; true -> X end end,Name), + Env = env("HTTP_"++httpd_util:to_upper(NewName), + multi_value([Value|R1])), + parsed_header(R2, [Env|SoFar]); + +parsed_header([{Name,Value}|Rest], SoFar) -> + {ok,NewName,_} = regexp:gsub(Name, "-", "_"), + Env=env("HTTP_"++httpd_util:to_upper(NewName),Value), + parsed_header(Rest, [Env|SoFar]). + + +multi_value([]) -> + []; +multi_value([Value]) -> + Value; +multi_value([Value|Rest]) -> + Value++", "++multi_value(Rest). + + +exec_script(Info, Script, AfterScript, RequestURI) -> + ?vdebug("exec_script -> entry with" + "~n Script: ~p" + "~n AfterScript: ~p", + [Script,AfterScript]), + exec_script(is_executable(Script),Info,Script,AfterScript,RequestURI). + +exec_script(true, Info, Script, AfterScript, RequestURI) -> + ?vtrace("exec_script -> entry when script is executable",[]), + process_flag(trap_exit,true), + Dir = filename:dirname(Script), + [Script_Name|_] = string:tokens(RequestURI, "?"), + Env = env(Info, Script_Name, AfterScript), + Port = (catch open_port({spawn,Script},[stream,{cd, Dir},{env, Env}])), + ?vtrace("exec_script -> Port: ~w",[Port]), + case Port of + P when port(P) -> + %% Send entity_body to port. + Res = case Info#mod.entity_body of + [] -> + true; + EntityBody -> + (catch port_command(Port, EntityBody)) + end, + case Res of + {'EXIT',Reason} -> + ?vlog("port send failed:" + "~n Port: ~p" + "~n URI: ~p" + "~n Reason: ~p", + [Port,Info#mod.request_uri,Reason]), + exit({open_cmd_failed,Reason, + [{mod,?MODULE},{port,Port}, + {uri,Info#mod.request_uri}, + {script,Script},{env,Env},{dir,Dir}, + {ebody_size,sz(Info#mod.entity_body)}]}); + true -> + proxy(Info, Port) + end; + {'EXIT',Reason} -> + ?vlog("open port failed: exit" + "~n URI: ~p" + "~n Reason: ~p", + [Info#mod.request_uri,Reason]), + exit({open_port_failed,Reason, + [{mod,?MODULE},{uri,Info#mod.request_uri},{script,Script}, + {env,Env},{dir,Dir}]}); + O -> + ?vlog("open port failed: unknown result" + "~n URI: ~p" + "~n O: ~p", + [Info#mod.request_uri,O]), + exit({open_port_failed,O, + [{mod,?MODULE},{uri,Info#mod.request_uri},{script,Script}, + {env,Env},{dir,Dir}]}) + end; + +exec_script(false,Info,Script,_AfterScript,_RequestURI) -> + ?vlog("script ~s not executable",[Script]), + {proceed, + [{status, + {404,Info#mod.request_uri, + ?NICE("You don't have permission to execute " ++ + Info#mod.request_uri ++ " on this server")}}| + Info#mod.data]}. + + + +%% +%% Socket <-> Port communication +%% + +proxy(#mod{config_db = ConfigDb} = Info, Port) -> + Timeout = httpd_util:lookup(ConfigDb, cgi_timeout, ?DEFAULT_CGI_TIMEOUT), + proxy(Info, Port, 0, undefined,[], Timeout). + +proxy(Info, Port, Size, StatusCode, AccResponse, Timeout) -> + ?vdebug("proxy -> entry with" + "~n Size: ~p" + "~n StatusCode ~p" + "~n Timeout: ~p", + [Size, StatusCode, Timeout]), + receive + {Port, {data, Response}} when port(Port) -> + ?vtrace("proxy -> got some data from the port",[]), + + NewStatusCode = update_status_code(StatusCode, Response), + + ?vtrace("proxy -> NewStatusCode: ~p",[NewStatusCode]), + case send(Info, NewStatusCode, Response, Size, AccResponse) of + socket_closed -> + ?vtrace("proxy -> socket closed: kill port",[]), + (catch port_close(Port)), % KILL the port !!!! + process_flag(trap_exit,false), + {proceed, + [{response,{already_sent,200,Size}}|Info#mod.data]}; + + head_sent -> + ?vtrace("proxy -> head sent: kill port",[]), + (catch port_close(Port)), % KILL the port !!!! + process_flag(trap_exit,false), + {proceed, + [{response,{already_sent,200,Size}}|Info#mod.data]}; + + {http_response, NewAccResponse} -> + ?vtrace("proxy -> head response: continue",[]), + NewSize = get_new_size(Size, Response), + proxy(Info, Port, NewSize, NewStatusCode, + NewAccResponse, Timeout); + + _ -> + ?vtrace("proxy -> continue",[]), + %% The data is sent and the socket is not closed, continue + NewSize = get_new_size(Size, Response), + proxy(Info, Port, NewSize, NewStatusCode, + "nonempty", Timeout) + end; + + {'EXIT', Port, normal} when port(Port) -> + ?vtrace("proxy -> exit signal from port: normal",[]), + NewStatusCode = update_status_code(StatusCode,AccResponse), + final_send(Info,NewStatusCode,Size,AccResponse), + process_flag(trap_exit,false), + {proceed, [{response,{already_sent,200,Size}}|Info#mod.data]}; + + {'EXIT', Port, Reason} when port(Port) -> + ?vtrace("proxy -> exit signal from port: ~p",[Reason]), + process_flag(trap_exit, false), + {proceed, [{status,{400,none,reason(Reason)}}|Info#mod.data]}; + + {'EXIT', Pid, Reason} when pid(Pid) -> + %% This is the case that a linked process has died, + %% It would be nice to response with a server error + %% but since the heade alredy is sent + ?vtrace("proxy -> exit signal from ~p: ~p",[Pid, Reason]), + proxy(Info, Port, Size, StatusCode, AccResponse, Timeout); + + %% This should not happen + WhatEver -> + ?vinfo("proxy -> received garbage: ~n~p", [WhatEver]), + NewStatusCode = update_status_code(StatusCode, AccResponse), + final_send(Info, StatusCode, Size, AccResponse), + process_flag(trap_exit, false), + {proceed, [{response,{already_sent,200,Size}}|Info#mod.data]} + + after Timeout -> + ?vlog("proxy -> timeout",[]), + (catch port_close(Port)), % KILL the port !!!! + httpd_socket:close(Info#mod.socket_type, Info#mod.socket), + process_flag(trap_exit,false), + {proceed,[{response,{already_sent,200,Size}}|Info#mod.data]} + end. + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% The functions that handles the sending of the data to the client %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%---------------------------------------------------------------------- +%% Send the header the first time the size of the body is Zero +%%---------------------------------------------------------------------- + +send(#mod{method = "HEAD"} = Info, StatusCode, Response, 0, []) -> + first_handle_head_request(Info, StatusCode, Response); +send(Info, StatusCode, Response, 0, []) -> + first_handle_other_request(Info, StatusCode, Response); + +%%---------------------------------------------------------------------- +%% The size of the body is bigger than zero => +%% we have a part of the body to send +%%---------------------------------------------------------------------- +send(Info, StatusCode, Response, Size, AccResponse) -> + handle_other_request(Info, StatusCode, Response). + + +%%---------------------------------------------------------------------- +%% The function is called the last time when the port has closed +%%---------------------------------------------------------------------- + +final_send(Info, StatusCode, Size, AccResponse)-> + final_handle_other_request(Info, StatusCode). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% The code that handles the head requests %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%---------------------------------------------------------------------- +%% The request is a head request if its a HTPT/1.1 request answer to it +%% otherwise we must collect the size of hte body before we can answer. +%% Return Values: +%% head_sent +%%---------------------------------------------------------------------- +first_handle_head_request(Info, StatusCode, Response)-> + case Info#mod.http_version of + "HTTP/1.1" -> + %% Since we have all we need to create the header create it + %% send it and return head_sent. + case httpd_util:split(Response,"\r\n\r\n|\n\n",2) of + {ok, [HeadEnd, Rest]} -> + HeadEnd1 = removeStatus(HeadEnd), + httpd_socket:deliver(Info#mod.socket_type,Info#mod.socket, + [create_header(Info,StatusCode), + HeadEnd1,"\r\n\r\n"]); + _ -> + httpd_socket:deliver(Info#mod.socket_type,Info#mod.socket, + [create_header(Info, StatusCode), + "Content-Type:text/html\r\n\r\n"]) + end; + _ -> + Response1= case regexp:split(Response,"\r\n\r\n|\n\n") of + {ok,[HeadEnd|Rest]} -> + removeStatus(HeadEnd); + _ -> + ["Content-Type:text/html"] + end, + H1 = httpd_util:header(StatusCode,Info#mod.connection), + httpd_socket:deliver(Info#mod.socket_type,Info#mod.socket, + [H1,Response1,"\r\n\r\n"]) + end, + head_sent. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% Handle the requests that is to the other methods %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%---------------------------------------------------------------------- +%% Create the http-response header and send it to the user if it is +%% a http/1.1 request otherwise we must accumulate it +%%---------------------------------------------------------------------- +first_handle_other_request(Info,StatusCode,Response)-> + Header = create_header(Info,StatusCode), + Response1 = + case httpd_util:split(Response,"\r\n\r\n|\n\n",2) of + {ok,[HeadPart,[]]} -> + [Header, removeStatus(HeadPart),"\r\n\r\n"]; + + {ok,[HeadPart,BodyPart]} -> + [Header, removeStatus(HeadPart), "\r\n\r\n", + httpd_util:integer_to_hexlist(length(BodyPart)), + "\r\n", BodyPart]; + _WhatEver -> + %% No response header field from the cgi-script, + %% Just a body + [Header, "Content-Type:text/html","\r\n\r\n", + httpd_util:integer_to_hexlist(length(Response)), + "\r\n", Response] + end, + httpd_socket:deliver(Info#mod.socket_type,Info#mod.socket, Response1). + + +handle_other_request(#mod{http_version = "HTTP/1.1", + socket_type = Type, socket = Sock} = Info, + StatusCode, Response0) -> + Response = create_chunk(Info, Response0), + httpd_socket:deliver(Type, Sock, Response); +handle_other_request(#mod{socket_type = Type, socket = Sock} = Info, + StatusCode, Response) -> + httpd_socket:deliver(Type, Sock, Response). + + +final_handle_other_request(#mod{http_version = "HTTP/1.1", + socket_type = Type, socket = Sock}, + StatusCode) -> + httpd_socket:deliver(Type, Sock, "0\r\n"); +final_handle_other_request(#mod{socket_type = Type, socket = Sock}, + StatusCode) -> + httpd_socket:close(Type, Sock), + socket_closed. + + +create_chunk(_Info, Response) -> + HEXSize = httpd_util:integer_to_hexlist(length(lists:flatten(Response))), + HEXSize++"\r\n"++Response++"\r\n". + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% The various helper functions %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +update_status_code(undefined, Response) -> + case status_code(Response) of + {ok, StatusCode1} -> + StatusCode1; + _ -> + ?vlog("invalid response from script:~n~p", [Response]), + 500 + end; +update_status_code(StatusCode,_Response)-> + StatusCode. + + +get_new_size(0,Response)-> + case httpd_util:split(Response,"\r\n\r\n|\n\n",2) of + {ok,[Head,Body]}-> + length(lists:flatten(Body)); + _ -> + %%No header in the respone + length(lists:flatten(Response)) + end; + +get_new_size(Size,Response)-> + Size+length(lists:flatten(Response)). + +%%---------------------------------------------------------------------- +%% Creates the http-header for a response +%%---------------------------------------------------------------------- +create_header(Info,StatusCode)-> + Cache=case httpd_util:lookup(Info#mod.config_db,script_nocache,false) of + true-> + Date=httpd_util:rfc1123_date(), + "Cache-Control:no-cache\r\nPragma:no-cache\r\nExpires:"++ Date ++ "\r\n"; + false -> + [] + end, + case Info#mod.http_version of + "HTTP/1.1" -> + Header=httpd_util:header(StatusCode, Info#mod.connection), + Header++"Transfer-encoding:chunked\r\n"++Cache; + _ -> + httpd_util:header(StatusCode,Info#mod.connection)++Cache + end. + + + +%% status_code + +status_code(Response) -> + case httpd_util:split(Response,"\n\n|\r\n\r\n",2) of + {ok,[Header,Body]} -> + case regexp:split(Header,"\n|\r\n") of + {ok,HeaderFields} -> + {ok,extract_status_code(HeaderFields)}; + {error,_} -> + {error, bad_script_output(Response)} + end; + _ -> + %% No header field in the returned data return 200 the standard code + {ok, 200} + end. + +bad_script_output(Bad) -> + lists:flatten(io_lib:format("Bad script output ~s",[Bad])). + + +extract_status_code([]) -> + 200; +extract_status_code([[$L,$o,$c,$a,$t,$i,$o,$n,$:,$ |_]|_]) -> + 302; +extract_status_code([[$S,$t,$a,$t,$u,$s,$:,$ |CodeAndReason]|_]) -> + case httpd_util:split(CodeAndReason," ",2) of + {ok,[Code,_]} -> + list_to_integer(Code); + {ok,_} -> + 200 + end; +extract_status_code([_|Rest]) -> + extract_status_code(Rest). + + +sz(B) when binary(B) -> {binary,size(B)}; +sz(L) when list(L) -> {list,length(L)}; +sz(_) -> undefined. + + +%% Convert error to printable string +%% +reason({error,emfile}) -> ": To many open files"; +reason({error,{enfile,_}}) -> ": File/port table overflow"; +reason({error,enomem}) -> ": Not enough memory"; +reason({error,eagain}) -> ": No more available OS processes"; +reason(_) -> "". + +removeStatus(Head)-> + case httpd_util:split(Head,"Status:.\r\n",2) of + {ok,[HeadPart,HeadEnd]}-> + HeadPart++HeadEnd; + _ -> + Head + end. + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% There are 2 config directives for mod_cgi: %% +%% ScriptNoCache true|false, defines whether the server shall add %% +%% header fields to stop proxies and %% +%% clients from saving the page in history %% +%% or cache %% +%% %% +%% ScriptTimeout Seconds, The number of seconds that the server %% +%% maximum will wait for the script to %% +%% generate a part of the document %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +load([$S,$c,$r,$i,$p,$t,$N,$o,$C,$a,$c,$h,$e |CacheArg],[])-> + case catch list_to_atom(httpd_conf:clean(CacheArg)) of + true -> + {ok, [], {script_nocache,true}}; + false -> + {ok, [], {script_nocache,false}}; + _ -> + {error, ?NICE(httpd_conf:clean(CacheArg)++ + " is an invalid ScriptNoCache directive")} + end; + +load([$S,$c,$r,$i,$p,$t,$T,$i,$m,$e,$o,$u,$t,$ |Timeout],[])-> + case catch list_to_integer(httpd_conf:clean(Timeout)) of + TimeoutSec when integer(TimeoutSec) -> + {ok, [], {script_timeout,TimeoutSec*1000}}; + _ -> + {error, ?NICE(httpd_conf:clean(Timeout)++ + " is an invalid ScriptTimeout")} + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_dir.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_dir.erl new file mode 100644 index 0000000000..9dda6d9119 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_dir.erl @@ -0,0 +1,266 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_dir.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_dir). +-export([do/1]). + +-include("httpd.hrl"). + +%% do + +do(Info) -> + ?DEBUG("do -> entry",[]), + case Info#mod.method of + "GET" -> + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + {proceed,Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data,response) of + %% No response has been generated! + undefined -> + do_dir(Info); + %% A response has been generated or sent! + Response -> + {proceed,Info#mod.data} + end + end; + %% Not a GET method! + _ -> + {proceed,Info#mod.data} + end. + +do_dir(Info) -> + ?DEBUG("do_dir -> Request URI: ~p",[Info#mod.request_uri]), + Path = mod_alias:path(Info#mod.data,Info#mod.config_db, + Info#mod.request_uri), + DefaultPath = mod_alias:default_index(Info#mod.config_db,Path), + %% Is it a directory? + case file:read_file_info(DefaultPath) of + {ok,FileInfo} when FileInfo#file_info.type == directory -> + DecodedRequestURI = + httpd_util:decode_hex(Info#mod.request_uri), + ?DEBUG("do_dir -> ~n" + " Path: ~p~n" + " DefaultPath: ~p~n" + " DecodedRequestURI: ~p", + [Path,DefaultPath,DecodedRequestURI]), + case dir(DefaultPath,string:strip(DecodedRequestURI,right,$/),Info#mod.config_db) of + {ok, Dir} -> + Head=[{content_type,"text/html"}, + {content_length,integer_to_list(httpd_util:flatlength(Dir))}, + {date,httpd_util:rfc1123_date(FileInfo#file_info.mtime)}, + {code,200}], + {proceed,[{response,{response,Head,Dir}}, + {mime_type,"text/html"}|Info#mod.data]}; + {error, Reason} -> + ?ERROR("do_dir -> dir operation failed: ~p",[Reason]), + {proceed, + [{status,{404,Info#mod.request_uri,Reason}}| + Info#mod.data]} + end; + {ok,FileInfo} -> + ?DEBUG("do_dir -> ~n" + " Path: ~p~n" + " DefaultPath: ~p~n" + " FileInfo: ~p", + [Path,DefaultPath,FileInfo]), + {proceed,Info#mod.data}; + {error,Reason} -> + ?LOG("do_dir -> failed reading file info (~p) for: ~p", + [Reason,DefaultPath]), + {proceed, + [{status,read_file_info_error(Reason,Info,DefaultPath)}| + Info#mod.data]} + end. + +dir(Path,RequestURI,ConfigDB) -> + case file:list_dir(Path) of + {ok,FileList} -> + SortedFileList=lists:sort(FileList), + {ok,[header(Path,RequestURI), + body(Path,RequestURI,ConfigDB,SortedFileList), + footer(Path,SortedFileList)]}; + {error,Reason} -> + {error,?NICE("Can't open directory "++Path++": "++Reason)} + end. + +%% header + +header(Path,RequestURI) -> + Header= + "<HTML>\n<HEAD>\n<TITLE>Index of "++RequestURI++"</TITLE>\n</HEAD>\n<BODY>\n<H1>Index of "++ + RequestURI++"</H1>\n<PRE><IMG SRC=\""++icon(blank)++ + "\" ALT=" "> Name Last modified Size Description +<HR>\n", + case regexp:sub(RequestURI,"[^/]*\$","") of + {ok,"/",_} -> + Header; + {ok,ParentRequestURI,_} -> + {ok,ParentPath,_}=regexp:sub(string:strip(Path,right,$/),"[^/]*\$",""), + Header++format(ParentPath,ParentRequestURI) + end. + +format(Path,RequestURI) -> + {ok,FileInfo}=file:read_file_info(Path), + {{Year,Month,Day},{Hour,Minute,Second}}=FileInfo#file_info.mtime, + io_lib:format("<IMG SRC=\"~s\" ALT=\"[~s]\"> <A HREF=\"~s\">Parent directory</A> ~2.2.0w-~s-~w ~2.2.0w:~2.2.0w -\n", + [icon(back),"DIR",RequestURI,Day, + httpd_util:month(Month),Year,Hour,Minute]). + +%% body + +body(Path,RequestURI,ConfigDB,[]) -> + []; +body(Path,RequestURI,ConfigDB,[Entry|Rest]) -> + [format(Path,RequestURI,ConfigDB,Entry)|body(Path,RequestURI,ConfigDB,Rest)]. + +format(Path,RequestURI,ConfigDB,Entry) -> + case file:read_file_info(Path++"/"++Entry) of + {ok,FileInfo} when FileInfo#file_info.type == directory -> + {{Year,Month,Day},{Hour,Minute,Second}}=FileInfo#file_info.mtime, + EntryLength=length(Entry), + if + EntryLength > 21 -> + io_lib:format("<IMG SRC=\"~s\" ALT=\"[~s]\"> <A HREF=\"~s\">~-21.s..</A>~2.2.0w-~s-~w ~2.2.0w:~2.2.0w -\n", + [icon(folder),"DIR",RequestURI++"/"++Entry++"/",Entry, + Day,httpd_util:month(Month),Year,Hour,Minute]); + true -> + io_lib:format("<IMG SRC=\"~s\" ALT=\"[~s]\"> <A HREF=\"~s\">~s</A>~*.*c~2.2.0w-~s-~w ~2.2.0w:~2.2.0w -\n", + [icon(folder),"DIR",RequestURI++"/"++Entry++"/",Entry, + 23-EntryLength,23-EntryLength,$ ,Day, + httpd_util:month(Month),Year,Hour,Minute]) + end; + {ok,FileInfo} -> + {{Year,Month,Day},{Hour,Minute,Second}}=FileInfo#file_info.mtime, + Suffix=httpd_util:suffix(Entry), + MimeType=httpd_util:lookup_mime(ConfigDB,Suffix,""), + EntryLength=length(Entry), + if + EntryLength > 21 -> + io_lib:format("<IMG SRC=\"~s\" ALT=\"[~s]\"> <A HREF=\"~s\">~-21.s..</A>~2.2.0w-~s-~w ~2.2.0w:~2.2.0w~8wk ~s\n", + [icon(Suffix,MimeType),Suffix,RequestURI++"/"++Entry, + Entry,Day,httpd_util:month(Month),Year,Hour,Minute, + trunc(FileInfo#file_info.size/1024+1),MimeType]); + true -> + io_lib:format("<IMG SRC=\"~s\" ALT=\"[~s]\"> <A HREF=\"~s\">~s</A>~*.*c~2.2.0w-~s-~w ~2.2.0w:~2.2.0w~8wk ~s\n", + [icon(Suffix,MimeType),Suffix,RequestURI++"/"++Entry, + Entry,23-EntryLength,23-EntryLength,$ ,Day, + httpd_util:month(Month),Year,Hour,Minute, + trunc(FileInfo#file_info.size/1024+1),MimeType]) + end; + {error,Reason} -> + "" + end. + +%% footer + +footer(Path,FileList) -> + case lists:member("README",FileList) of + true -> + {ok,Body}=file:read_file(Path++"/README"), + "</PRE>\n<HR>\n<PRE>\n"++binary_to_list(Body)++ + "\n</PRE>\n</BODY>\n</HTML>\n"; + false -> + "</PRE>\n</BODY>\n</HTML>\n" + end. + +%% +%% Icon mappings are hard-wired ala default Apache (Ugly!) +%% + +icon(Suffix,MimeType) -> + case icon(Suffix) of + undefined -> + case MimeType of + [$t,$e,$x,$t,$/|_] -> + "/icons/text.gif"; + [$i,$m,$a,$g,$e,$/|_] -> + "/icons/image2.gif"; + [$a,$u,$d,$i,$o,$/|_] -> + "/icons/sound2.gif"; + [$v,$i,$d,$e,$o,$/|_] -> + "/icons/movie.gif"; + _ -> + "/icons/unknown.gif" + end; + Icon -> + Icon + end. + +icon(blank) -> "/icons/blank.gif"; +icon(back) -> "/icons/back.gif"; +icon(folder) -> "/icons/folder.gif"; +icon("bin") -> "/icons/binary.gif"; +icon("exe") -> "/icons/binary.gif"; +icon("hqx") -> "/icons/binhex.gif"; +icon("tar") -> "/icons/tar.gif"; +icon("wrl") -> "/icons/world2.gif"; +icon("wrl.gz") -> "/icons/world2.gif"; +icon("vrml") -> "/icons/world2.gif"; +icon("vrm") -> "/icons/world2.gif"; +icon("iv") -> "/icons/world2.gif"; +icon("Z") -> "/icons/compressed.gif"; +icon("z") -> "/icons/compressed.gif"; +icon("tgz") -> "/icons/compressed.gif"; +icon("gz") -> "/icons/compressed.gif"; +icon("zip") -> "/icons/compressed.gif"; +icon("ps") -> "/icons/a.gif"; +icon("ai") -> "/icons/a.gif"; +icon("eps") -> "/icons/a.gif"; +icon("html") -> "/icons/layout.gif"; +icon("shtml") -> "/icons/layout.gif"; +icon("htm") -> "/icons/layout.gif"; +icon("pdf") -> "/icons/layout.gif"; +icon("txt") -> "/icons/text.gif"; +icon("erl") -> "/icons/burst.gif"; +icon("c") -> "/icons/c.gif"; +icon("pl") -> "/icons/p.gif"; +icon("py") -> "/icons/p.gif"; +icon("for") -> "/icons/f.gif"; +icon("dvi") -> "/icons/dvi.gif"; +icon("uu") -> "/icons/uuencoded.gif"; +icon("conf") -> "/icons/script.gif"; +icon("sh") -> "/icons/script.gif"; +icon("shar") -> "/icons/script.gif"; +icon("csh") -> "/icons/script.gif"; +icon("ksh") -> "/icons/script.gif"; +icon("tcl") -> "/icons/script.gif"; +icon("tex") -> "/icons/tex.gif"; +icon("core") -> "/icons/tex.gif"; +icon(_) -> undefined. + + +read_file_info_error(eacces,Info,Path) -> + read_file_info_error(403,Info,Path, + ": Missing search permissions for one " + "of the parent directories"); +read_file_info_error(enoent,Info,Path) -> + read_file_info_error(404,Info,Path,""); +read_file_info_error(enotdir,Info,Path) -> + read_file_info_error(404,Info,Path, + ": A component of the file name is not a directory"); +read_file_info_error(_,Info,Path) -> + read_file_info_error(500,none,Path,""). + +read_file_info_error(StatusCode,none,Path,Reason) -> + {StatusCode,none,?NICE("Can't access "++Path++Reason)}; +read_file_info_error(StatusCode,Info,Path,Reason) -> + {StatusCode,Info#mod.request_uri, + ?NICE("Can't access "++Path++Reason)}. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_disk_log.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_disk_log.erl new file mode 100644 index 0000000000..bb175f24b0 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_disk_log.erl @@ -0,0 +1,404 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_disk_log.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_disk_log). +-export([do/1,error_log/5,security_log/2,load/2,store/2,remove/1]). + +-export([report_error/2]). + +-define(VMODULE,"DISK_LOG"). +-include("httpd_verbosity.hrl"). + +-include("httpd.hrl"). + +%% do + +do(Info) -> + AuthUser = auth_user(Info#mod.data), + Date = custom_date(), + log_internal_info(Info,Date,Info#mod.data), + LogFormat = get_log_format(Info#mod.config_db), + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + transfer_log(Info, "-", AuthUser, Date, StatusCode, 0, LogFormat), + if + StatusCode >= 400 -> + error_log(Info, Date, Reason, LogFormat); + true -> + not_an_error + end, + {proceed,Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data,response) of + {already_sent,StatusCode,Size} -> + transfer_log(Info, "-", AuthUser, Date, StatusCode, + Size, LogFormat), + {proceed,Info#mod.data}; + + {response, Head, Body} -> + Size = httpd_util:key1search(Head, content_length, 0), + Code = httpd_util:key1search(Head, code, 200), + transfer_log(Info, "-", AuthUser, Date, Code, + Size, LogFormat), + {proceed,Info#mod.data}; + + {StatusCode,Response} -> + transfer_log(Info, "-", AuthUser, Date, 200, + httpd_util:flatlength(Response), LogFormat), + {proceed,Info#mod.data}; + undefined -> + transfer_log(Info, "-", AuthUser, Date, 200, + 0, LogFormat), + {proceed,Info#mod.data} + end + end. + +custom_date() -> + LocalTime = calendar:local_time(), + UniversalTime = calendar:universal_time(), + Minutes = round(diff_in_minutes(LocalTime,UniversalTime)), + {{YYYY,MM,DD},{Hour,Min,Sec}} = LocalTime, + Date = + io_lib:format("~.2.0w/~.3s/~.4w:~.2.0w:~.2.0w:~.2.0w ~c~.2.0w~.2.0w", + [DD,httpd_util:month(MM),YYYY,Hour,Min,Sec,sign(Minutes), + abs(Minutes) div 60,abs(Minutes) rem 60]), + lists:flatten(Date). + +diff_in_minutes(L,U) -> + (calendar:datetime_to_gregorian_seconds(L) - + calendar:datetime_to_gregorian_seconds(U))/60. + +sign(Minutes) when Minutes > 0 -> + $+; +sign(Minutes) -> + $-. + +auth_user(Data) -> + case httpd_util:key1search(Data,remote_user) of + undefined -> + "-"; + RemoteUser -> + RemoteUser + end. + +%% log_internal_info + +log_internal_info(Info,Date,[]) -> + ok; +log_internal_info(Info,Date,[{internal_info,Reason}|Rest]) -> + Format = get_log_format(Info#mod.config_db), + error_log(Info,Date,Reason,Format), + log_internal_info(Info,Date,Rest); +log_internal_info(Info,Date,[_|Rest]) -> + log_internal_info(Info,Date,Rest). + + +%% transfer_log + +transfer_log(Info,RFC931,AuthUser,Date,StatusCode,Bytes,Format) -> + case httpd_util:lookup(Info#mod.config_db,transfer_disk_log) of + undefined -> + no_transfer_log; + TransferDiskLog -> + {PortNumber,RemoteHost}=(Info#mod.init_data)#init_data.peername, + Entry = io_lib:format("~s ~s ~s [~s] \"~s\" ~w ~w~n", + [RemoteHost,RFC931,AuthUser,Date, + Info#mod.request_line,StatusCode,Bytes]), + write(TransferDiskLog, Entry, Format) + end. + + +%% error_log + +error_log(Info, Date, Reason, Format) -> + Format=get_log_format(Info#mod.config_db), + case httpd_util:lookup(Info#mod.config_db,error_disk_log) of + undefined -> + no_error_log; + ErrorDiskLog -> + {PortNumber,RemoteHost}=(Info#mod.init_data)#init_data.peername, + Entry = + io_lib:format("[~s] access to ~s failed for ~s, reason: ~p~n", + [Date, Info#mod.request_uri, + RemoteHost, Reason]), + write(ErrorDiskLog, Entry, Format) + end. + +error_log(SocketType, Socket, ConfigDB, {PortNumber, RemoteHost}, Reason) -> + Format = get_log_format(ConfigDB), + case httpd_util:lookup(ConfigDB,error_disk_log) of + undefined -> + no_error_log; + ErrorDiskLog -> + Date = custom_date(), + Entry = + io_lib:format("[~s] server crash for ~s, reason: ~p~n", + [Date,RemoteHost,Reason]), + write(ErrorDiskLog, Entry, Format), + ok + end. + + +%% security_log + +security_log(ConfigDB, Event) -> + Format = get_log_format(ConfigDB), + case httpd_util:lookup(ConfigDB,security_disk_log) of + undefined -> + no_error_log; + DiskLog -> + Date = custom_date(), + Entry = io_lib:format("[~s] ~s ~n", [Date, Event]), + write(DiskLog, Entry, Format), + ok + end. + +report_error(ConfigDB, Error) -> + Format = get_log_format(ConfigDB), + case httpd_util:lookup(ConfigDB, error_disk_log) of + undefined -> + no_error_log; + ErrorDiskLog -> + Date = custom_date(), + Entry = io_lib:format("[~s] reporting error: ~s",[Date,Error]), + write(ErrorDiskLog, Entry, Format), + ok + end. + +%%---------------------------------------------------------------------- +%% Get the current format of the disklog +%%---------------------------------------------------------------------- +get_log_format(ConfigDB)-> + httpd_util:lookup(ConfigDB,disk_log_format,external). + + +%% +%% Configuration +%% + +%% load + +load([$T,$r,$a,$n,$s,$f,$e,$r,$D,$i,$s,$k,$L,$o,$g,$S,$i,$z,$e,$ | + TransferDiskLogSize],[]) -> + case regexp:split(TransferDiskLogSize," ") of + {ok,[MaxBytes,MaxFiles]} -> + case httpd_conf:make_integer(MaxBytes) of + {ok,MaxBytesInteger} -> + case httpd_conf:make_integer(MaxFiles) of + {ok,MaxFilesInteger} -> + {ok,[],{transfer_disk_log_size, + {MaxBytesInteger,MaxFilesInteger}}}; + {error,_} -> + {error, + ?NICE(httpd_conf:clean(TransferDiskLogSize)++ + " is an invalid TransferDiskLogSize")} + end; + {error,_} -> + {error,?NICE(httpd_conf:clean(TransferDiskLogSize)++ + " is an invalid TransferDiskLogSize")} + end + end; +load([$T,$r,$a,$n,$s,$f,$e,$r,$D,$i,$s,$k,$L,$o,$g,$ |TransferDiskLog],[]) -> + {ok,[],{transfer_disk_log,httpd_conf:clean(TransferDiskLog)}}; + +load([$E,$r,$r,$o,$r,$D,$i,$s,$k,$L,$o,$g,$S,$i,$z,$e,$ | ErrorDiskLogSize],[]) -> + case regexp:split(ErrorDiskLogSize," ") of + {ok,[MaxBytes,MaxFiles]} -> + case httpd_conf:make_integer(MaxBytes) of + {ok,MaxBytesInteger} -> + case httpd_conf:make_integer(MaxFiles) of + {ok,MaxFilesInteger} -> + {ok,[],{error_disk_log_size, + {MaxBytesInteger,MaxFilesInteger}}}; + {error,_} -> + {error,?NICE(httpd_conf:clean(ErrorDiskLogSize)++ + " is an invalid ErrorDiskLogSize")} + end; + {error,_} -> + {error,?NICE(httpd_conf:clean(ErrorDiskLogSize)++ + " is an invalid ErrorDiskLogSize")} + end + end; +load([$E,$r,$r,$o,$r,$D,$i,$s,$k,$L,$o,$g,$ |ErrorDiskLog],[]) -> + {ok, [], {error_disk_log, httpd_conf:clean(ErrorDiskLog)}}; + +load([$S,$e,$c,$u,$r,$i,$t,$y,$D,$i,$s,$k,$L,$o,$g,$S,$i,$z,$e,$ |SecurityDiskLogSize],[]) -> + case regexp:split(SecurityDiskLogSize, " ") of + {ok, [MaxBytes, MaxFiles]} -> + case httpd_conf:make_integer(MaxBytes) of + {ok, MaxBytesInteger} -> + case httpd_conf:make_integer(MaxFiles) of + {ok, MaxFilesInteger} -> + {ok, [], {security_disk_log_size, + {MaxBytesInteger, MaxFilesInteger}}}; + {error,_} -> + {error, ?NICE(httpd_conf:clean(SecurityDiskLogSize)++ + " is an invalid SecurityDiskLogSize")} + end; + {error, _} -> + {error, ?NICE(httpd_conf:clean(SecurityDiskLogSize)++ + " is an invalid SecurityDiskLogSize")} + end + end; +load([$S,$e,$c,$u,$r,$i,$t,$y,$D,$i,$s,$k,$L,$o,$g,$ |SecurityDiskLog],[]) -> + {ok, [], {security_disk_log, httpd_conf:clean(SecurityDiskLog)}}; + +load([$D,$i,$s,$k,$L,$o,$g,$F,$o,$r,$m,$a,$t,$ |Format],[]) -> + case httpd_conf:clean(Format) of + "internal" -> + {ok, [], {disk_log_format,internal}}; + "external" -> + {ok, [], {disk_log_format,external}}; + _Default -> + {ok, [], {disk_log_format,external}} + end. + +%% store + +store({transfer_disk_log,TransferDiskLog},ConfigList) -> + case create_disk_log(TransferDiskLog, transfer_disk_log_size, ConfigList) of + {ok,TransferDB} -> + {ok,{transfer_disk_log,TransferDB}}; + {error,Reason} -> + {error,Reason} + end; +store({security_disk_log,SecurityDiskLog},ConfigList) -> + case create_disk_log(SecurityDiskLog, security_disk_log_size, ConfigList) of + {ok,SecurityDB} -> + {ok,{security_disk_log,SecurityDB}}; + {error,Reason} -> + {error,Reason} + end; +store({error_disk_log,ErrorDiskLog},ConfigList) -> + case create_disk_log(ErrorDiskLog, error_disk_log_size, ConfigList) of + {ok,ErrorDB} -> + {ok,{error_disk_log,ErrorDB}}; + {error,Reason} -> + {error,Reason} + end. + + +%%---------------------------------------------------------------------- +%% Open or creates the disklogs +%%---------------------------------------------------------------------- +log_size(ConfigList, Tag) -> + httpd_util:key1search(ConfigList, Tag, {500*1024,8}). + +create_disk_log(LogFile, SizeTag, ConfigList) -> + Filename = httpd_conf:clean(LogFile), + {MaxBytes, MaxFiles} = log_size(ConfigList, SizeTag), + case filename:pathtype(Filename) of + absolute -> + create_disk_log(Filename, MaxBytes, MaxFiles, ConfigList); + volumerelative -> + create_disk_log(Filename, MaxBytes, MaxFiles, ConfigList); + relative -> + case httpd_util:key1search(ConfigList,server_root) of + undefined -> + {error, + ?NICE(Filename++ + " is an invalid ErrorLog beacuse ServerRoot is not defined")}; + ServerRoot -> + AbsoluteFilename = filename:join(ServerRoot,Filename), + create_disk_log(AbsoluteFilename, MaxBytes, MaxFiles, + ConfigList) + end + end. + +create_disk_log(Filename, MaxBytes, MaxFiles, ConfigList) -> + Format = httpd_util:key1search(ConfigList, disk_log_format, external), + open(Filename, MaxBytes, MaxFiles, Format). + + + +%% remove +remove(ConfigDB) -> + lists:foreach(fun([DiskLog]) -> close(DiskLog) end, + ets:match(ConfigDB,{transfer_disk_log,'$1'})), + lists:foreach(fun([DiskLog]) -> close(DiskLog) end, + ets:match(ConfigDB,{error_disk_log,'$1'})), + ok. + + +%% +%% Some disk_log wrapper functions: +%% + +%%---------------------------------------------------------------------- +%% Function: open/4 +%% Description: Open a disk log file. +%% Control which format the disk log will be in. The external file +%% format is used as default since that format was used by older +%% implementations of inets. +%% +%% When the internal disk log format is used, we will do some extra +%% controls. If the files are valid, try to repair them and if +%% thats not possible, truncate. +%%---------------------------------------------------------------------- + +open(Filename, MaxBytes, MaxFiles, internal) -> + Opts = [{format, internal}, {repair, truncate}], + open1(Filename, MaxBytes, MaxFiles, Opts); +open(Filename, MaxBytes, MaxFiles, _) -> + Opts = [{format, external}], + open1(Filename, MaxBytes, MaxFiles, Opts). + +open1(Filename, MaxBytes, MaxFiles, Opts0) -> + Opts1 = [{name, Filename}, {file, Filename}, {type, wrap}] ++ Opts0, + case open2(Opts1, {MaxBytes, MaxFiles}) of + {ok, LogDB} -> + {ok, LogDB}; + {error, Reason} -> + ?vlog("failed opening disk log with args:" + "~n Filename: ~p" + "~n MaxBytes: ~p" + "~n MaxFiles: ~p" + "~n Opts0: ~p" + "~nfor reason:" + "~n ~p", [Filename, MaxBytes, MaxFiles, Opts0, Reason]), + {error, + ?NICE("Can't create " ++ Filename ++ + lists:flatten(io_lib:format(", ~p",[Reason])))}; + _ -> + {error, ?NICE("Can't create "++Filename)} + end. + +open2(Opts, Size) -> + case disk_log:open(Opts) of + {error, {badarg, size}} -> + %% File did not exist, add the size option and try again + disk_log:open([{size, Size} | Opts]); + Else -> + Else + end. + + +%%---------------------------------------------------------------------- +%% Actually writes the entry to the disk_log. If the log is an +%% internal disk_log write it with log otherwise with blog. +%%---------------------------------------------------------------------- +write(Log, Entry, internal) -> + disk_log:log(Log, Entry); + +write(Log, Entry, _) -> + disk_log:blog(Log, Entry). + +%% Close the log file +close(Log) -> + disk_log:close(Log). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_esi.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_esi.erl new file mode 100644 index 0000000000..cb211749da --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_esi.erl @@ -0,0 +1,481 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_esi.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_esi). +-export([do/1,load/2]). + +%%Functions provided to help erl scheme alias programmer to +%%Create dynamic webpages that are sent back to the user during +%%Generation +-export([deliver/2]). + + +-include("httpd.hrl"). + +-define(VMODULE,"ESI"). +-include("httpd_verbosity.hrl"). + +-define(GATEWAY_INTERFACE,"CGI/1.1"). +-define(DEFAULT_ERL_TIMEOUT,15000). +%% do + +do(Info) -> + ?vtrace("do",[]), + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + {proceed,Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data,response) of + %% No response has been generated! + undefined -> + case erl_or_eval(Info#mod.request_uri, + Info#mod.config_db) of + {eval,CGIBody,Modules} -> + eval(Info,Info#mod.method,CGIBody,Modules); + {erl,CGIBody,Modules} -> + erl(Info,Info#mod.method,CGIBody,Modules); + proceed -> + {proceed,Info#mod.data} + end; + %% A response has been generated or sent! + Response -> + {proceed,Info#mod.data} + end + end. + + + +%% erl_or_eval + +erl_or_eval(RequestURI, ConfigDB) -> + case erlp(RequestURI, ConfigDB) of + false -> + case evalp(RequestURI, ConfigDB) of + false -> + ?vtrace("neither erl nor eval",[]), + proceed; + Other -> + Other + end; + Other -> + Other + end. + +erlp(RequestURI, ConfigDB) -> + case httpd_util:multi_lookup(ConfigDB, erl_script_alias) of + [] -> + false; + AliasMods -> + erlp_find_alias(RequestURI,AliasMods) + end. + +erlp_find_alias(_RequestURI,[]) -> + ?vtrace("erlp_find_alias -> no match",[]), + false; +erlp_find_alias(RequestURI,[{Alias,Modules}|Rest]) -> + case regexp:first_match(RequestURI,"^"++Alias++"/") of + {match,1,Length} -> + ?vtrace("erlp -> match with Length: ~p",[Length]), + {erl,string:substr(RequestURI,Length+1),Modules}; + nomatch -> + erlp_find_alias(RequestURI,Rest) + end. + +evalp(RequestURI, ConfigDB) -> + case httpd_util:multi_lookup(ConfigDB, eval_script_alias) of + [] -> + false; + AliasMods -> + evalp_find_alias(RequestURI,AliasMods) + end. + +evalp_find_alias(_RequestURI,[]) -> + ?vtrace("evalp_find_alias -> no match",[]), + false; +evalp_find_alias(RequestURI,[{Alias,Modules}|Rest]) -> + case regexp:first_match(RequestURI,"^"++Alias++"\\?") of + {match, 1, Length} -> + ?vtrace("evalp_find_alias -> match with Length: ~p",[Length]), + {eval, string:substr(RequestURI,Length+1),Modules}; + nomatch -> + evalp_find_alias(RequestURI,Rest) + end. + + +%% +%% Erl mechanism +%% + +%%This is exactly the same as the GET method the difference is that +%%The response must not contain any data expect the response header + + +erl(Info,"HEAD",CGIBody,Modules) -> + erl(Info,"GET",CGIBody,Modules); + +erl(Info,"GET",CGIBody,Modules) -> + ?vtrace("erl GET request",[]), + case httpd_util:split(CGIBody,":|%3A|/",2) of + {ok, [Mod,FuncAndInput]} -> + ?vtrace("~n Mod: ~p" + "~n FuncAndInput: ~p",[Mod,FuncAndInput]), + case httpd_util:split(FuncAndInput,"[\?/]",2) of + {ok, [Func,Input]} -> + ?vtrace("~n Func: ~p" + "~n Input: ~p",[Func,Input]), + exec(Info,"GET",CGIBody,Modules,Mod,Func, + {input_type(FuncAndInput),Input}); + {ok, [Func]} -> + exec(Info,"GET",CGIBody,Modules,Mod,Func,{no_input,""}); + {ok, BadRequest} -> + {proceed,[{status,{400,none,BadRequest}}|Info#mod.data]} + end; + {ok, BadRequest} -> + ?vlog("erl BAD (GET-) request",[]), + {proceed, [{status,{400,none,BadRequest}}|Info#mod.data]} + end; + +erl(Info, "POST", CGIBody, Modules) -> + ?vtrace("erl POST request",[]), + case httpd_util:split(CGIBody,":|%3A|/",2) of + {ok,[Mod,Func]} -> + ?vtrace("~n Mod: ~p" + "~n Func: ~p",[Mod,Func]), + exec(Info,"POST",CGIBody,Modules,Mod,Func, + {entity_body,Info#mod.entity_body}); + {ok,BadRequest} -> + ?vlog("erl BAD (POST-) request",[]), + {proceed,[{status,{400,none,BadRequest}}|Info#mod.data]} + end. + +input_type([]) -> + no_input; +input_type([$/|Rest]) -> + path_info; +input_type([$?|Rest]) -> + query_string; +input_type([First|Rest]) -> + input_type(Rest). + + +%% exec + +exec(Info,Method,CGIBody,["all"],Mod,Func,{Type,Input}) -> + ?vtrace("exec ~s 'all'",[Method]), + exec(Info,Method,CGIBody,[Mod],Mod,Func,{Type,Input}); +exec(Info,Method,CGIBody,Modules,Mod,Func,{Type,Input}) -> + ?vtrace("exec ~s request with:" + "~n Modules: ~p" + "~n Mod: ~p" + "~n Func: ~p" + "~n Type: ~p" + "~n Input: ~p", + [Method,Modules,Mod,Func,Type,Input]), + case lists:member(Mod,Modules) of + true -> + {_,RemoteAddr}=(Info#mod.init_data)#init_data.peername, + ServerName=(Info#mod.init_data)#init_data.resolve, + Env=get_environment(Info,ServerName,Method,RemoteAddr,Type,Input), + ?vtrace("and now call the module",[]), + case try_new_erl_scheme_method(Info,Env,Input,list_to_atom(Mod),list_to_atom(Func)) of + {error,not_new_method}-> + case catch apply(list_to_atom(Mod),list_to_atom(Func),[Env,Input]) of + {'EXIT',Reason} -> + ?vlog("exit with Reason: ~p",[Reason]), + {proceed,[{status,{500,none,Reason}}|Info#mod.data]}; + Response -> + control_response_header(Info,Mod,Func,Response) + end; + ResponseResult-> + ResponseResult + end; + false -> + ?vlog("unknown module",[]), + {proceed,[{status,{403,Info#mod.request_uri, + ?NICE("Client not authorized to evaluate: "++CGIBody)}}|Info#mod.data]} + end. + +control_response_header(Info,Mod,Func,Response)-> + case control_response(Response,Info,Mod,Func) of + {proceed,[{response,{StatusCode,Response}}|Rest]} -> + case httpd_util:lookup(Info#mod.config_db,erl_script_nocache,false) of + true -> + case httpd_util:split(Response,"\r\n\r\n|\n\n",2) of + {ok,[Head,Body]}-> + Date=httpd_util:rfc1123_date(), + Cache="Cache-Control:no-cache\r\nPragma:no-cache\r\nExpires:"++ Date ++ "\r\n", + {proceed,[{response,{StatusCode,[Head,"\r\n",Cache,"\r\n",Body]}}|Rest]}; + _-> + {proceed,[{response,{StatusCode,Response}}|Rest]} + end; + WhatEver-> + {proceed,[{response,{StatusCode,Response}}|Rest]} + end; + WhatEver-> + WhatEver + end. + +control_response(Response,Info,Mod,Func)-> + ?vdebug("Response: ~n~p",[Response]), + case mod_cgi:status_code(lists:flatten(Response)) of + {ok,StatusCode} -> + {proceed,[{response,{StatusCode,Response}}|Info#mod.data]}; + {error,Reason} -> + {proceed, + [{status,{400,none, + ?NICE("Error in "++Mod++":"++Func++"/2: "++ + lists:flatten(io_lib:format("~p",[Reason])))}}| + Info#mod.data]} + end. + +parsed_header([]) -> + []; +parsed_header([{Name,[Value|R1]}|R2]) when list(Value) -> + NewName=lists:map(fun(X) -> if X == $- -> $_; true -> X end end,Name), + [{list_to_atom("http_"++httpd_util:to_lower(NewName)), + multi_value([Value|R1])}|parsed_header(R2)]; +parsed_header([{Name,Value}|Rest]) when list(Value)-> + {ok,NewName,_}=regexp:gsub(Name,"-","_"), + [{list_to_atom("http_"++httpd_util:to_lower(NewName)),Value}| + parsed_header(Rest)]. + +multi_value([]) -> + []; +multi_value([Value]) -> + Value; +multi_value([Value|Rest]) -> + Value++", "++multi_value(Rest). + +%% +%% Eval mechanism +%% + + +eval(Info,"POST",CGIBody,Modules) -> + ?vtrace("eval(POST) -> method not supported",[]), + {proceed,[{status,{501,{"POST",Info#mod.request_uri,Info#mod.http_version}, + ?NICE("Eval mechanism doesn't support method POST")}}| + Info#mod.data]}; + +eval(Info,"HEAD",CGIBody,Modules) -> + %%The function that sends the data in httpd_response handles HEAD reqest by not + %% Sending the body + eval(Info,"GET",CGIBody,Modules); + + +eval(Info,"GET",CGIBody,Modules) -> + ?vtrace("eval(GET) -> entry when" + "~n Modules: ~p",[Modules]), + case auth(CGIBody,Modules) of + true -> + case lib:eval_str(string:concat(CGIBody,". ")) of + {error,Reason} -> + ?vlog("eval -> error:" + "~n Reason: ~p",[Reason]), + {proceed,[{status,{500,none,Reason}}|Info#mod.data]}; + {ok,Response} -> + ?vtrace("eval -> ok:" + "~n Response: ~p",[Response]), + case mod_cgi:status_code(lists:flatten(Response)) of + {ok,StatusCode} -> + {proceed,[{response,{StatusCode,Response}}|Info#mod.data]}; + {error,Reason} -> + {proceed,[{status,{400,none,Reason}}|Info#mod.data]} + end + end; + false -> + ?vlog("eval -> auth failed",[]), + {proceed,[{status, + {403,Info#mod.request_uri, + ?NICE("Client not authorized to evaluate: "++CGIBody)}}| + Info#mod.data]} + end. + +auth(CGIBody,["all"]) -> + true; +auth(CGIBody,Modules) -> + case regexp:match(CGIBody,"^[^\:(%3A)]*") of + {match,Start,Length} -> + lists:member(string:substr(CGIBody,Start,Length),Modules); + nomatch -> + false + end. + +%%---------------------------------------------------------------------- +%%Creates the environment list that will be the first arg to the +%%Functions that is called through the ErlScript Schema +%%---------------------------------------------------------------------- + +get_environment(Info,ServerName,Method,RemoteAddr,Type,Input)-> + Env=[{server_software,?SERVER_SOFTWARE}, + {server_name,ServerName}, + {gateway_interface,?GATEWAY_INTERFACE}, + {server_protocol,?SERVER_PROTOCOL}, + {server_port,httpd_util:lookup(Info#mod.config_db,port,80)}, + {request_method,Method}, + {remote_addr,RemoteAddr}, + {script_name,Info#mod.request_uri}| + parsed_header(Info#mod.parsed_header)], + get_environment(Type,Input,Env,Info). + + +get_environment(Type,Input,Env,Info)-> + Env1=case Type of + query_string -> + [{query_string,Input}|Env]; + path_info -> + Aliases=httpd_util:multi_lookup(Info#mod.config_db,alias), + {_,PathTranslated,_}=mod_alias:real_name(Info#mod.config_db,[$/|Input],Aliases), + [{path_info,"/"++httpd_util:decode_hex(Input)}, + {path_translated,PathTranslated}|Env]; + entity_body -> + [{content_length,httpd_util:flatlength(Input)}|Env]; + no_input -> + Env + end, + get_environment(Info,Env1). + +get_environment(Info,Env)-> + case httpd_util:key1search(Info#mod.data,remote_user) of + undefined -> + Env; + RemoteUser -> + [{remote_user,RemoteUser}|Env] + end. +%% +%% Configuration +%% + +%% load + +load([$E,$r,$l,$S,$c,$r,$i,$p,$t,$A,$l,$i,$a,$s,$ |ErlScriptAlias],[]) -> + case regexp:split(ErlScriptAlias," ") of + {ok, [ErlName|Modules]} -> + {ok, [], {erl_script_alias, {ErlName,Modules}}}; + {ok, _} -> + {error,?NICE(httpd_conf:clean(ErlScriptAlias)++ + " is an invalid ErlScriptAlias")} + end; +load([$E,$v,$a,$l,$S,$c,$r,$i,$p,$t,$A,$l,$i,$a,$s,$ |EvalScriptAlias],[]) -> + case regexp:split(EvalScriptAlias, " ") of + {ok, [EvalName|Modules]} -> + {ok, [], {eval_script_alias, {EvalName,Modules}}}; + {ok, _} -> + {error, ?NICE(httpd_conf:clean(EvalScriptAlias)++ + " is an invalid EvalScriptAlias")} + end; +load([$E,$r,$l,$S,$c,$r,$i,$p,$t,$T,$i,$m,$e,$o,$u,$t,$ |Timeout],[])-> + case catch list_to_integer(httpd_conf:clean(Timeout)) of + TimeoutSec when integer(TimeoutSec) -> + {ok, [], {erl_script_timeout,TimeoutSec*1000}}; + _ -> + {error, ?NICE(httpd_conf:clean(Timeout)++ + " is an invalid ErlScriptTimeout")} + end; +load([$E,$r,$l,$S,$c,$r,$i,$p,$t,$N,$o,$C,$a,$c,$h,$e |CacheArg],[])-> + case catch list_to_atom(httpd_conf:clean(CacheArg)) of + true -> + {ok, [], {erl_script_nocache,true}}; + false -> + {ok, [], {erl_script_nocache,false}}; + _ -> + {error, ?NICE(httpd_conf:clean(CacheArg)++ + " is an invalid ErlScriptNoCache directive")} + end. + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% Functions below handles the data from the dynamic webpages %% +%% That sends data back to the user part by part %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%---------------------------------------------------------------------- +%%Deliver is the callback function users can call to deliver back data to the +%%client +%%---------------------------------------------------------------------- + +deliver(SessionID,Data)when pid(SessionID) -> + SessionID ! {ok,Data}, + ok; +deliver(SessionID,Data) -> + {error,bad_sessionID}. + + +%%---------------------------------------------------------------------- +%% The method that tries to execute the new format +%%---------------------------------------------------------------------- + +%%It would be nicer to use erlang:function_exported/3 but if the +%%Module isn't loaded the function says that it is not loaded + + +try_new_erl_scheme_method(Info,Env,Input,Mod,Func)-> + process_flag(trap_exit,true), + Pid=spawn_link(Mod,Func,[self(),Env,Input]), + Timeout=httpd_util:lookup(Info#mod.config_db,erl_script_timeout,?DEFAULT_ERL_TIMEOUT), + RetVal=receive_response_data(Info,Pid,0,undefined,[],Timeout), + process_flag(trap_exit,false), + RetVal. + + +%%---------------------------------------------------------------------- +%%The function recieves the data from the process that generates the page +%%and send the data to the client through the mod_cgi:send function +%%---------------------------------------------------------------------- + +receive_response_data(Info,Pid,Size,StatusCode,AccResponse,Timeout) -> + ?DEBUG("receive_response_data()-> Script Size: ~p,StatusCode ~p ,Timeout: ~p ~n",[Size,StatusCode,Timeout]), + receive + {ok, Response} -> + NewStatusCode=mod_cgi:update_status_code(StatusCode,Response), + + ?DEBUG("receive_response_data/2 NewStatusCode: ~p~n",[NewStatusCode]), + case mod_cgi:send(Info, NewStatusCode,Response, Size,AccResponse) of + socket_closed -> + (catch exit(Pid,final)), + {proceed,[{response,{already_sent,200,Size}}|Info#mod.data]}; + head_sent-> + (catch exit(Pid,final)), + {proceed,[{response,{already_sent,200,Size}}|Info#mod.data]}; + _ -> + %%The data is sent and the socket is not closed contine + NewSize = mod_cgi:get_new_size(Size,Response), + receive_response_data(Info,Pid,NewSize,NewStatusCode,"notempty",Timeout) + end; + {'EXIT', Pid, Reason} when AccResponse==[] -> + {error,not_new_method}; + {'EXIT', Pid, Reason} when pid(Pid) -> + NewStatusCode=mod_cgi:update_status_code(StatusCode,AccResponse), + mod_cgi:final_send(Info,NewStatusCode,Size,AccResponse), + {proceed, [{response,{already_sent,200,Size}}|Info#mod.data]}; + %% This should not happen! + WhatEver -> + NewStatusCode=mod_cgi:update_status_code(StatusCode,AccResponse), + mod_cgi:final_send(Info,StatusCode,Size,AccResponse), + {proceed, [{response,{already_sent,200,Size}}|Info#mod.data]} + after + Timeout -> + (catch exit(Pid,timeout)), % KILL the port !!!! + httpd_socket:close(Info#mod.socket_type,Info#mod.socket), + {proceed,[{response,{already_sent,200,Size}}|Info#mod.data]} + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_get.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_get.erl new file mode 100644 index 0000000000..4136d31669 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_get.erl @@ -0,0 +1,151 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_get.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_get). +-export([do/1]). +-include("httpd.hrl"). + +%% do + +do(Info) -> + ?DEBUG("do -> entry",[]), + case Info#mod.method of + "GET" -> + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + {proceed,Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data,response) of + %% No response has been generated! + undefined -> + do_get(Info); + %% A response has been generated or sent! + Response -> + {proceed,Info#mod.data} + end + end; + %% Not a GET method! + _ -> + {proceed,Info#mod.data} + end. + + +do_get(Info) -> + ?DEBUG("do_get -> Request URI: ~p",[Info#mod.request_uri]), + Path = mod_alias:path(Info#mod.data, Info#mod.config_db, + Info#mod.request_uri), + {FileInfo, LastModified} =get_modification_date(Path), + + send_response(Info#mod.socket,Info#mod.socket_type,Path,Info,FileInfo,LastModified). + + +%%The common case when no range is specified +send_response(Socket,SocketType,Path,Info,FileInfo,LastModified)-> + %% Send the file! + %% Find the modification date of the file + case file:open(Path,[raw,binary]) of + {ok, FileDescriptor} -> + ?DEBUG("do_get -> FileDescriptor: ~p",[FileDescriptor]), + Suffix = httpd_util:suffix(Path), + MimeType = httpd_util:lookup_mime_default(Info#mod.config_db, + Suffix,"text/plain"), + %FileInfo=file:read_file_info(Path), + Date = httpd_util:rfc1123_date(), + Size = integer_to_list(FileInfo#file_info.size), + Header=case Info#mod.http_version of + "HTTP/1.1" -> + [httpd_util:header(200, MimeType, Info#mod.connection), + "Last-Modified: ", LastModified, "\r\n", + "Etag: ",httpd_util:create_etag(FileInfo),"\r\n", + "Content-Length: ",Size,"\r\n\r\n"]; + "HTTP/1.0" -> + [httpd_util:header(200, MimeType, Info#mod.connection), + "Last-Modified: ", LastModified, "\r\n", + "Content-Length: ",Size,"\r\n\r\n"] + end, + + send(Info#mod.socket_type, Info#mod.socket, + Header, FileDescriptor), + file:close(FileDescriptor), + {proceed,[{response,{already_sent,200, + FileInfo#file_info.size}}, + {mime_type,MimeType}|Info#mod.data]}; + {error, Reason} -> + + {proceed, + [{status,open_error(Reason,Info,Path)}|Info#mod.data]} + end. + +%% send + +send(SocketType,Socket,Header,FileDescriptor) -> + ?DEBUG("send -> send header",[]), + case httpd_socket:deliver(SocketType,Socket,Header) of + socket_closed -> + ?LOG("send -> socket closed while sending header",[]), + socket_close; + _ -> + send_body(SocketType,Socket,FileDescriptor) + end. + +send_body(SocketType,Socket,FileDescriptor) -> + case file:read(FileDescriptor,?FILE_CHUNK_SIZE) of + {ok,Binary} -> + ?DEBUG("send_body -> send another chunk: ~p",[size(Binary)]), + case httpd_socket:deliver(SocketType,Socket,Binary) of + socket_closed -> + ?LOG("send_body -> socket closed while sending",[]), + socket_close; + _ -> + send_body(SocketType,Socket,FileDescriptor) + end; + eof -> + ?DEBUG("send_body -> done with this file",[]), + eof + end. + + +%% open_error - Handle file open failure +%% +open_error(eacces,Info,Path) -> + open_error(403,Info,Path,""); +open_error(enoent,Info,Path) -> + open_error(404,Info,Path,""); +open_error(enotdir,Info,Path) -> + open_error(404,Info,Path, + ": A component of the file name is not a directory"); +open_error(emfile,_Info,Path) -> + open_error(500,none,Path,": To many open files"); +open_error({enfile,_},_Info,Path) -> + open_error(500,none,Path,": File table overflow"); +open_error(_Reason,_Info,Path) -> + open_error(500,none,Path,""). + +open_error(StatusCode,none,Path,Reason) -> + {StatusCode,none,?NICE("Can't open "++Path++Reason)}; +open_error(StatusCode,Info,Path,Reason) -> + {StatusCode,Info#mod.request_uri,?NICE("Can't open "++Path++Reason)}. + +get_modification_date(Path)-> + case file:read_file_info(Path) of + {ok, FileInfo0} -> + {FileInfo0, httpd_util:rfc1123_date(FileInfo0#file_info.mtime)}; + _ -> + {#file_info{},""} + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_head.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_head.erl new file mode 100644 index 0000000000..ce71e6532e --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_head.erl @@ -0,0 +1,89 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_head.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_head). +-export([do/1]). + +-include("httpd.hrl"). + +%% do + +do(Info) -> + ?DEBUG("do -> entry",[]), + case Info#mod.method of + "HEAD" -> + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + {proceed,Info#mod.data}; + %% No status code has been generated! + _undefined -> + case httpd_util:key1search(Info#mod.data,response) of + %% No response has been generated! + undefined -> + do_head(Info); + %% A response has been sent! Nothing to do about it! + {already_sent,StatusCode,Size} -> + {proceed,Info#mod.data}; + %% A response has been generated! + {StatusCode,Response} -> + {proceed,Info#mod.data} + end + end; + %% Not a HEAD method! + _ -> + {proceed,Info#mod.data} + end. + +do_head(Info) -> + ?DEBUG("do_head -> Request URI: ~p",[Info#mod.request_uri]), + Path = mod_alias:path(Info#mod.data,Info#mod.config_db, + Info#mod.request_uri), + Suffix = httpd_util:suffix(Path), + %% Does the file exists? + case file:read_file_info(Path) of + {ok,FileInfo} -> + MimeType=httpd_util:lookup_mime_default(Info#mod.config_db,Suffix,"text/plain"), + Length=io_lib:write(FileInfo#file_info.size), + Head=[{content_type,MimeType},{content_length,Length},{code,200}], + {proceed,[{response,{response,Head,nobody}}|Info#mod.data]}; + {error,Reason} -> + {proceed, + [{status,read_file_info_error(Reason,Info,Path)}|Info#mod.data]} + end. + +%% read_file_info_error - Handle file info read failure +%% +read_file_info_error(eacces,Info,Path) -> + read_file_info_error(403,Info,Path,""); +read_file_info_error(enoent,Info,Path) -> + read_file_info_error(404,Info,Path,""); +read_file_info_error(enotdir,Info,Path) -> + read_file_info_error(404,Info,Path, + ": A component of the file name is not a directory"); +read_file_info_error(emfile,_Info,Path) -> + read_file_info_error(500,none,Path,": To many open files"); +read_file_info_error({enfile,_},_Info,Path) -> + read_file_info_error(500,none,Path,": File table overflow"); +read_file_info_error(_Reason,_Info,Path) -> + read_file_info_error(500,none,Path,""). + +read_file_info_error(StatusCode,none,Path,Reason) -> + {StatusCode,none,?NICE("Can't access "++Path++Reason)}; +read_file_info_error(StatusCode,Info,Path,Reason) -> + {StatusCode,Info#mod.request_uri, + ?NICE("Can't access "++Path++Reason)}. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_htaccess.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_htaccess.erl new file mode 100644 index 0000000000..3806ce2e06 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_htaccess.erl @@ -0,0 +1,1136 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_htaccess.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% + +-module(mod_htaccess). + +-export([do/1, load/2]). +-export([debug/0]). + +-include("httpd.hrl"). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Public methods that interface the eswapi %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%---------------------------------------------------------------------- +% Public method called by the webbserver to insert the data about +% Names on accessfiles +%---------------------------------------------------------------------- +load([$A,$c,$c,$e,$s,$s,$F,$i,$l,$e,$N,$a,$m,$e|FileNames],Context)-> + CleanFileNames=httpd_conf:clean(FileNames), + %%io:format("\n The filenames is:" ++ FileNames ++ "\n"), + {ok,[],{access_files,string:tokens(CleanFileNames," ")}}. + + +%---------------------------------------------------------------------- +% Public method that the webbserver calls to control the page +%---------------------------------------------------------------------- +do(Info)-> + case httpd_util:key1search(Info#mod.data,status) of + {Status_code,PhraseArgs,Reason}-> + {proceed,Info#mod.data}; + undefined -> + control_path(Info) + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% The functions that start the control if there is a accessfile %% +%% and if so controls if the dir is allowed or not %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%---------------------------------------------------------------------- +%Info = record mod as specified in httpd.hrl +%returns either {proceed,Info#mod.data} +%{proceed,[{status,403....}|Info#mod.data]} +%{proceed,[{status,401....}|Info#mod.data]} +%{proceed,[{status,500....}|Info#mod.data]} +%---------------------------------------------------------------------- +control_path(Info) -> + Path = mod_alias:path(Info#mod.data, + Info#mod.config_db, + Info#mod.request_uri), + case isErlScriptOrNotAccessibleFile(Path,Info) of + true-> + {proceed,Info#mod.data}; + false-> + case getHtAccessData(Path,Info)of + {ok,public}-> + %%There was no restrictions on the page continue + {proceed,Info#mod.data}; + {error,Reason} -> + %Something got wrong continue or quit??????????????????/ + {proceed,Info#mod.data}; + {accessData,AccessData}-> + controlAllowedMethod(Info,AccessData) + end + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% These methods controls that the method the client used in the %% +%% request is one of the limited %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%---------------------------------------------------------------------- +%Control that if the accessmethod used is in the list of modes to challenge +% +%Info is the mod record as specified in httpd.hrl +%AccessData is an ets table whit the data in the .htaccessfiles +%---------------------------------------------------------------------- +controlAllowedMethod(Info,AccessData)-> + case allowedRequestMethod(Info,AccessData) of + allow-> + %%The request didnt use one of the limited methods + ets:delete(AccessData), + {proceed,Info#mod.data}; + challenge-> + authenticateUser(Info,AccessData) + end. + +%---------------------------------------------------------------------- +%Check the specified access method in the .htaccessfile +%---------------------------------------------------------------------- +allowedRequestMethod(Info,AccessData)-> + case ets:lookup(AccessData,limit) of + [{limit,all}]-> + challenge; + [{limit,Methods}]-> + isLimitedRequestMethod(Info,Methods) + end. + + +%---------------------------------------------------------------------- +%Check the specified accessmethods in the .htaccesfile against the users +%accessmethod +% +%Info is the record from the do call +%Methods is a list of the methods specified in the .htaccessfile +%---------------------------------------------------------------------- +isLimitedRequestMethod(Info,Methods)-> + case lists:member(Info#mod.method,Methods) of + true-> + challenge; + false -> + allow + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% These methods controls that the user comes from an allowwed net %% +%% and if so wheather its a valid user or a challenge shall be %% +%% generated %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%---------------------------------------------------------------------- +%The first thing to control is that the user is from a network +%that has access to the page +%---------------------------------------------------------------------- +authenticateUser(Info,AccessData)-> + case controlNet(Info,AccessData) of + allow-> + %the network is ok control that it is an allowed user + authenticateUser2(Info,AccessData); + deny-> + %The user isnt allowed to access the pages from that network + ets:delete(AccessData), + {proceed,[{status,{403,Info#mod.request_uri, + "Restricted area not allowed from your network"}}|Info#mod.data]} + end. + + +%---------------------------------------------------------------------- +%The network the user comes from is allowed to view the resources +%control whether the user needsto supply a password or not +%---------------------------------------------------------------------- +authenticateUser2(Info,AccessData)-> + case ets:lookup(AccessData,require) of + [{require,AllowedUsers}]-> + case ets:lookup(AccessData,auth_name) of + [{auth_name,Realm}]-> + authenticateUser2(Info,AccessData,Realm,AllowedUsers); + _NoAuthName-> + ets:delete(AccessData), + {break,[{status,{500,none, + ?NICE("mod_htaccess:AuthName directive not specified")}}]} + end; + [] -> + %%No special user is required the network is ok so let + %%the user in + ets:delete(AccessData), + {proceed,Info#mod.data} + end. + + +%---------------------------------------------------------------------- +%The user must send a userId and a password to get the resource +%Control if its already in the http-request +%if the file with users is bad send an 500 response +%---------------------------------------------------------------------- +authenticateUser2(Info,AccessData,Realm,AllowedUsers)-> + case authenticateUser(Info,AccessData,AllowedUsers) of + allow -> + ets:delete(AccessData), + {user,Name,Pwd}=getAuthenticatingDataFromHeader(Info), + {proceed, [{remote_user_name,Name}|Info#mod.data]}; + challenge-> + ets:delete(AccessData), + ReasonPhrase = httpd_util:reason_phrase(401), + Message = httpd_util:message(401,none,Info#mod.config_db), + {proceed, + [{response, + {401, + ["WWW-Authenticate: Basic realm=\"",Realm, + "\"\r\n\r\n","<HTML>\n<HEAD>\n<TITLE>", + ReasonPhrase,"</TITLE>\n", + "</HEAD>\n<BODY>\n<H1>",ReasonPhrase, + "</H1>\n",Message,"\n</BODY>\n</HTML>\n"]}}| + Info#mod.data]}; + deny-> + ets:delete(AccessData), + {break,[{status,{500,none, + ?NICE("mod_htaccess:Bad path to user or group file")}}]} + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% Methods that validate the netwqork the user comes from %% +%% according to the allowed networks %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%--------------------------------------------------------------------- +%Controls the users networkaddress agains the specifed networks to +%allow or deny +% +%returns either allow or deny +%---------------------------------------------------------------------- +controlNet(Info,AccessData)-> + UserNetwork=getUserNetworkAddress(Info), + case getAllowDenyOrder(AccessData) of + {_deny,[],_allow,[]}-> + allow; + {deny,[],allow,AllowedNetworks}-> + controlIfAllowed(AllowedNetworks,UserNetwork,allow,deny); + {allow,AllowedNetworks,deny,[]}-> + controlIfAllowed(AllowedNetworks,UserNetwork,allow,deny); + + {deny,DeniedNetworks,allow,[]}-> + controlIfAllowed(DeniedNetworks,UserNetwork,allow,deny); + {allow,[],deny,DeniedNetworks}-> + controlIfAllowed(DeniedNetworks,UserNetwork,allow,deny); + + {deny,DeniedNetworks,allow,AllowedNetworks}-> + controlDenyAllow(DeniedNetworks,AllowedNetworks,UserNetwork); + {allow,AllowedNetworks,deny,DeniedNetworks}-> + controlAllowDeny(AllowedNetworks,DeniedNetworks,UserNetwork) + end. + + +%---------------------------------------------------------------------- +%Returns the users IP-Number +%---------------------------------------------------------------------- +getUserNetworkAddress(Info)-> + {_Socket,Address}=(Info#mod.init_data)#init_data.peername, + Address. + + +%---------------------------------------------------------------------- +%Control the users Ip-number against the ip-numbers in the .htaccessfile +%---------------------------------------------------------------------- +controlIfAllowed(AllowedNetworks,UserNetwork,IfAllowed,IfDenied)-> + case AllowedNetworks of + [{allow,all}]-> + IfAllowed; + [{deny,all}]-> + IfDenied; + [{deny,Networks}]-> + memberNetwork(Networks,UserNetwork,IfDenied,IfAllowed); + [{allow,Networks}]-> + memberNetwork(Networks,UserNetwork,IfAllowed,IfDenied); + _Error-> + IfDenied + end. + + +%---------------------------------------------------------------------% +%The Denycontrol isn't neccessary to preform since the allow control % +%override the deny control % +%---------------------------------------------------------------------% +controlDenyAllow(DeniedNetworks,AllowedNetworks,UserNetwork)-> + case AllowedNetworks of + [{allow,all}]-> + allow; + [{allow,Networks}]-> + case memberNetwork(Networks,UserNetwork) of + true-> + allow; + false-> + deny + end + end. + + +%----------------------------------------------------------------------% +%Control that the user is in the allowed list if so control that the % +%network is in the denied list +%----------------------------------------------------------------------% +controlAllowDeny(AllowedNetworks,DeniedNetworks,UserNetwork)-> + case controlIfAllowed(AllowedNetworks,UserNetwork,allow,deny) of + allow-> + controlIfAllowed(DeniedNetworks,UserNetwork,deny,allow); + deny -> + deny + end. + +%---------------------------------------------------------------------- +%Controls if the users Ipnumber is in the list of either denied or +%allowed networks +%---------------------------------------------------------------------- +memberNetwork(Networks,UserNetwork,IfTrue,IfFalse)-> + case memberNetwork(Networks,UserNetwork) of + true-> + IfTrue; + false-> + IfFalse + end. + + +%---------------------------------------------------------------------- +%regexp match the users ip-address against the networks in the list of +%ipadresses or subnet addresses. +memberNetwork(Networks,UserNetwork)-> + case lists:filter(fun(Net)-> + case regexp:match(UserNetwork, + formatRegexp(Net)) of + {match,1,_}-> + true; + _NotSubNet -> + false + end + end,Networks) of + []-> + false; + MemberNetWork -> + true + end. + + +%---------------------------------------------------------------------- +%Creates a regexp from an ip-number i.e "127.0.0-> "^127[.]0[.]0.*" +%"127.0.0.-> "^127[.]0[.]0[.].*" +%---------------------------------------------------------------------- +formatRegexp(Net)-> + [SubNet1|SubNets]=string:tokens(Net,"."), + NetRegexp=lists:foldl(fun(SubNet,Newnet)-> + Newnet ++ "[.]" ++SubNet + end,"^"++SubNet1,SubNets), + case string:len(Net)-string:rchr(Net,$.) of + 0-> + NetRegexp++"[.].*"; + _-> + NetRegexp++".*" + end. + + +%---------------------------------------------------------------------- +%If the user has specified if the allow or deny check shall be preformed +%first get that order if no order is specified take +%allow - deny since its harder that deny - allow +%---------------------------------------------------------------------- +getAllowDenyOrder(AccessData)-> + case ets:lookup(AccessData,order) of + [{order,{deny,allow}}]-> + {deny,ets:lookup(AccessData,deny), + allow,ets:lookup(AccessData,allow)}; + _DefaultOrder-> + {allow,ets:lookup(AccessData,allow), + deny,ets:lookup(AccessData,deny)} + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% The methods that validates the user %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%---------------------------------------------------------------------- +%Control if there is anyu autheticating data in threquest header +%if so it controls it against the users in the list Allowed Users +%---------------------------------------------------------------------- +authenticateUser(Info,AccessData,AllowedUsers)-> + case getAuthenticatingDataFromHeader(Info) of + {user,User,PassWord}-> + authenticateUser(Info,AccessData,AllowedUsers, + {user,User,PassWord}); + {error,nouser}-> + challenge; + {error,BadData}-> + challenge + end. + + +%---------------------------------------------------------------------- +%Returns the Autheticating data in the http-request +%---------------------------------------------------------------------- +getAuthenticatingDataFromHeader(Info)-> + PrsedHeader=Info#mod.parsed_header, + case httpd_util:key1search(PrsedHeader,"authorization" ) of + undefined-> + {error,nouser}; + [$B,$a,$s,$i,$c,$\ |EncodedString]-> + UnCodedString=httpd_util:decode_base64(EncodedString), + case httpd_util:split(UnCodedString,":",2) of + {ok,[User,PassWord]}-> + {user,User,PassWord}; + {error,Error}-> + {error,Error} + end; + BadCredentials -> + {error,BadCredentials} + end. + + +%---------------------------------------------------------------------- +%Returns a list of all members of the allowed groups +%---------------------------------------------------------------------- +getGroupMembers(Groups,AllowedGroups)-> + Allowed=lists:foldl(fun({group,Name,Members},AllowedMembers)-> + case lists:member(Name,AllowedGroups) of + true-> + AllowedMembers++Members; + false -> + AllowedMembers + end + end,[],Groups), + {ok,Allowed}. + +authenticateUser(Info,AccessData,{{users,[]},{groups,Groups}},User)-> + authenticateUser(Info,AccessData,{groups,Groups},User); +authenticateUser(Info,AccessData,{{users,Users},{groups,[]}},User)-> + authenticateUser(Info,AccessData,{users,Users},User); + +authenticateUser(Info,AccessData,{{users,Users},{groups,Groups}},User)-> + AllowUser=authenticateUser(Info,AccessData,{users,Users},User), + AllowGroup=authenticateUser(Info,AccessData,{groups,Groups},User), + case {AllowGroup,AllowUser} of + {_,allow}-> + allow; + {allow,_}-> + allow; + {challenge,_}-> + challenge; + {_,challenge}-> + challenge; + {_deny,_deny}-> + deny + end; + + +%---------------------------------------------------------------------- +%Controls that the user is a member in one of the allowed group +%---------------------------------------------------------------------- +authenticateUser(Info,AccessData,{groups,AllowedGroups},{user,User,PassWord})-> + case getUsers(AccessData,group_file) of + {group_data,Groups}-> + case getGroupMembers(Groups,AllowedGroups) of + {ok,Members}-> + authenticateUser(Info,AccessData,{users,Members}, + {user,User,PassWord}); + {error,BadData}-> + deny + end; + {error,BadData}-> + deny + end; + + +%---------------------------------------------------------------------- +%Control that the user is one of the allowed users and that the passwd is ok +%---------------------------------------------------------------------- +authenticateUser(Info,AccessData,{users,AllowedUsers},{user,User,PassWord})-> + case lists:member(User,AllowedUsers) of + true-> + %Get the usernames and passwords from the file + case getUsers(AccessData,user_file) of + {error,BadData}-> + deny; + {user_data,Users}-> + %Users is a list of the users in + %the userfile [{user,User,Passwd}] + checkPassWord(Users,{user,User,PassWord}) + end; + false -> + challenge + end. + + +%---------------------------------------------------------------------- +%Control that the user User={user,"UserName","PassWd"} is +%member of the list of Users +%---------------------------------------------------------------------- +checkPassWord(Users,User)-> + case lists:member(User,Users) of + true-> + allow; + false-> + challenge + end. + + +%---------------------------------------------------------------------- +%Get the users in the specified file +%UserOrGroup is an atom that specify if its a group file or a user file +%i.e. group_file or user_file +%---------------------------------------------------------------------- +getUsers({file,FileName},UserOrGroup)-> + case file:open(FileName,[read]) of + {ok,AccessFileHandle} -> + getUsers({stream,AccessFileHandle},[],UserOrGroup); + {error,Reason} -> + {error,{Reason,FileName}} + end; + + +%---------------------------------------------------------------------- +%The method that starts the lokkong for user files +%---------------------------------------------------------------------- + +getUsers(AccessData,UserOrGroup)-> + case ets:lookup(AccessData,UserOrGroup) of + [{UserOrGroup,File}]-> + getUsers({file,File},UserOrGroup); + _ -> + {error,noUsers} + end. + + +%---------------------------------------------------------------------- +%Reads data from the filehandle File to the list FileData and when its +%reach the end it returns the list in a tuple {user_file|group_file,FileData} +%---------------------------------------------------------------------- +getUsers({stream,File},FileData,UserOrGroup)-> + case io:get_line(File,[]) of + eof when UserOrGroup==user_file-> + {user_data,FileData}; + eof when UserOrGroup ==group_file-> + {group_data,FileData}; + Line -> + getUsers({stream,File}, + formatUser(Line,FileData,UserOrGroup),UserOrGroup) + end. + + +%---------------------------------------------------------------------- +%If the line is a comment remove it +%---------------------------------------------------------------------- +formatUser([$#|UserDataComment],FileData,_UserOrgroup)-> + FileData; + + +%---------------------------------------------------------------------- +%The user name in the file is Username:Passwd\n +%Remove the newline sign and split the user name in +%UserName and Password +%---------------------------------------------------------------------- +formatUser(UserData,FileData,UserOrGroup)-> + case string:tokens(UserData," \r\n")of + [User|Whitespace] when UserOrGroup==user_file-> + case string:tokens(User,":") of + [Name,PassWord]-> + [{user,Name,PassWord}|FileData]; + _Error-> + FileData + end; + GroupData when UserOrGroup==group_file -> + parseGroupData(GroupData,FileData); + _Error -> + FileData + end. + + +%---------------------------------------------------------------------- +%if everything is right GroupData is on the form +% ["groupName:", "Member1", "Member2", "Member2" +%---------------------------------------------------------------------- +parseGroupData([GroupName|GroupData],FileData)-> + [{group,formatGroupName(GroupName),GroupData}|FileData]. + + +%---------------------------------------------------------------------- +%the line in the file is GroupName: Member1 Member2 .....MemberN +%Remove the : from the group name +%---------------------------------------------------------------------- +formatGroupName(GroupName)-> + string:strip(GroupName,right,$:). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% Functions that parses the accessfiles %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%---------------------------------------------------------------------- +%Control that the asset is a real file and not a request for an virtual +%asset +%---------------------------------------------------------------------- +isErlScriptOrNotAccessibleFile(Path,Info)-> + case file:read_file_info(Path) of + {ok,_fileInfo}-> + false; + {error,_Reason} -> + true + end. + + +%---------------------------------------------------------------------- +%Path=PathToTheRequestedFile=String +%Innfo=record#mod +%---------------------------------------------------------------------- +getHtAccessData(Path,Info)-> + HtAccessFileNames=getHtAccessFileNames(Info), + case getData(Path,Info,HtAccessFileNames) of + {ok,public}-> + {ok,public}; + {accessData,AccessData}-> + {accessData,AccessData}; + {error,Reason} -> + {error,Reason} + end. + + +%---------------------------------------------------------------------- +%returns the names of the accessfiles +%---------------------------------------------------------------------- +getHtAccessFileNames(Info)-> + case httpd_util:lookup(Info#mod.config_db,access_files) of + undefined-> + [".htaccess"]; + Files-> + Files + end. +%---------------------------------------------------------------------- +%HtAccessFileNames=["accessfileName1",..."AccessFileName2"] +%---------------------------------------------------------------------- +getData(Path,Info,HtAccessFileNames)-> + case regexp:split(Path,"/") of + {error,Error}-> + {error,Error}; + {ok,SplittedPath}-> + getData2(HtAccessFileNames,SplittedPath,Info) + end. + + +%---------------------------------------------------------------------- +%Add to together the data in the Splittedpath up to the path +%that is the alias or the document root +%Since we do not need to control after any accessfiles before here +%---------------------------------------------------------------------- +getData2(HtAccessFileNames,SplittedPath,Info)-> + case getRootPath(SplittedPath,Info) of + {error,Path}-> + {error,Path}; + {ok,StartPath,RestOfSplittedPath} -> + getData2(HtAccessFileNames,StartPath,RestOfSplittedPath,Info) + end. + + +%---------------------------------------------------------------------- +%HtAccessFilenames is a list the names the accesssfiles can have +%Path is the shortest match agains all alias and documentroot +%rest of splitted path is a list of the parts of the path +%Info is the mod recod from the server +%---------------------------------------------------------------------- +getData2(HtAccessFileNames,StartPath,RestOfSplittedPath,Info)-> + case getHtAccessFiles(HtAccessFileNames,StartPath,RestOfSplittedPath) of + []-> + %No accessfile qiut its a public directory + {ok,public}; + Files -> + loadAccessFilesData(Files) + end. + + +%---------------------------------------------------------------------- +%Loads the data in the accessFiles specifiied by +% AccessFiles=["/hoem/public/html/accefile", +% "/home/public/html/priv/accessfile"] +%---------------------------------------------------------------------- +loadAccessFilesData(AccessFiles)-> + loadAccessFilesData(AccessFiles,ets:new(accessData,[])). + + +%---------------------------------------------------------------------- +%Returns the found data +%---------------------------------------------------------------------- +contextToValues(AccessData)-> + case ets:lookup(AccessData,context) of + [{context,Values}]-> + ets:delete(AccessData,context), + insertContext(AccessData,Values), + {accessData,AccessData}; + _Error-> + {error,errorInAccessFile} + end. + + +insertContext(AccessData,[])-> + ok; + +insertContext(AccessData,[{allow,From}|Values])-> + insertDenyAllowContext(AccessData,{allow,From}), + insertContext(AccessData,Values); + +insertContext(AccessData,[{deny,From}|Values])-> + insertDenyAllowContext(AccessData,{deny,From}), + insertContext(AccessData,Values); + +insertContext(AccessData,[{require,{GrpOrUsr,Members}}|Values])-> + case ets:lookup(AccessData,require) of + []when GrpOrUsr==users-> + ets:insert(AccessData,{require,{{users,Members},{groups,[]}}}); + + [{require,{{users,Users},{groups,Groups}}}]when GrpOrUsr==users -> + ets:insert(AccessData,{require,{{users,Users++Members}, + {groups,Groups}}}); + []when GrpOrUsr==groups-> + ets:insert(AccessData,{require,{{users,[]},{groups,Members}}}); + + [{require,{{users,Users},{groups,Groups}}}]when GrpOrUsr==groups -> + ets:insert(AccessData,{require,{{users,Users}, + {groups,Groups++Members}}}) + end, + insertContext(AccessData,Values); + + + +%%limit and order directive need no transforming they areis just to insert +insertContext(AccessData,[Elem|Values])-> + ets:insert(AccessData,Elem), + insertContext(AccessData,Values). + + +insertDenyAllowContext(AccessData,{AllowDeny,From})-> + case From of + all-> + ets:insert(AccessData,{AllowDeny,all}); + AllowedSubnets-> + case ets:lookup(AccessData,AllowDeny) of + []-> + ets:insert(AccessData,{AllowDeny,From}); + [{AllowDeny,all}]-> + ok; + [{AllowDeny,Networks}]-> + ets:insert(AccessData,{allow,Networks++From}) + end + end. + +loadAccessFilesData([],AccessData)-> + %preform context to limits + contextToValues(AccessData), + {accessData,AccessData}; + +%---------------------------------------------------------------------- +%Takes each file in the list and load the data to the ets table +%AccessData +%---------------------------------------------------------------------- +loadAccessFilesData([FileName|FileNames],AccessData)-> + case loadAccessFileData({file,FileName},AccessData) of + overRide-> + loadAccessFilesData(FileNames,AccessData); + noOverRide -> + {accessData,AccessData}; + error-> + ets:delete(AccessData), + {error,errorInAccessFile} + end. + +%---------------------------------------------------------------------- +%opens the filehandle to the specified file +%---------------------------------------------------------------------- +loadAccessFileData({file,FileName},AccessData)-> + case file:open(FileName,[read]) of + {ok,AccessFileHandle}-> + loadAccessFileData({stream,AccessFileHandle},AccessData,[]); + {error,Reason} -> + overRide + end. + +%---------------------------------------------------------------------- +%%look att each line in the file and add them to the database +%%When end of file is reached control i overrride is allowed +%% if so return +%---------------------------------------------------------------------- +loadAccessFileData({stream,File},AccessData,FileData)-> + case io:get_line(File,[]) of + eof-> + insertData(AccessData,FileData), + case ets:match_object(AccessData,{'_',error}) of + []-> + %Case we got no error control that we can override a + %at least some of the values + case ets:match_object(AccessData, + {allow_over_ride,none}) of + []-> + overRide; + _NoOverride-> + noOverRide + end; + Errors-> + error + end; + Line -> + loadAccessFileData({stream,File},AccessData, + insertLine(string:strip(Line,left),FileData)) + end. + +%---------------------------------------------------------------------- +%AccessData is a ets table where the previous found data is inserted +%FileData is a list of the directives in the last parsed file +%before insertion a control is done that the directive is allowed to +%override +%---------------------------------------------------------------------- +insertData(AccessData,{{context,Values},FileData})-> + insertData(AccessData,[{context,Values}|FileData]); + +insertData(AccessData,FileData)-> + case ets:lookup(AccessData,allow_over_ride) of + [{allow_over_ride,all}]-> + lists:foreach(fun(Elem)-> + ets:insert(AccessData,Elem) + end,FileData); + []-> + lists:foreach(fun(Elem)-> + ets:insert(AccessData,Elem) + end,FileData); + [{allow_over_ride,Directives}]when list(Directives)-> + lists:foreach(fun({Key,Value})-> + case lists:member(Key,Directives) of + true-> + ok; + false -> + ets:insert(AccessData,{Key,Value}) + end + end,FileData); + [{allow_over_ride,_}]-> + %Will never appear if the user + %aint doing very strang econfig files + ok + end. +%---------------------------------------------------------------------- +%Take a line in the accessfile and transform it into a tuple that +%later can be inserted in to the ets:table +%---------------------------------------------------------------------- +%%%Here is the alternatives that resides inside the limit context + +insertLine([$o,$r,$d,$e,$r|Order],{{context,Values},FileData})-> + {{context,[{order,getOrder(Order)}|Values]},FileData}; +%%Let the user place a tab in the beginning +insertLine([$\t,$o,$r,$d,$e,$r|Order],{{context,Values},FileData})-> + {{context,[{order,getOrder(Order)}|Values]},FileData}; + +insertLine([$a,$l,$l,$o,$w|Allow],{{context,Values},FileData})-> + {{context,[{allow,getAllowDenyData(Allow)}|Values]},FileData}; +insertLine([$\t,$a,$l,$l,$o,$w|Allow],{{context,Values},FileData})-> + {{context,[{allow,getAllowDenyData(Allow)}|Values]},FileData}; + +insertLine([$d,$e,$n,$y|Deny],{{context,Values},FileData})-> + {{context,[{deny,getAllowDenyData(Deny)}|Values]},FileData}; +insertLine([$\t,$d,$e,$n,$y|Deny],{{context,Values},FileData})-> + {{context,[{deny,getAllowDenyData(Deny)}|Values]},FileData}; + + +insertLine([$r,$e,$q,$u,$i,$r,$e|Require],{{context,Values},FileData})-> + {{context,[{require,getRequireData(Require)}|Values]},FileData}; +insertLine([$\t,$r,$e,$q,$u,$i,$r,$e|Require],{{context,Values},FileData})-> + {{context,[{require,getRequireData(Require)}|Values]},FileData}; + + +insertLine([$<,$/,$L,$i,$m,$i,$t|EndLimit],{Context,FileData})-> + [Context|FileData]; + +insertLine([$<,$L,$i,$m,$i,$t|Limit],FileData)-> + {{context,[{limit,getLimits(Limit)}]}, FileData}; + + + +insertLine([$A,$u,$t,$h,$U,$s,$e,$r,$F,$i,$l,$e,$\ |AuthUserFile],FileData)-> + [{user_file,string:strip(AuthUserFile,right,$\n)}|FileData]; + +insertLine([$A,$u,$t,$h,$G,$r,$o,$u,$p,$F,$i,$l,$e,$\ |AuthGroupFile], + FileData)-> + [{group_file,string:strip(AuthGroupFile,right,$\n)}|FileData]; + +insertLine([$A,$l,$l,$o,$w,$O,$v,$e,$r,$R,$i,$d,$e|AllowOverRide],FileData)-> + [{allow_over_ride,getAllowOverRideData(AllowOverRide)} + |FileData]; + +insertLine([$A,$u,$t,$h,$N,$a,$m,$e,$\ |AuthName],FileData)-> + [{auth_name,string:strip(AuthName,right,$\n)}|FileData]; + +insertLine([$A,$u,$t,$h,$T,$y,$p,$e|AuthType],FileData)-> + [{auth_type,getAuthorizationType(AuthType)}|FileData]; + +insertLine(_BadDirectiveOrComment,FileData)-> + FileData. + +%---------------------------------------------------------------------- +%transform the Data specified about override to a form that is ieasier +%handled later +%Override data="all"|"md5"|"Directive1 .... DirectioveN" +%---------------------------------------------------------------------- + +getAllowOverRideData(OverRideData)-> + case string:tokens(OverRideData," \r\n") of + [[$a,$l,$l]|_]-> + all; + [[$n,$o,$n,$e]|_]-> + none; + Directives -> + getOverRideDirectives(Directives) + end. + +getOverRideDirectives(Directives)-> + lists:map(fun(Directive)-> + transformDirective(Directive) + end,Directives). +transformDirective([$A,$u,$t,$h,$U,$s,$e,$r,$F,$i,$l,$e|_])-> + user_file; +transformDirective([$A,$u,$t,$h,$G,$r,$o,$u,$p,$F,$i,$l,$e|_]) -> + group_file; +transformDirective([$A,$u,$t,$h,$N,$a,$m,$e|_])-> + auth_name; +transformDirective([$A,$u,$t,$h,$T,$y,$p,$e|_])-> + auth_type; +transformDirective(_UnAllowedOverRideDirective) -> + unallowed. +%---------------------------------------------------------------------- +%Replace the string that specify which method to use for authentication +%and replace it with the atom for easier mathing +%---------------------------------------------------------------------- +getAuthorizationType(AuthType)-> + [Arg|Crap]=string:tokens(AuthType,"\n\r\ "), + case Arg of + [$B,$a,$s,$i,$c]-> + basic; + [$M,$D,$5] -> + md5; + _What -> + error + end. +%---------------------------------------------------------------------- +%Returns a list of the specified methods to limit or the atom all +%---------------------------------------------------------------------- +getLimits(Limits)-> + case regexp:split(Limits,">")of + {ok,[_NoEndOnLimit]}-> + error; + {ok,[Methods|Crap]}-> + case regexp:split(Methods," ")of + {ok,[]}-> + all; + {ok,SplittedMethods}-> + SplittedMethods; + {error,Error}-> + error + end; + {error,_Error}-> + error + end. + + +%---------------------------------------------------------------------- +% Transform the order to prefrom deny allow control to a tuple of atoms +%---------------------------------------------------------------------- +getOrder(Order)-> + [First|Rest]=lists:map(fun(Part)-> + list_to_atom(Part) + end,string:tokens(Order," \n\r")), + case First of + deny-> + {deny,allow}; + allow-> + {allow,deny}; + _Error-> + error + end. + +%---------------------------------------------------------------------- +% The string AllowDeny is "from all" or "from Subnet1 Subnet2...SubnetN" +%---------------------------------------------------------------------- +getAllowDenyData(AllowDeny)-> + case string:tokens(AllowDeny," \n\r") of + [_From|AllowDenyData] when length(AllowDenyData)>=1-> + case lists:nth(1,AllowDenyData) of + [$a,$l,$l]-> + all; + Hosts-> + AllowDenyData + end; + Error-> + errror + end. +%---------------------------------------------------------------------- +% Fix the string that describes who is allowed to se the page +%---------------------------------------------------------------------- +getRequireData(Require)-> + [UserOrGroup|UserData]=string:tokens(Require," \n\r"), + case UserOrGroup of + [$u,$s,$e,$r]-> + {users,UserData}; + [$g,$r,$o,$u,$p] -> + {groups,UserData}; + _Whatever -> + error + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% Methods that collects the searchways to the accessfiles %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%---------------------------------------------------------------------- +% Get the whole path to the different accessfiles +%---------------------------------------------------------------------- +getHtAccessFiles(HtAccessFileNames,Path,RestOfSplittedPath)-> + getHtAccessFiles(HtAccessFileNames,Path,RestOfSplittedPath,[]). + +getHtAccessFiles(HtAccessFileNames,Path,[[]],HtAccessFiles)-> + HtAccessFiles ++ accessFilesOfPath(HtAccessFileNames,Path++"/"); + +getHtAccessFiles(HtAccessFileNames,Path,[],HtAccessFiles)-> + HtAccessFiles; +getHtAccessFiles(HtAccessFileNames,Path,[NextDir|RestOfSplittedPath], + AccessFiles)-> + getHtAccessFiles(HtAccessFileNames,Path++"/"++NextDir,RestOfSplittedPath, + AccessFiles ++ + accessFilesOfPath(HtAccessFileNames,Path++"/")). + + +%---------------------------------------------------------------------- +%Control if therer are any accessfies in the path +%---------------------------------------------------------------------- +accessFilesOfPath(HtAccessFileNames,Path)-> + lists:foldl(fun(HtAccessFileName,Files)-> + case file:read_file_info(Path++HtAccessFileName) of + {ok,FileInfo}-> + [Path++HtAccessFileName|Files]; + {error,_Error} -> + Files + end + end,[],HtAccessFileNames). + + +%---------------------------------------------------------------------- +%Sake the splitted path and joins it up to the documentroot or the alias +%that match first +%---------------------------------------------------------------------- + +getRootPath(SplittedPath,Info)-> + DocRoot=httpd_util:lookup(Info#mod.config_db,document_root,"/"), + PresumtiveRootPath= + [DocRoot|lists:map(fun({Alias,RealPath})-> + RealPath + end, + httpd_util:multi_lookup(Info#mod.config_db,alias))], + getRootPath(PresumtiveRootPath,SplittedPath,Info). + + +getRootPath(PresumtiveRootPath,[[],Splittedpath],Info)-> + getRootPath(PresumtiveRootPath,["/",Splittedpath],Info); + + +getRootPath(PresumtiveRootPath,[Part,NextPart|SplittedPath],Info)-> + case lists:member(Part,PresumtiveRootPath)of + true-> + {ok,Part,[NextPart|SplittedPath]}; + false -> + getRootPath(PresumtiveRootPath, + [Part++"/"++NextPart|SplittedPath],Info) + end; + +getRootPath(PresumtiveRootPath,[Part],Info)-> + case lists:member(Part,PresumtiveRootPath)of + true-> + {ok,Part,[]}; + false -> + {error,Part} + end. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%Debug methods %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%---------------------------------------------------------------------- +% Simulate the webserver by calling do/1 with apropiate parameters +%---------------------------------------------------------------------- +debug()-> + Conf=getConfigData(), + Uri=getUri(), + {_Proceed,Data}=getDataFromAlias(Conf,Uri), + Init_data=#init_data{peername={socket,"127.0.0.1"}}, + ParsedHeader=headerparts(), + do(#mod{init_data=Init_data, + data=Data, + config_db=Conf, + request_uri=Uri, + parsed_header=ParsedHeader, + method="GET"}). + +%---------------------------------------------------------------------- +%Add authenticate data to the fake http-request header +%---------------------------------------------------------------------- +headerparts()-> + [{"authorization","Basic " ++ httpd_util:encode_base64("lotta:potta")}]. + +getDataFromAlias(Conf,Uri)-> + mod_alias:do(#mod{config_db=Conf,request_uri=Uri}). + +getUri()-> + "/appmon/test/test.html". + +getConfigData()-> + Tab=ets:new(test_inets,[bag,public]), + ets:insert(Tab,{server_name,"localhost"}), + ets:insert(Tab,{bind_addresss,{127,0,0,1}}), + ets:insert(Tab,{erl_script_alias,{"/webcover/erl",["webcover"]}}), + ets:insert(Tab,{erl_script_alias,{"/erl",["webappmon"]}}), + ets:insert(Tab,{com_type,ip_comm}), + ets:insert(Tab,{modules,[mod_alias,mod_auth,mod_header]}), + ets:insert(Tab,{default_type,"text/plain"}), + ets:insert(Tab,{server_root, + "/home/gandalf/marting/exjobb/webtool-1.0/priv/root"}), + ets:insert(Tab,{port,8888}), + ets:insert(Tab,{document_root, + "/home/gandalf/marting/exjobb/webtool-1.0/priv/root"}), + ets:insert(Tab, + {alias, + {"/appmon" + ,"/home/gandalf/marting/exjobb/webappmon-1.0/priv"}}), + ets:insert(Tab,{alias, + {"/webcover" + ,"/home/gandalf/marting/exjobb/webcover-1.0/priv"}}), + ets:insert(Tab,{access_file,[".htaccess","kalle","pelle"]}), + Tab. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_include.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_include.erl new file mode 100644 index 0000000000..eedbf4a669 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_include.erl @@ -0,0 +1,722 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_include.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_include). +-export([do/1,parse/2,config/6,include/6,echo/6,fsize/6,flastmod/6,exec/6]). + +-include("httpd.hrl"). + +-define(VMODULE,"INCLUDE"). +-include("httpd_verbosity.hrl"). + +%% do + +do(Info) -> + ?vtrace("do",[]), + case Info#mod.method of + "GET" -> + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + {proceed,Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data, response) of + %% No response has been generated! + undefined -> + do_include(Info); + %% A response has been generated or sent! + Response -> + {proceed,Info#mod.data} + end + end; + %% Not a GET method! + _ -> + {proceed,Info#mod.data} + end. + +do_include(Info) -> + ?vtrace("do_include -> entry with" + "~n URI: ~p",[Info#mod.request_uri]), + Path = mod_alias:path(Info#mod.data,Info#mod.config_db, + Info#mod.request_uri), + Suffix = httpd_util:suffix(Path), + case httpd_util:lookup_mime_default(Info#mod.config_db,Suffix) of + "text/x-server-parsed-html" -> + HeaderStart = + httpd_util:header(200, "text/html", Info#mod.connection), + ?vtrace("do_include -> send ~p", [Path]), + case send_in(Info,Path,HeaderStart,file:read_file_info(Path)) of + {ok, ErrorLog, Size} -> + ?vtrace("do_include -> sent ~w bytes", [Size]), + {proceed,[{response,{already_sent,200,Size}}, + {mime_type,"text/html"}| + lists:append(ErrorLog,Info#mod.data)]}; + {error, Reason} -> + ?vlog("send in failed:" + "~n Reason: ~p" + "~n Path: ~p" + "~n Info: ~p", + [Reason,Info,Path]), + {proceed, + [{status,send_error(Reason,Info,Path)}|Info#mod.data]} + end; + _ -> %% Unknown mime type, ignore + {proceed,Info#mod.data} + end. + + +%% +%% config directive +%% + +config(Info, Context, ErrorLog, TagList, ValueList, R) -> + case verify_tags("config",[errmsg,timefmt,sizefmt], + TagList,ValueList) of + ok -> + {ok,update_context(TagList,ValueList,Context),ErrorLog,"",R}; + {error,Reason} -> + {ok,Context,[{internal_info,Reason}|ErrorLog], + httpd_util:key1search(Context,errmsg,""),R} + end. + +update_context([],[],Context) -> + Context; +update_context([Tag|R1],[Value|R2],Context) -> + update_context(R1,R2,[{Tag,Value}|Context]). + +verify_tags(Command,ValidTags,TagList,ValueList) when length(TagList)==length(ValueList) -> + verify_tags(Command,ValidTags,TagList); +verify_tags(Command,ValidTags,TagList,ValueList) -> + {error,?NICE(Command++" directive has spurious tags")}. + +verify_tags(Command, ValidTags, []) -> + ok; +verify_tags(Command, ValidTags, [Tag|Rest]) -> + case lists:member(Tag, ValidTags) of + true -> + verify_tags(Command, ValidTags, Rest); + false -> + {error,?NICE(Command++" directive has a spurious tag ("++ + atom_to_list(Tag)++")")} + end. + +%% +%% include directive +%% + +include(Info,Context,ErrorLog,[virtual],[VirtualPath],R) -> + Aliases = httpd_util:multi_lookup(Info#mod.config_db,alias), + {_, Path, _AfterPath} = + mod_alias:real_name(Info#mod.config_db, VirtualPath, Aliases), + include(Info,Context,ErrorLog,R,Path); +include(Info, Context, ErrorLog, [file], [FileName], R) -> + Path = file(Info#mod.config_db, Info#mod.request_uri, FileName), + include(Info, Context, ErrorLog, R, Path); +include(Info, Context, ErrorLog, TagList, ValueList, R) -> + {ok, Context, + [{internal_info,?NICE("include directive has a spurious tag")}| + ErrorLog], httpd_util:key1search(Context, errmsg, ""), R}. + +include(Info, Context, ErrorLog, R, Path) -> + ?DEBUG("include -> read file: ~p",[Path]), + case file:read_file(Path) of + {ok, Body} -> + ?DEBUG("include -> size(Body): ~p",[size(Body)]), + {ok, NewContext, NewErrorLog, Result} = + parse(Info, binary_to_list(Body), Context, ErrorLog, []), + {ok, Context, NewErrorLog, Result, R}; + {error, Reason} -> + {ok, Context, + [{internal_info, ?NICE("Can't open "++Path)}|ErrorLog], + httpd_util:key1search(Context, errmsg, ""), R} + end. + +file(ConfigDB, RequestURI, FileName) -> + Aliases = httpd_util:multi_lookup(ConfigDB, alias), + {_, Path, _AfterPath} + = mod_alias:real_name(ConfigDB, RequestURI, Aliases), + Pwd = filename:dirname(Path), + filename:join(Pwd, FileName). + +%% +%% echo directive +%% + +echo(Info,Context,ErrorLog,[var],["DOCUMENT_NAME"],R) -> + {ok,Context,ErrorLog,document_name(Info#mod.data,Info#mod.config_db, + Info#mod.request_uri),R}; +echo(Info,Context,ErrorLog,[var],["DOCUMENT_URI"],R) -> + {ok,Context,ErrorLog,document_uri(Info#mod.config_db, + Info#mod.request_uri),R}; +echo(Info,Context,ErrorLog,[var],["QUERY_STRING_UNESCAPED"],R) -> + {ok,Context,ErrorLog,query_string_unescaped(Info#mod.request_uri),R}; +echo(Info,Context,ErrorLog,[var],["DATE_LOCAL"],R) -> + {ok,Context,ErrorLog,date_local(),R}; +echo(Info,Context,ErrorLog,[var],["DATE_GMT"],R) -> + {ok,Context,ErrorLog,date_gmt(),R}; +echo(Info,Context,ErrorLog,[var],["LAST_MODIFIED"],R) -> + {ok,Context,ErrorLog,last_modified(Info#mod.data,Info#mod.config_db, + Info#mod.request_uri),R}; +echo(Info,Context,ErrorLog,TagList,ValueList,R) -> + {ok,Context, + [{internal_info,?NICE("echo directive has a spurious tag")}| + ErrorLog],"(none)",R}. + +document_name(Data,ConfigDB,RequestURI) -> + Path = mod_alias:path(Data,ConfigDB,RequestURI), + case regexp:match(Path,"[^/]*\$") of + {match,Start,Length} -> + string:substr(Path,Start,Length); + nomatch -> + "(none)" + end. + +document_uri(ConfigDB, RequestURI) -> + Aliases = httpd_util:multi_lookup(ConfigDB, alias), + {Path, AfterPath} = + case mod_alias:real_name(ConfigDB, RequestURI, Aliases) of + {_, Name, {[], []}} -> + {Name, ""}; + {_, Name, {PathInfo, []}} -> + {Name, "/"++PathInfo}; + {_, Name, {PathInfo, QueryString}} -> + {Name, "/"++PathInfo++"?"++QueryString}; + {_, Name, _} -> + {Name, ""}; + Gurka -> + io:format("Gurka: ~p~n", [Gurka]) + end, + VirtualPath = string:substr(RequestURI, 1, + length(RequestURI)-length(AfterPath)), + {match, Start, Length} = regexp:match(Path,"[^/]*\$"), + FileName = string:substr(Path,Start,Length), + case regexp:match(VirtualPath, FileName++"\$") of + {match, _, _} -> + httpd_util:decode_hex(VirtualPath)++AfterPath; + nomatch -> + string:strip(httpd_util:decode_hex(VirtualPath),right,$/)++ + "/"++FileName++AfterPath + end. + +query_string_unescaped(RequestURI) -> + case regexp:match(RequestURI,"[\?].*\$") of + {match,Start,Length} -> + %% Escape all shell-special variables with \ + escape(string:substr(RequestURI,Start+1,Length-1)); + nomatch -> + "(none)" + end. + +escape([]) -> []; +escape([$;|R]) -> [$\\,$;|escape(R)]; +escape([$&|R]) -> [$\\,$&|escape(R)]; +escape([$(|R]) -> [$\\,$(|escape(R)]; +escape([$)|R]) -> [$\\,$)|escape(R)]; +escape([$||R]) -> [$\\,$||escape(R)]; +escape([$^|R]) -> [$\\,$^|escape(R)]; +escape([$<|R]) -> [$\\,$<|escape(R)]; +escape([$>|R]) -> [$\\,$>|escape(R)]; +escape([$\n|R]) -> [$\\,$\n|escape(R)]; +escape([$ |R]) -> [$\\,$ |escape(R)]; +escape([$\t|R]) -> [$\\,$\t|escape(R)]; +escape([C|R]) -> [C|escape(R)]. + +date_local() -> + {{Year,Month,Day},{Hour,Minute,Second}}=calendar:local_time(), + %% Time format hard-wired to: "%a %b %e %T %Y" according to strftime(3) + io_lib:format("~s ~s ~2w ~2.2.0w:~2.2.0w:~2.2.0w ~w", + [httpd_util:day(calendar:day_of_the_week(Year,Month,Day)), + httpd_util:month(Month),Day,Hour,Minute,Second,Year]). + +date_gmt() -> + {{Year,Month,Day},{Hour,Minute,Second}}=calendar:universal_time(), + %% Time format hard-wired to: "%a %b %e %T %Z %Y" according to strftime(3) + io_lib:format("~s ~s ~2w ~2.2.0w:~2.2.0w:~2.2.0w GMT ~w", + [httpd_util:day(calendar:day_of_the_week(Year,Month,Day)), + httpd_util:month(Month),Day,Hour,Minute,Second,Year]). + +last_modified(Data,ConfigDB,RequestURI) -> + {ok,FileInfo}=file:read_file_info(mod_alias:path(Data,ConfigDB,RequestURI)), + {{Year,Month,Day},{Hour,Minute,Second}}=FileInfo#file_info.mtime, + io_lib:format("~s ~s ~2w ~2.2.0w:~2.2.0w:~2.2.0w ~w", + [httpd_util:day(calendar:day_of_the_week(Year,Month,Day)), + httpd_util:month(Month),Day,Hour,Minute,Second,Year]). + +%% +%% fsize directive +%% + +fsize(Info,Context,ErrorLog,[virtual],[VirtualPath],R) -> + Aliases=httpd_util:multi_lookup(Info#mod.config_db,alias), + {_,Path,AfterPath}= + mod_alias:real_name(Info#mod.config_db,VirtualPath,Aliases), + fsize(Info, Context, ErrorLog, R, Path); +fsize(Info,Context,ErrorLog,[file],[FileName],R) -> + Path=file(Info#mod.config_db,Info#mod.request_uri,FileName), + fsize(Info,Context,ErrorLog,R,Path); +fsize(Info,Context,ErrorLog,TagList,ValueList,R) -> + {ok,Context,[{internal_info,?NICE("fsize directive has a spurious tag")}| + ErrorLog],httpd_util:key1search(Context,errmsg,""),R}. + +fsize(Info,Context,ErrorLog,R,Path) -> + case file:read_file_info(Path) of + {ok,FileInfo} -> + case httpd_util:key1search(Context,sizefmt) of + "bytes" -> + {ok,Context,ErrorLog, + integer_to_list(FileInfo#file_info.size),R}; + "abbrev" -> + Size = integer_to_list(trunc(FileInfo#file_info.size/1024+1))++"k", + {ok,Context,ErrorLog,Size,R}; + Value-> + {ok,Context, + [{internal_info, + ?NICE("fsize directive has a spurious tag value ("++ + Value++")")}| + ErrorLog], + httpd_util:key1search(Context, errmsg, ""), R} + end; + {error,Reason} -> + {ok,Context,[{internal_info,?NICE("Can't open "++Path)}|ErrorLog], + httpd_util:key1search(Context,errmsg,""),R} + end. + +%% +%% flastmod directive +%% + +flastmod(Info, Context, ErrorLog, [virtual], [VirtualPath],R) -> + Aliases=httpd_util:multi_lookup(Info#mod.config_db,alias), + {_,Path,AfterPath}= + mod_alias:real_name(Info#mod.config_db,VirtualPath,Aliases), + flastmod(Info,Context,ErrorLog,R,Path); +flastmod(Info, Context, ErrorLog, [file], [FileName], R) -> + Path = file(Info#mod.config_db, Info#mod.request_uri, FileName), + flastmod(Info, Context, ErrorLog, R, Path); +flastmod(Info,Context,ErrorLog,TagList,ValueList,R) -> + {ok,Context,[{internal_info,?NICE("flastmod directive has a spurious tag")}| + ErrorLog],httpd_util:key1search(Context,errmsg,""),R}. + +flastmod(Info,Context,ErrorLog,R,File) -> + case file:read_file_info(File) of + {ok,FileInfo} -> + {{Yr,Mon,Day},{Hour,Minute,Second}}=FileInfo#file_info.mtime, + Result= + io_lib:format("~s ~s ~2w ~w:~w:~w ~w", + [httpd_util:day( + calendar:day_of_the_week(Yr,Mon, Day)), + httpd_util:month(Mon),Day,Hour,Minute,Second, Yr]), + {ok,Context,ErrorLog,Result,R}; + {error,Reason} -> + {ok,Context,[{internal_info,?NICE("Can't open "++File)}|ErrorLog], + httpd_util:key1search(Context,errmsg,""),R} + end. + +%% +%% exec directive +%% + +exec(Info,Context,ErrorLog,[cmd],[Command],R) -> + ?vtrace("exec cmd:~n Command: ~p",[Command]), + cmd(Info,Context,ErrorLog,R,Command); +exec(Info,Context,ErrorLog,[cgi],[RequestURI],R) -> + ?vtrace("exec cgi:~n RequestURI: ~p",[RequestURI]), + cgi(Info,Context,ErrorLog,R,RequestURI); +exec(Info,Context,ErrorLog,TagList,ValueList,R) -> + ?vtrace("exec with spurious tag:" + "~n TagList: ~p" + "~n ValueList: ~p", + [TagList,ValueList]), + {ok, Context, + [{internal_info,?NICE("exec directive has a spurious tag")}| + ErrorLog], httpd_util:key1search(Context,errmsg,""),R}. + +%% cmd + +cmd(Info, Context, ErrorLog, R, Command) -> + process_flag(trap_exit,true), + Env = env(Info), + Dir = filename:dirname(Command), + Port = (catch open_port({spawn,Command},[stream,{cd,Dir},{env,Env}])), + case Port of + P when port(P) -> + {NewErrorLog, Result} = proxy(Port, ErrorLog), + {ok, Context, NewErrorLog, Result, R}; + {'EXIT', Reason} -> + ?vlog("open port failed: exit" + "~n URI: ~p" + "~n Reason: ~p", + [Info#mod.request_uri,Reason]), + exit({open_port_failed,Reason, + [{uri,Info#mod.request_uri},{script,Command}, + {env,Env},{dir,Dir}]}); + O -> + ?vlog("open port failed: unknown result" + "~n URI: ~p" + "~n O: ~p", + [Info#mod.request_uri,O]), + exit({open_port_failed,O, + [{uri,Info#mod.request_uri},{script,Command}, + {env,Env},{dir,Dir}]}) + end. + +env(Info) -> + [{"DOCUMENT_NAME",document_name(Info#mod.data,Info#mod.config_db, + Info#mod.request_uri)}, + {"DOCUMENT_URI", document_uri(Info#mod.config_db, Info#mod.request_uri)}, + {"QUERY_STRING_UNESCAPED", query_string_unescaped(Info#mod.request_uri)}, + {"DATE_LOCAL", date_local()}, + {"DATE_GMT", date_gmt()}, + {"LAST_MODIFIED", last_modified(Info#mod.data, Info#mod.config_db, + Info#mod.request_uri)} + ]. + +%% cgi + +cgi(Info, Context, ErrorLog, R, RequestURI) -> + ScriptAliases = httpd_util:multi_lookup(Info#mod.config_db, script_alias), + case mod_alias:real_script_name(Info#mod.config_db, RequestURI, + ScriptAliases) of + {Script, AfterScript} -> + exec_script(Info,Script,AfterScript,ErrorLog,Context,R); + not_a_script -> + {ok, Context, + [{internal_info, ?NICE(RequestURI++" is not a script")}| + ErrorLog], httpd_util:key1search(Context, errmsg, ""),R} + end. + +remove_header([]) -> + []; +remove_header([$\n,$\n|Rest]) -> + Rest; +remove_header([C|Rest]) -> + remove_header(Rest). + + +exec_script(Info,Script,AfterScript,ErrorLog,Context,R) -> + process_flag(trap_exit,true), + Aliases = httpd_util:multi_lookup(Info#mod.config_db, alias), + {_, Path, AfterPath} = mod_alias:real_name(Info#mod.config_db, + Info#mod.request_uri, + Aliases), + Env = env(Info)++mod_cgi:env(Info, Path, AfterPath), + Dir = filename:dirname(Path), + Port = (catch open_port({spawn,Script},[stream,{env, Env},{cd, Dir}])), + case Port of + P when port(P) -> + %% Send entity body to port. + Res = case Info#mod.entity_body of + [] -> + true; + EntityBody -> + (catch port_command(Port,EntityBody)) + end, + case Res of + {'EXIT', Reason} -> + ?vlog("port send failed:" + "~n Port: ~p" + "~n URI: ~p" + "~n Reason: ~p", + [Port,Info#mod.request_uri,Reason]), + exit({open_cmd_failed,Reason, + [{mod,?MODULE},{port,Port}, + {uri,Info#mod.request_uri}, + {script,Script},{env,Env},{dir,Dir}, + {ebody_size,sz(Info#mod.entity_body)}]}); + true -> + {NewErrorLog, Result} = proxy(Port, ErrorLog), + {ok, Context, NewErrorLog, remove_header(Result), R} + end; + {'EXIT', Reason} -> + ?vlog("open port failed: exit" + "~n URI: ~p" + "~n Reason: ~p", + [Info#mod.request_uri,Reason]), + exit({open_port_failed,Reason, + [{mod,?MODULE},{uri,Info#mod.request_uri},{script,Script}, + {env,Env},{dir,Dir}]}); + O -> + ?vlog("open port failed: unknown result" + "~n URI: ~p" + "~n O: ~p", + [Info#mod.request_uri,O]), + exit({open_port_failed,O, + [{mod,?MODULE},{uri,Info#mod.request_uri},{script,Script}, + {env,Env},{dir,Dir}]}) + end. + + +%% +%% Port communication +%% + +proxy(Port,ErrorLog) -> + process_flag(trap_exit, true), + proxy(Port, ErrorLog, []). + +proxy(Port, ErrorLog, Result) -> + receive + {Port, {data, Response}} -> + proxy(Port, ErrorLog, lists:append(Result,Response)); + {'EXIT', Port, normal} when port(Port) -> + process_flag(trap_exit, false), + {ErrorLog, Result}; + {'EXIT', Port, Reason} when port(Port) -> + process_flag(trap_exit, false), + {[{internal_info, + ?NICE("Scrambled output from CGI-script")}|ErrorLog], + Result}; + {'EXIT', Pid, Reason} when pid(Pid) -> + process_flag(trap_exit, false), + {'EXIT', Pid, Reason}; + %% This should not happen! + WhatEver -> + process_flag(trap_exit, false), + {ErrorLog, Result} + end. + + +%% ------ +%% Temporary until I figure out a way to fix send_in_chunks +%% (comments and directives that start in one chunk but end +%% in another is not handled). +%% + +send_in(Info, Path,Head, {ok,FileInfo}) -> + case file:read_file(Path) of + {ok, Bin} -> + send_in1(Info, binary_to_list(Bin), Head, FileInfo); + {error, Reason} -> + ?vlog("failed reading file: ~p",[Reason]), + {error, {open,Reason}} + end; +send_in(Info,Path,Head,{error,Reason}) -> + ?vlog("failed open file: ~p",[Reason]), + {error, {open,Reason}}. + +send_in1(Info, Data,Head,FileInfo) -> + {ok, _Context, Err, ParsedBody} = parse(Info,Data,?DEFAULT_CONTEXT,[],[]), + Size = length(ParsedBody), + ?vdebug("send_in1 -> Size: ~p",[Size]), + Head1 = case Info#mod.http_version of + "HTTP/1.1"-> + Head ++ + "Content-Length: " ++ + integer_to_list(Size) ++ + "\r\nEtag:" ++ + httpd_util:create_etag(FileInfo,Size) ++"\r\n" ++ + "Last-Modified: " ++ + httpd_util:rfc1123_date(FileInfo#file_info.mtime) ++ + "\r\n\r\n"; + _-> + %% i.e http/1.0 and http/0.9 + Head ++ + "Content-Length: " ++ + integer_to_list(Size) ++ + "\r\nLast-Modified: " ++ + httpd_util:rfc1123_date(FileInfo#file_info.mtime) ++ + "\r\n\r\n" + end, + httpd_socket:deliver(Info#mod.socket_type,Info#mod.socket, + [Head1,ParsedBody]), + {ok, Err, Size}. + + + +%% +%% Addition to "Fuzzy" HTML parser. This is actually a ugly hack to +%% avoid putting to much data on the heap. To be rewritten... +%% + +% -define(CHUNK_SIZE, 4096). + +% send_in_chunks(Info, Path) -> +% ?DEBUG("send_in_chunks -> Path: ~p",[Path]), +% case file:open(Path, [read, raw]) of +% {ok, Stream} -> +% send_in_chunks(Info, Stream, ?DEFAULT_CONTEXT,[]); +% {error, Reason} -> +% ?ERROR("Failed open file: ~p",[Reason]), +% {error, {open,Reason}} +% end. + +% send_in_chunks(Info, Stream, Context, ErrorLog) -> +% case file:read(Stream, ?CHUNK_SIZE) of +% {ok, Data} -> +% ?DEBUG("send_in_chunks -> read ~p bytes",[length(Data)]), +% {ok, NewContext, NewErrorLog, ParsedBody}= +% parse(Info, Data, Context, ErrorLog, []), +% httpd_socket:deliver(Info#mod.socket_type, +% Info#mod.socket, ParsedBody), +% send_in_chunks(Info,Stream,NewContext,NewErrorLog); +% eof -> +% {ok, ErrorLog}; +% {error, Reason} -> +% ?ERROR("Failed read from file: ~p",[Reason]), +% {error, {read,Reason}} +% end. + + +%% +%% "Fuzzy" HTML parser +%% + +parse(Info,Body) -> + parse(Info, Body, ?DEFAULT_CONTEXT, [], []). + +parse(Info, [], Context, ErrorLog, Result) -> + {ok, Context, lists:reverse(ErrorLog), lists:reverse(Result)}; +parse(Info,[$<,$!,$-,$-,$#|R1],Context,ErrorLog,Result) -> + ?DEBUG("parse -> start command directive when length(R1): ~p",[length(R1)]), + case catch parse0(R1,Context) of + {parse_error,Reason} -> + parse(Info,R1,Context,[{internal_info,?NICE(Reason)}|ErrorLog], + [$#,$-,$-,$!,$<|Result]); + {ok,Context,Command,TagList,ValueList,R2} -> + ?DEBUG("parse -> Command: ~p",[Command]), + {ok,NewContext,NewErrorLog,MoreResult,R3}= + handle(Info,Context,ErrorLog,Command,TagList,ValueList,R2), + parse(Info,R3,NewContext,NewErrorLog,lists:reverse(MoreResult)++Result) + end; +parse(Info,[$<,$!,$-,$-|R1],Context,ErrorLog,Result) -> + ?DEBUG("parse -> start comment when length(R1) = ~p",[length(R1)]), + case catch parse5(R1,[],0) of + {parse_error,Reason} -> + ?ERROR("parse -> parse error: ~p",[Reason]), + parse(Info,R1,Context,[{internal_info,?NICE(Reason)}|ErrorLog],Result); + {Comment,R2} -> + ?DEBUG("parse -> length(Comment) = ~p, length(R2) = ~p", + [length(Comment),length(R2)]), + parse(Info,R2,Context,ErrorLog,Comment++Result) + end; +parse(Info,[C|R],Context,ErrorLog,Result) -> + parse(Info,R,Context,ErrorLog,[C|Result]). + +handle(Info,Context,ErrorLog,Command,TagList,ValueList,R) -> + case catch apply(?MODULE,Command,[Info,Context,ErrorLog,TagList,ValueList, + R]) of + {'EXIT',{undef,_}} -> + throw({parse_error,"Unknown command "++atom_to_list(Command)++ + " in parsed doc"}); + Result -> + Result + end. + +parse0([],Context) -> + throw({parse_error,"Premature EOF in parsed file"}); +parse0([$-,$-,$>|R],Context) -> + throw({parse_error,"Premature EOF in parsed file"}); +parse0([$ |R],Context) -> + parse0(R,Context); +parse0(String,Context) -> + parse1(String,Context,""). + +parse1([],Context,Command) -> + throw({parse_error,"Premature EOF in parsed file"}); +parse1([$-,$-,$>|R],Context,Command) -> + throw({parse_error,"Premature EOF in parsed file"}); +parse1([$ |R],Context,Command) -> + parse2(R,Context,list_to_atom(lists:reverse(Command)),[],[],""); +parse1([C|R],Context,Command) -> + parse1(R,Context,[C|Command]). + +parse2([],Context,Command,TagList,ValueList,Tag) -> + throw({parse_error,"Premature EOF in parsed file"}); +parse2([$-,$-,$>|R],Context,Command,TagList,ValueList,Tag) -> + {ok,Context,Command,TagList,ValueList,R}; +parse2([$ |R],Context,Command,TagList,ValueList,Tag) -> + parse2(R,Context,Command,TagList,ValueList,Tag); +parse2([$=|R],Context,Command,TagList,ValueList,Tag) -> + parse3(R,Context,Command,[list_to_atom(lists:reverse(Tag))|TagList], + ValueList); +parse2([C|R],Context,Command,TagList,ValueList,Tag) -> + parse2(R,Context,Command,TagList,ValueList,[C|Tag]). + +parse3([],Context,Command,TagList,ValueList) -> + throw({parse_error,"Premature EOF in parsed file"}); +parse3([$-,$-,$>|R],Context,Command,TagList,ValueList) -> + throw({parse_error,"Premature EOF in parsed file"}); +parse3([$ |R],Context,Command,TagList,ValueList) -> + parse3(R,Context,Command,TagList,ValueList); +parse3([$"|R],Context,Command,TagList,ValueList) -> + parse4(R,Context,Command,TagList,ValueList,""); +parse3(String,Context,Command,TagList,ValueList) -> + throw({parse_error,"Premature EOF in parsed file"}). + +parse4([],Context,Command,TagList,ValueList,Value) -> + throw({parse_error,"Premature EOF in parsed file"}); +parse4([$-,$-,$>|R],Context,Command,TagList,ValueList,Value) -> + throw({parse_error,"Premature EOF in parsed file"}); +parse4([$"|R],Context,Command,TagList,ValueList,Value) -> + parse2(R,Context,Command,TagList,[lists:reverse(Value)|ValueList],""); +parse4([C|R],Context,Command,TagList,ValueList,Value) -> + parse4(R,Context,Command,TagList,ValueList,[C|Value]). + +parse5([],Comment,Depth) -> + ?ERROR("parse5 -> unterminated comment of ~p bytes when Depth = ~p", + [length(Comment),Depth]), + throw({parse_error,"Premature EOF in parsed file"}); +parse5([$<,$!,$-,$-|R],Comment,Depth) -> + parse5(R,[$-,$-,$!,$<|Comment],Depth+1); +parse5([$-,$-,$>|R],Comment,0) -> + {">--"++Comment++"--!<",R}; +parse5([$-,$-,$>|R],Comment,Depth) -> + parse5(R,[$>,$-,$-|Comment],Depth-1); +parse5([C|R],Comment,Depth) -> + parse5(R,[C|Comment],Depth). + + +sz(B) when binary(B) -> {binary,size(B)}; +sz(L) when list(L) -> {list,length(L)}; +sz(_) -> undefined. + + +%% send_error - Handle failure to send the file +%% +send_error({open,Reason},Info,Path) -> open_error(Reason,Info,Path); +send_error({read,Reason},Info,Path) -> read_error(Reason,Info,Path). + + +%% open_error - Handle file open failure +%% +open_error(eacces,Info,Path) -> + open_error(403,Info,Path,""); +open_error(enoent,Info,Path) -> + open_error(404,Info,Path,""); +open_error(enotdir,Info,Path) -> + open_error(404,Info,Path, + ": A component of the file name is not a directory"); +open_error(emfile,_Info,Path) -> + open_error(500,none,Path,": To many open files"); +open_error({enfile,_},_Info,Path) -> + open_error(500,none,Path,": File table overflow"); +open_error(_Reason,_Info,Path) -> + open_error(500,none,Path,""). + +open_error(StatusCode,none,Path,Reason) -> + {StatusCode,none,?NICE("Can't open "++Path++Reason)}; +open_error(StatusCode,Info,Path,Reason) -> + {StatusCode,Info#mod.request_uri,?NICE("Can't open "++Path++Reason)}. + +read_error(_Reason,_Info,Path) -> + read_error(500,none,Path,""). + +read_error(StatusCode,none,Path,Reason) -> + {StatusCode,none,?NICE("Can't read "++Path++Reason)}; +read_error(StatusCode,Info,Path,Reason) -> + {StatusCode,Info#mod.request_uri,?NICE("Can't read "++Path++Reason)}. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_log.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_log.erl new file mode 100644 index 0000000000..a24ac425e6 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_log.erl @@ -0,0 +1,250 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_log.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_log). +-export([do/1,error_log/5,security_log/2,load/2,store/2,remove/1]). + +-export([report_error/2]). + +-include("httpd.hrl"). + +-define(VMODULE,"LOG"). +-include("httpd_verbosity.hrl"). + +%% do + +do(Info) -> + AuthUser = auth_user(Info#mod.data), + Date = custom_date(), + log_internal_info(Info,Date,Info#mod.data), + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + transfer_log(Info,"-",AuthUser,Date,StatusCode,0), + if + StatusCode >= 400 -> + error_log(Info,Date,Reason); + true -> + not_an_error + end, + {proceed,Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data,response) of + {already_sent,StatusCode,Size} -> + transfer_log(Info,"-",AuthUser,Date,StatusCode,Size), + {proceed,Info#mod.data}; + {response,Head,Body} -> + Size=httpd_util:key1search(Head,content_length,unknown), + Code=httpd_util:key1search(Head,code,unknown), + transfer_log(Info,"-",AuthUser,Date,Code,Size), + {proceed,Info#mod.data}; + {StatusCode,Response} -> + transfer_log(Info,"-",AuthUser,Date,200, + httpd_util:flatlength(Response)), + {proceed,Info#mod.data}; + undefined -> + transfer_log(Info,"-",AuthUser,Date,200,0), + {proceed,Info#mod.data} + end + end. + +custom_date() -> + LocalTime=calendar:local_time(), + UniversalTime=calendar:universal_time(), + Minutes=round(diff_in_minutes(LocalTime,UniversalTime)), + {{YYYY,MM,DD},{Hour,Min,Sec}}=LocalTime, + Date = + io_lib:format("~.2.0w/~.3s/~.4w:~.2.0w:~.2.0w:~.2.0w ~c~.2.0w~.2.0w", + [DD, httpd_util:month(MM), YYYY, Hour, Min, Sec, + sign(Minutes), + abs(Minutes) div 60, abs(Minutes) rem 60]), + lists:flatten(Date). + +diff_in_minutes(L,U) -> + (calendar:datetime_to_gregorian_seconds(L) - + calendar:datetime_to_gregorian_seconds(U))/60. + +sign(Minutes) when Minutes > 0 -> + $+; +sign(Minutes) -> + $-. + +auth_user(Data) -> + case httpd_util:key1search(Data,remote_user) of + undefined -> + "-"; + RemoteUser -> + RemoteUser + end. + +%% log_internal_info + +log_internal_info(Info,Date,[]) -> + ok; +log_internal_info(Info,Date,[{internal_info,Reason}|Rest]) -> + error_log(Info,Date,Reason), + log_internal_info(Info,Date,Rest); +log_internal_info(Info,Date,[_|Rest]) -> + log_internal_info(Info,Date,Rest). + +%% transfer_log + +transfer_log(Info,RFC931,AuthUser,Date,StatusCode,Bytes) -> + case httpd_util:lookup(Info#mod.config_db,transfer_log) of + undefined -> + no_transfer_log; + TransferLog -> + {PortNumber,RemoteHost}=(Info#mod.init_data)#init_data.peername, + case (catch io:format(TransferLog, "~s ~s ~s [~s] \"~s\" ~w ~w~n", + [RemoteHost, RFC931, AuthUser, + Date, Info#mod.request_line, + StatusCode, Bytes])) of + ok -> + ok; + Error -> + error_logger:error_report(Error) + end + end. + +%% security log + +security_log(Info, Reason) -> + case httpd_util:lookup(Info#mod.config_db, security_log) of + undefined -> + no_security_log; + SecurityLog -> + io:format(SecurityLog,"[~s] ~s~n", [custom_date(), Reason]) + end. + +%% error_log + +error_log(Info,Date,Reason) -> + case httpd_util:lookup(Info#mod.config_db, error_log) of + undefined -> + no_error_log; + ErrorLog -> + {PortNumber,RemoteHost}=(Info#mod.init_data)#init_data.peername, + io:format(ErrorLog,"[~s] access to ~s failed for ~s, reason: ~p~n", + [Date,Info#mod.request_uri,RemoteHost,Reason]) + end. + +error_log(SocketType,Socket,ConfigDB,{PortNumber,RemoteHost},Reason) -> + case httpd_util:lookup(ConfigDB,error_log) of + undefined -> + no_error_log; + ErrorLog -> + Date=custom_date(), + io:format(ErrorLog,"[~s] server crash for ~s, reason: ~p~n", + [Date,RemoteHost,Reason]), + ok + end. + +report_error(ConfigDB,Error) -> + case httpd_util:lookup(ConfigDB,error_log) of + undefined -> + no_error_log; + ErrorLog -> + Date=custom_date(), + io:format(ErrorLog,"[~s] reporting error: ~s~n",[Date,Error]), + ok + end. + +%% +%% Configuration +%% + +%% load + +load([$T,$r,$a,$n,$s,$f,$e,$r,$L,$o,$g,$ |TransferLog],[]) -> + {ok,[],{transfer_log,httpd_conf:clean(TransferLog)}}; +load([$E,$r,$r,$o,$r,$L,$o,$g,$ |ErrorLog],[]) -> + {ok,[],{error_log,httpd_conf:clean(ErrorLog)}}; +load([$S,$e,$c,$u,$r,$i,$t,$y,$L,$o,$g,$ |SecurityLog], []) -> + {ok, [], {security_log, httpd_conf:clean(SecurityLog)}}. + +%% store + +store({transfer_log,TransferLog},ConfigList) -> + case create_log(TransferLog,ConfigList) of + {ok,TransferLogStream} -> + {ok,{transfer_log,TransferLogStream}}; + {error,Reason} -> + {error,Reason} + end; +store({error_log,ErrorLog},ConfigList) -> + case create_log(ErrorLog,ConfigList) of + {ok,ErrorLogStream} -> + {ok,{error_log,ErrorLogStream}}; + {error,Reason} -> + {error,Reason} + end; +store({security_log, SecurityLog},ConfigList) -> + case create_log(SecurityLog, ConfigList) of + {ok, SecurityLogStream} -> + {ok, {security_log, SecurityLogStream}}; + {error, Reason} -> + {error, Reason} + end. + +create_log(LogFile,ConfigList) -> + Filename = httpd_conf:clean(LogFile), + case filename:pathtype(Filename) of + absolute -> + case file:open(Filename, [read,write]) of + {ok,LogStream} -> + file:position(LogStream,{eof,0}), + {ok,LogStream}; + {error,_} -> + {error,?NICE("Can't create "++Filename)} + end; + volumerelative -> + case file:open(Filename, [read,write]) of + {ok,LogStream} -> + file:position(LogStream,{eof,0}), + {ok,LogStream}; + {error,_} -> + {error,?NICE("Can't create "++Filename)} + end; + relative -> + case httpd_util:key1search(ConfigList,server_root) of + undefined -> + {error, + ?NICE(Filename++ + " is an invalid logfile name beacuse ServerRoot is not defined")}; + ServerRoot -> + AbsoluteFilename=filename:join(ServerRoot,Filename), + case file:open(AbsoluteFilename, [read,write]) of + {ok,LogStream} -> + file:position(LogStream,{eof,0}), + {ok,LogStream}; + {error,Reason} -> + {error,?NICE("Can't create "++AbsoluteFilename)} + end + end + end. + +%% remove + +remove(ConfigDB) -> + lists:foreach(fun([Stream]) -> file:close(Stream) end, + ets:match(ConfigDB,{transfer_log,'$1'})), + lists:foreach(fun([Stream]) -> file:close(Stream) end, + ets:match(ConfigDB,{error_log,'$1'})), + lists:foreach(fun([Stream]) -> file:close(Stream) end, + ets:match(ConfigDB,{security_log,'$1'})), + ok. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_range.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_range.erl new file mode 100644 index 0000000000..f623dc3ec8 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_range.erl @@ -0,0 +1,380 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_range.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_range). +-export([do/1]). +-include("httpd.hrl"). + +%% do + + + +do(Info) -> + ?DEBUG("do -> entry",[]), + case Info#mod.method of + "GET" -> + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + {proceed,Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data,response) of + %% No response has been generated! + undefined -> + case httpd_util:key1search(Info#mod.parsed_header,"range") of + undefined -> + %Not a range response + {proceed,Info#mod.data}; + Range -> + %%Control that there weren't a if-range field that stopped + %%The range request in favor for the whole file + case httpd_util:key1search(Info#mod.data,if_range) of + send_file -> + {proceed,Info#mod.data}; + _undefined -> + do_get_range(Info,Range) + end + end; + %% A response has been generated or sent! + Response -> + {proceed,Info#mod.data} + end + end; + %% Not a GET method! + _ -> + {proceed,Info#mod.data} + end. + +do_get_range(Info,Ranges) -> + ?DEBUG("do_get_range -> Request URI: ~p",[Info#mod.request_uri]), + Path = mod_alias:path(Info#mod.data, Info#mod.config_db, + Info#mod.request_uri), + {FileInfo, LastModified} =get_modification_date(Path), + send_range_response(Path,Info,Ranges,FileInfo,LastModified). + + +send_range_response(Path,Info,Ranges,FileInfo,LastModified)-> + case parse_ranges(Ranges) of + error-> + ?ERROR("send_range_response-> Unparsable range request",[]), + {proceed,Info#mod.data}; + {multipart,RangeList}-> + send_multi_range_response(Path,Info,RangeList); + {Start,Stop}-> + send_range_response(Path,Info,Start,Stop,FileInfo,LastModified) + end. +%%More than one range specified +%%Send a multipart reponse to the user +% +%%An example of an multipart range response + +% HTTP/1.1 206 Partial Content +% Date:Wed 15 Nov 1995 04:08:23 GMT +% Last-modified:Wed 14 Nov 1995 04:08:23 GMT +% Content-type: multipart/byteranges; boundary="SeparatorString" +% +% --"SeparatorString" +% Content-Type: application/pdf +% Content-Range: bytes 500-600/1010 +% .... The data..... 101 bytes +% +% --"SeparatorString" +% Content-Type: application/pdf +% Content-Range: bytes 700-1009/1010 +% .... The data..... + + + +send_multi_range_response(Path,Info,RangeList)-> + case file:open(Path, [raw,binary]) of + {ok, FileDescriptor} -> + file:close(FileDescriptor), + ?DEBUG("send_multi_range_response -> FileDescriptor: ~p",[FileDescriptor]), + Suffix = httpd_util:suffix(Path), + PartMimeType = httpd_util:lookup_mime_default(Info#mod.config_db,Suffix,"text/plain"), + Date = httpd_util:rfc1123_date(), + {FileInfo,LastModified}=get_modification_date(Path), + case valid_ranges(RangeList,Path,FileInfo) of + {ValidRanges,true}-> + ?DEBUG("send_multi_range_response -> Ranges are valid:",[]), + %Apache breaks the standard by sending the size field in the Header. + Header = [{code,206}, + {content_type,"multipart/byteranges;boundary=RangeBoundarySeparator"}, + {etag,httpd_util:create_etag(FileInfo)}, + {last_modified,LastModified} + ], + ?DEBUG("send_multi_range_response -> Valid Ranges: ~p",[RagneList]), + Body={fun send_multiranges/4,[ValidRanges,Info,PartMimeType,Path]}, + {proceed,[{response,{response,Header,Body}}|Info#mod.data]}; + _ -> + {proceed, [{status, {416,"Range not valid",bad_range_boundaries }}]} + end; + {error, Reason} -> + ?ERROR("do_get -> failed open file: ~p",[Reason]), + {proceed,Info#mod.data} + end. + +send_multiranges(ValidRanges,Info,PartMimeType,Path)-> + ?DEBUG("send_multiranges -> Start sending the ranges",[]), + case file:open(Path, [raw,binary]) of + {ok,FileDescriptor} -> + lists:foreach(fun(Range)-> + send_multipart_start(Range,Info,PartMimeType,FileDescriptor) + end,ValidRanges), + file:close(FileDescriptor), + %%Sends an end of the multipart + httpd_socket:deliver(Info#mod.socket_type,Info#mod.socket,"\r\n--RangeBoundarySeparator--"), + sent; + _ -> + close + end. + +send_multipart_start({{Start,End},{StartByte,EndByte,Size}},Info,PartMimeType,FileDescriptor)when StartByte<Size-> + PartHeader=["\r\n--RangeBoundarySeparator\r\n","Content-type: ",PartMimeType,"\r\n", + "Content-Range:bytes=",integer_to_list(StartByte),"-",integer_to_list(EndByte),"/", + integer_to_list(Size),"\r\n\r\n"], + send_part_start(Info#mod.socket_type,Info#mod.socket,PartHeader,FileDescriptor,Start,End); + + +send_multipart_start({{Start,End},{StartByte,EndByte,Size}},Info,PartMimeType,FileDescriptor)-> + PartHeader=["\r\n--RangeBoundarySeparator\r\n","Content-type: ",PartMimeType,"\r\n", + "Content-Range:bytes=",integer_to_list(Size-(StartByte-Size)),"-",integer_to_list(EndByte),"/", + integer_to_list(Size),"\r\n\r\n"], + send_part_start(Info#mod.socket_type,Info#mod.socket,PartHeader,FileDescriptor,Start,End). + +send_part_start(SocketType,Socket,PartHeader,FileDescriptor,Start,End)-> + case httpd_socket:deliver(SocketType,Socket,PartHeader) of + ok -> + send_part_start(SocketType,Socket,FileDescriptor,Start,End); + _ -> + close + end. + +send_range_response(Path,Info,Start,Stop,FileInfo,LastModified)-> + case file:open(Path, [raw,binary]) of + {ok, FileDescriptor} -> + file:close(FileDescriptor), + ?DEBUG("send_range_response -> FileDescriptor: ~p",[FileDescriptor]), + Suffix = httpd_util:suffix(Path), + MimeType = httpd_util:lookup_mime_default(Info#mod.config_db,Suffix,"text/plain"), + Date = httpd_util:rfc1123_date(), + Size = get_range_size(Start,Stop,FileInfo), + case valid_range(Start,Stop,FileInfo) of + {true,StartByte,EndByte,TotByte}-> + Head=[{code,206},{content_type, MimeType}, + {last_modified, LastModified}, + {etag,httpd_util:create_etag(FileInfo)}, + {content_range,["bytes=",integer_to_list(StartByte),"-", + integer_to_list(EndByte),"/",integer_to_list(TotByte)]}, + {content_length,Size}], + BodyFunc=fun send_range_body/5, + Arg=[Info#mod.socket_type, Info#mod.socket,Path,Start,Stop], + {proceed,[{response,{response,Head,{BodyFunc,Arg}}}|Info#mod.data]}; + {false,Reason} -> + {proceed, [{status, {416,Reason,bad_range_boundaries }}]} + end; + {error, Reason} -> + ?ERROR("send_range_response -> failed open file: ~p",[Reason]), + {proceed,Info#mod.data} + end. + + +send_range_body(SocketType,Socket,Path,Start,End) -> + ?DEBUG("mod_range -> send_range_body",[]), + case file:open(Path, [raw,binary]) of + {ok,FileDescriptor} -> + send_part_start(SocketType,Socket,FileDescriptor,Start,End), + file:close(FileDescriptor); + _ -> + close + end. + +send_part_start(SocketType,Socket,FileDescriptor,Start,End) -> + case Start of + from_end -> + file:position(FileDescriptor,{eof,End}), + send_body(SocketType,Socket,FileDescriptor); + from_start -> + file:position(FileDescriptor,{bof,End}), + send_body(SocketType,Socket,FileDescriptor); + Byte when integer(Byte) -> + file:position(FileDescriptor,{bof,Start}), + send_part(SocketType,Socket,FileDescriptor,End) + end, + sent. + + +%%This function could replace send_body by calling it with Start=0 end =FileSize +%% But i gues it would be stupid when we look at performance +send_part(SocketType,Socket,FileDescriptor,End)-> + case file:position(FileDescriptor,{cur,0}) of + {ok,NewPos} -> + if + NewPos > End -> + ok; + true -> + Size=get_file_chunk_size(NewPos,End,?FILE_CHUNK_SIZE), + case file:read(FileDescriptor,Size) of + eof -> + ok; + {error,Reason} -> + ok; + {ok,Binary} -> + case httpd_socket:deliver(SocketType,Socket,Binary) of + socket_closed -> + ?LOG("send_range of body -> socket closed while sending",[]), + socket_close; + _ -> + send_part(SocketType,Socket,FileDescriptor,End) + end + end + end; + _-> + ok + end. + +%% validate that the range is in the limits of the file +valid_ranges(RangeList,Path,FileInfo)-> + lists:mapfoldl(fun({Start,End},Acc)-> + case Acc of + true -> + case valid_range(Start,End,FileInfo) of + {true,StartB,EndB,Size}-> + {{{Start,End},{StartB,EndB,Size}},true}; + _ -> + false + end; + _ -> + {false,false} + end + end,true,RangeList). + + + +valid_range(from_end,End,FileInfo)-> + Size=FileInfo#file_info.size, + if + End < Size -> + {true,(Size+End),Size-1,Size}; + true -> + false + end; +valid_range(from_start,End,FileInfo)-> + Size=FileInfo#file_info.size, + if + End < Size -> + {true,End,Size-1,Size}; + true -> + false + end; + +valid_range(Start,End,FileInfo)when Start=<End-> + case FileInfo#file_info.size of + FileSize when Start< FileSize -> + case FileInfo#file_info.size of + Size when End<Size -> + {true,Start,End,FileInfo#file_info.size}; + Size -> + {true,Start,Size-1,Size} + end; + _-> + {false,"The size of the range is negative"} + end; + +valid_range(Start,End,FileInfo)-> + {false,"Range starts out of file boundaries"}. +%% Find the modification date of the file +get_modification_date(Path)-> + case file:read_file_info(Path) of + {ok, FileInfo0} -> + {FileInfo0, httpd_util:rfc1123_date(FileInfo0#file_info.mtime)}; + _ -> + {#file_info{},""} + end. + +%Calculate the size of the chunk to read + +get_file_chunk_size(Position,End,DefaultChunkSize)when (Position+DefaultChunkSize) =< End-> + DefaultChunkSize; +get_file_chunk_size(Position,End,DefaultChunkSize)-> + (End-Position) +1. + + + +%Get the size of the range to send. Remember that +%A range is from startbyte up to endbyte which means that +%the nuber of byte in a range is (StartByte-EndByte)+1 + +get_range_size(from_end,Stop,FileInfo)-> + integer_to_list(-1*Stop); + +get_range_size(from_start,StartByte,FileInfo) -> + integer_to_list((((FileInfo#file_info.size)-StartByte))); + +get_range_size(StartByte,EndByte,FileInfo) -> + integer_to_list((EndByte-StartByte)+1). + +parse_ranges([$\ ,$b,$y,$t,$e,$s,$\=|Ranges])-> + parse_ranges([$b,$y,$t,$e,$s,$\=|Ranges]); +parse_ranges([$b,$y,$t,$e,$s,$\=|Ranges])-> + case string:tokens(Ranges,", ") of + [Range] -> + parse_range(Range); + [Range1|SplittedRanges]-> + {multipart,lists:map(fun parse_range/1,[Range1|SplittedRanges])} + end; +%Bad unit +parse_ranges(Ranges)-> + io:format("Bad Ranges : ~p",[Ranges]), + error. +%Parse the range specification from the request to {Start,End} +%Start=End : Numreric string | [] + +parse_range(Range)-> + format_range(split_range(Range,[],[])). +format_range({[],BytesFromEnd})-> + {from_end,-1*(list_to_integer(BytesFromEnd))}; +format_range({StartByte,[]})-> + {from_start,list_to_integer(StartByte)}; +format_range({StartByte,EndByte})-> + {list_to_integer(StartByte),list_to_integer(EndByte)}. +%Last case return the splitted range +split_range([],Current,Other)-> + {lists:reverse(Other),lists:reverse(Current)}; + +split_range([$-|Rest],Current,Other)-> + split_range(Rest,Other,Current); + +split_range([N|Rest],Current,End) -> + split_range(Rest,[N|Current],End). + +send_body(SocketType,Socket,FileDescriptor) -> + case file:read(FileDescriptor,?FILE_CHUNK_SIZE) of + {ok,Binary} -> + ?DEBUG("send_body -> send another chunk: ~p",[size(Binary)]), + case httpd_socket:deliver(SocketType,Socket,Binary) of + socket_closed -> + ?LOG("send_body -> socket closed while sending",[]), + socket_close; + _ -> + send_body(SocketType,Socket,FileDescriptor) + end; + eof -> + ?DEBUG("send_body -> done with this file",[]), + eof + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_responsecontrol.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_responsecontrol.erl new file mode 100644 index 0000000000..b818a15f32 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_responsecontrol.erl @@ -0,0 +1,320 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_responsecontrol.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% + +-module(mod_responsecontrol). +-export([do/1]). + +-include("httpd.hrl"). + + +do(Info) -> + ?DEBUG("do -> response_control",[]), + case httpd_util:key1search(Info#mod.data,status) of + %% A status code has been generated! + {StatusCode,PhraseArgs,Reason} -> + {proceed,Info#mod.data}; + %% No status code has been generated! + undefined -> + case httpd_util:key1search(Info#mod.data,response) of + %% No response has been generated! + undefined -> + case do_responsecontrol(Info) of + continue -> + {proceed,Info#mod.data}; + Response -> + {proceed,[Response|Info#mod.data]} + end; + %% A response has been generated or sent! + Response -> + {proceed,Info#mod.data} + end + end. + + +%%---------------------------------------------------------------------- +%%Control that the request header did not contians any limitations +%%wheather a response shall be createed or not +%%---------------------------------------------------------------------- + +do_responsecontrol(Info) -> + ?DEBUG("do_response_control -> Request URI: ~p",[Info#mod.request_uri]), + Path = mod_alias:path(Info#mod.data, Info#mod.config_db, + Info#mod.request_uri), + case file:read_file_info(Path) of + {ok, FileInfo} -> + control(Path,Info,FileInfo); + _ -> + %% The requested asset is not a plain file and then it must + %% be generated everytime its requested + continue + end. + +%%---------------------------------------------------------------------- +%%Control the If-Match, If-None-Match, and If-Modified-Since +%%---------------------------------------------------------------------- + + +%% If a client sends more then one of the if-XXXX fields in a request +%% The standard says it does not specify the behaviuor so I specified it :-) +%% The priority between the fields is +%% 1.If-modified +%% 2.If-Unmodified +%% 3.If-Match +%% 4.If-Nomatch + +%% This means if more than one of the fields are in the request the +%% field with highest priority will be used + +%%If the request is a range request the If-Range field will be the winner. + +control(Path,Info,FileInfo)-> + case control_range(Path,Info,FileInfo) of + undefined -> + case control_Etag(Path,Info,FileInfo) of + undefined -> + case control_modification(Path,Info,FileInfo) of + continue -> + continue; + ReturnValue -> + send_return_value(ReturnValue,FileInfo) + end; + continue -> + continue; + ReturnValue -> + send_return_value(ReturnValue,FileInfo) + end; + Response-> + Response + end. + +%%---------------------------------------------------------------------- +%%If there are both a range and an if-range field control if +%%---------------------------------------------------------------------- +control_range(Path,Info,FileInfo) -> + case httpd_util:key1search(Info#mod.parsed_header,"range") of + undefined-> + undefined; + _Range -> + case httpd_util:key1search(Info#mod.parsed_header,"if-range") of + undefined -> + undefined; + EtagOrDate -> + control_if_range(Path,Info,FileInfo,EtagOrDate) + end + end. + +control_if_range(Path,Info,FileInfo,EtagOrDate) -> + case httpd_util:convert_request_date(strip_date(EtagOrDate)) of + bad_date -> + FileEtag=httpd_util:create_etag(FileInfo), + case FileEtag of + EtagOrDate -> + continue; + _ -> + {if_range,send_file} + end; + ErlDate -> + %%We got the date in the request if it is + case control_modification_data(Info,FileInfo#file_info.mtime,"if-range") of + modified -> + {if_range,send_file}; + _UnmodifiedOrUndefined-> + continue + end + end. + +%%---------------------------------------------------------------------- +%%Controls the values of the If-Match and I-None-Mtch +%%---------------------------------------------------------------------- +control_Etag(Path,Info,FileInfo)-> + FileEtag=httpd_util:create_etag(FileInfo), + %%Control if the E-Tag for the resource matches one of the Etags in + %%the -if-match header field + case control_match(Info,FileInfo,"if-match",FileEtag) of + nomatch -> + %%None of the Etags in the if-match field matched the current + %%Etag for the resource return a 304 + {412,Info,Path}; + match -> + continue; + undefined -> + case control_match(Info,FileInfo,"if-none-match",FileEtag) of + nomatch -> + continue; + match -> + case Info#mod.method of + "GET" -> + {304,Info,Path}; + "HEAD" -> + {304,Info,Path}; + _OtherrequestMethod -> + {412,Info,Path} + end; + undefined -> + undefined + end + end. + +%%---------------------------------------------------------------------- +%%Control if there are any Etags for HeaderField in the request if so +%%Control if they match the Etag for the requested file +%%---------------------------------------------------------------------- +control_match(Info,FileInfo,HeaderField,FileEtag)-> + case split_etags(httpd_util:key1search(Info#mod.parsed_header,HeaderField)) of + undefined-> + undefined; + Etags-> + %%Control that the match any star not is availible + case lists:member("*",Etags) of + true-> + match; + false-> + compare_etags(FileEtag,Etags) + end + end. + +%%---------------------------------------------------------------------- +%%Split the etags from the request +%%---------------------------------------------------------------------- +split_etags(undefined)-> + undefined; +split_etags(Tags) -> + string:tokens(Tags,", "). + +%%---------------------------------------------------------------------- +%%Control if the etag for the file is in the list +%%---------------------------------------------------------------------- +compare_etags(Tag,Etags) -> + case lists:member(Tag,Etags) of + true -> + match; + _ -> + nomatch + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%%Control if the file is modificated %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%---------------------------------------------------------------------- +%%Control the If-Modified-Since and If-Not-Modified-Since header fields +%%---------------------------------------------------------------------- +control_modification(Path,Info,FileInfo)-> + ?DEBUG("control_modification() -> entry",[]), + case control_modification_data(Info,FileInfo#file_info.mtime,"if-modified-since") of + modified-> + continue; + unmodified-> + {304,Info,Path}; + undefined -> + case control_modification_data(Info,FileInfo#file_info.mtime,"if-unmodified-since") of + modified -> + {412,Info,Path}; + _ContinueUndefined -> + continue + end + end. + +%%---------------------------------------------------------------------- +%%Controls the date from the http-request if-modified-since and +%%if-not-modified-since against the modification data of the +%%File +%%---------------------------------------------------------------------- +%%Info is the record about the request +%%ModificationTime is the time the file was edited last +%%Header Field is the name of the field to control + +control_modification_data(Info,ModificationTime,HeaderField)-> + case strip_date(httpd_util:key1search(Info#mod.parsed_header,HeaderField)) of + undefined-> + undefined; + LastModified0 -> + LastModified=httpd_util:convert_request_date(LastModified0), + ?DEBUG("control_modification_data() -> " + "~n Request-Field: ~s" + "~n FileLastModified: ~p" + "~n FieldValue: ~p", + [HeaderField,ModificationTime,LastModified]), + case LastModified of + bad_date -> + undefined; + _ -> + FileTime=calendar:datetime_to_gregorian_seconds(ModificationTime), + FieldTime=calendar:datetime_to_gregorian_seconds(LastModified), + if + FileTime=<FieldTime -> + ?DEBUG("File unmodified~n", []), + unmodified; + FileTime>=FieldTime -> + ?DEBUG("File modified~n", []), + modified + end + end + end. + +%%---------------------------------------------------------------------- +%%Compare to dates on the form {{YYYY,MM,DD},{HH,MIN,SS}} +%%If the first date is the biggest returns biggest1 (read biggestFirst) +%%If the first date is smaller +% compare_date(Date,bad_date)-> +% bad_date; + +% compare_date({D1,T1},{D2,T2})-> +% case compare_date1(D1,D2) of +% equal -> +% compare_date1(T1,T2); +% GTorLT-> +% GTorLT +% end. + +% compare_date1({T1,T2,T3},{T12,T22,T32}) when T1>T12 -> +% bigger1; +% compare_date1({T1,T2,T3},{T1,T22,T32}) when T2>T22 -> +% bigger1; +% compare_date1({T1,T2,T3},{T1,T2,T32}) when T3>T32 -> +% bigger1; +% compare_date1({T1,T2,T3},{T1,T2,T3})-> +% equal; +% compare_date1(_D1,_D2)-> +% smaller1. + + +%% IE4 & NS4 sends an extra '; length=xxxx' string at the end of the If-Modified-Since +%% header, we detect this and ignore it (the RFCs does not mention this). +strip_date(undefined) -> + undefined; +strip_date([]) -> + []; +strip_date([$;,$ |Rest]) -> + []; +strip_date([C|Rest]) -> + [C|strip_date(Rest)]. + +send_return_value({412,_,_},FileInfo)-> + {status,{412,none,"Precondition Failed"}}; + +send_return_value({304,Info,Path},FileInfo)-> + Suffix=httpd_util:suffix(Path), + MimeType = httpd_util:lookup_mime_default(Info#mod.config_db,Suffix,"text/plain"), + Header = [{code,304}, + {etag,httpd_util:create_etag(FileInfo)}, + {content_length,0}, + {last_modified,httpd_util:rfc1123_date(FileInfo#file_info.mtime)}], + {response,{response,Header,nobody}}. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_security.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_security.erl new file mode 100644 index 0000000000..b4d52d1599 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_security.erl @@ -0,0 +1,307 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_security.erl,v 1.1 2008/12/17 09:53:35 mikpe Exp $ +%% +-module(mod_security). + +%% Security Audit Functionality + +%% User API exports +-export([list_blocked_users/1, list_blocked_users/2, list_blocked_users/3, + block_user/4, block_user/5, + unblock_user/2, unblock_user/3, unblock_user/4, + list_auth_users/1, list_auth_users/2, list_auth_users/3]). + +%% module API exports +-export([do/1, load/2, store/2, remove/1]). + +-include("httpd.hrl"). + +-define(VMODULE,"SEC"). +-include("httpd_verbosity.hrl"). + + +%% do/1 +do(Info) -> + ?vdebug("~n do with ~n Info: ~p",[Info]), + %% Check and see if any user has been authorized. + case httpd_util:key1search(Info#mod.data,remote_user,not_defined_user) of + not_defined_user -> + %% No user has been authorized. + case httpd_util:key1search(Info#mod.data, status) of + %% A status code has been generated! + {401, PhraseArgs, Reason} -> + case httpd_util:key1search(Info#mod.parsed_header, + "authorization") of + undefined -> + %% Not an authorization attempt (server just replied to + %% challenge for authentication) + {proceed, Info#mod.data}; + [$B,$a,$s,$i,$c,$ |EncodedString] -> + %% Someone tried to authenticate, and obviously failed! + ?vlog("~n Authentication failed: ~s", + [EncodedString]), + report_failed(Info, EncodedString,"Failed authentication"), + take_failed_action(Info, EncodedString), + {proceed, Info#mod.data} + end; + _ -> + {proceed, Info#mod.data} + end; + User -> + %% A user has been authenticated, now is he blocked ? + ?vtrace("user '~p' authentication",[User]), + Path = mod_alias:path(Info#mod.data, + Info#mod.config_db, + Info#mod.request_uri), + {Dir, SDirData} = secretp(Path, Info#mod.config_db), + Addr = httpd_util:lookup(Info#mod.config_db, bind_address), + Port = httpd_util:lookup(Info#mod.config_db, port), + DF = httpd_util:key1search(SDirData, data_file), + case mod_security_server:check_blocked_user(Info, User, + SDirData, + Addr, Port) of + true -> + ?vtrace("user blocked",[]), + report_failed(Info,httpd_util:decode_base64(User) ,"User Blocked"), + {proceed, [{status, {403, Info#mod.request_uri, ""}}|Info#mod.data]}; + false -> + ?vtrace("user not blocked",[]), + EncodedUser=httpd_util:decode_base64(User), + report_failed(Info, EncodedUser,"Authentication Succedded"), + mod_security_server:store_successful_auth(Addr, Port, + User, SDirData), + {proceed, Info#mod.data} + end + end. + + + +report_failed(Info, EncodedString,Event) -> + Request = Info#mod.request_line, + Decoded = httpd_util:decode_base64(EncodedString), + {PortNumber,RemoteHost}=(Info#mod.init_data)#init_data.peername, + String = RemoteHost++" : " ++ Event ++ " : "++Request++" : "++Decoded, + mod_disk_log:security_log(Info,String), + mod_log:security_log(Info, String). + +take_failed_action(Info, EncodedString) -> + Path = mod_alias:path(Info#mod.data,Info#mod.config_db, Info#mod.request_uri), + {Dir, SDirData} = secretp(Path, Info#mod.config_db), + Addr = httpd_util:lookup(Info#mod.config_db, bind_address), + Port = httpd_util:lookup(Info#mod.config_db, port), + DecodedString = httpd_util:decode_base64(EncodedString), + mod_security_server:store_failed_auth(Info, Addr, Port, + DecodedString, SDirData). + +secretp(Path, ConfigDB) -> + Directories = ets:match(ConfigDB,{directory,'$1','_'}), + case secret_path(Path, Directories) of + {yes, Directory} -> + SDirs0 = httpd_util:multi_lookup(ConfigDB, security_directory), + SDir = lists:filter(fun(X) -> + lists:member({path, Directory}, X) + end, SDirs0), + {Directory, lists:flatten(SDir)}; + no -> + error_report({internal_error_secretp, ?MODULE}), + {[], []} + end. + +secret_path(Path,Directories) -> + secret_path(Path, httpd_util:uniq(lists:sort(Directories)), to_be_found). + +secret_path(Path, [], to_be_found) -> + no; +secret_path(Path, [], Directory) -> + {yes, Directory}; +secret_path(Path, [[NewDirectory]|Rest], Directory) -> + case regexp:match(Path, NewDirectory) of + {match, _, _} when Directory == to_be_found -> + secret_path(Path, Rest, NewDirectory); + {match, _, Length} when Length > length(Directory)-> + secret_path(Path, Rest, NewDirectory); + {match, _, Length} -> + secret_path(Path, Rest, Directory); + nomatch -> + secret_path(Path, Rest, Directory) + end. + + +load([$<,$D,$i,$r,$e,$c,$t,$o,$r,$y,$ |Directory],[]) -> + Dir = httpd_conf:custom_clean(Directory,"",">"), + {ok, [{security_directory, Dir, [{path, Dir}]}]}; +load(eof,[{security_directory,Directory, DirData}|_]) -> + {error, ?NICE("Premature end-of-file in "++Directory)}; +load([$S,$e,$c,$u,$r,$i,$t,$y,$D,$a,$t,$a,$F,$i,$l,$e,$ |FileName], + [{security_directory, Dir, DirData}]) -> + File = httpd_conf:clean(FileName), + {ok, [{security_directory, Dir, [{data_file, File}|DirData]}]}; +load([$S,$e,$c,$u,$r,$i,$t,$y,$C,$a,$l,$l,$b,$a,$c,$k,$M,$o,$d,$u,$l,$e,$ |ModuleName], + [{security_directory, Dir, DirData}]) -> + Mod = list_to_atom(httpd_conf:clean(ModuleName)), + {ok, [{security_directory, Dir, [{callback_module, Mod}|DirData]}]}; +load([$S,$e,$c,$u,$r,$i,$t,$y,$M,$a,$x,$R,$e,$t,$r,$i,$e,$s,$ |Retries], + [{security_directory, Dir, DirData}]) -> + MaxRetries = httpd_conf:clean(Retries), + load_return_int_tag("SecurityMaxRetries", max_retries, + httpd_conf:clean(Retries), Dir, DirData); +load([$S,$e,$c,$u,$r,$i,$t,$y,$B,$l,$o,$c,$k,$T,$i,$m,$e,$ |Time], + [{security_directory, Dir, DirData}]) -> + load_return_int_tag("SecurityBlockTime", block_time, + httpd_conf:clean(Time), Dir, DirData); +load([$S,$e,$c,$u,$r,$i,$t,$y,$F,$a,$i,$l,$E,$x,$p,$i,$r,$e,$T,$i,$m,$e,$ |Time], + [{security_directory, Dir, DirData}]) -> + load_return_int_tag("SecurityFailExpireTime", fail_expire_time, + httpd_conf:clean(Time), Dir, DirData); +load([$S,$e,$c,$u,$r,$i,$t,$y,$A,$u,$t,$h,$T,$i,$m,$e,$o,$u,$t,$ |Time0], + [{security_directory, Dir, DirData}]) -> + Time = httpd_conf:clean(Time0), + load_return_int_tag("SecurityAuthTimeout", auth_timeout, + httpd_conf:clean(Time), Dir, DirData); +load([$A,$u,$t,$h,$N,$a,$m,$e,$ |Name0], + [{security_directory, Dir, DirData}]) -> + Name = httpd_conf:clean(Name0), + {ok, [{security_directory, Dir, [{auth_name, Name}|DirData]}]}; +load("</Directory>",[{security_directory,Directory, DirData}]) -> + {ok, [], {security_directory, Directory, DirData}}. + +load_return_int_tag(Name, Atom, Time, Dir, DirData) -> + case Time of + "infinity" -> + {ok, [{security_directory, Dir, [{Atom, 99999999999999999999999999999}|DirData]}]}; + Int -> + case catch list_to_integer(Time) of + {'EXIT', _} -> + {error, Time++" is an invalid "++Name}; + Val -> + {ok, [{security_directory, Dir, [{Atom, Val}|DirData]}]} + end + end. + +store({security_directory, Dir0, DirData}, ConfigList) -> + ?CDEBUG("store(security_directory) -> ~n" + " Dir0: ~p~n" + " DirData: ~p", + [Dir0, DirData]), + Addr = httpd_util:key1search(ConfigList, bind_address), + Port = httpd_util:key1search(ConfigList, port), + mod_security_server:start(Addr, Port), + SR = httpd_util:key1search(ConfigList, server_root), + Dir = + case filename:pathtype(Dir0) of + relative -> + filename:join(SR, Dir0); + _ -> + Dir0 + end, + case httpd_util:key1search(DirData, data_file, no_data_file) of + no_data_file -> + {error, no_security_data_file}; + DataFile0 -> + DataFile = + case filename:pathtype(DataFile0) of + relative -> + filename:join(SR, DataFile0); + _ -> + DataFile0 + end, + case mod_security_server:new_table(Addr, Port, DataFile) of + {ok, TwoTables} -> + NewDirData0 = lists:keyreplace(data_file, 1, DirData, + {data_file, TwoTables}), + NewDirData1 = case Addr of + undefined -> + [{port,Port}|NewDirData0]; + _ -> + [{port,Port},{bind_address,Addr}| + NewDirData0] + end, + {ok, {security_directory,NewDirData1}}; + {error, Err} -> + {error, {{open_data_file, DataFile}, Err}} + end + end. + + +remove(ConfigDB) -> + Addr = case ets:lookup(ConfigDB, bind_address) of + [] -> + undefined; + [{bind_address, Address}] -> + Address + end, + [{port, Port}] = ets:lookup(ConfigDB, port), + mod_security_server:delete_tables(Addr, Port), + mod_security_server:stop(Addr, Port). + + +%% +%% User API +%% + +%% list_blocked_users + +list_blocked_users(Port) -> + list_blocked_users(undefined, Port). + +list_blocked_users(Port, Dir) when integer(Port) -> + list_blocked_users(undefined,Port,Dir); +list_blocked_users(Addr, Port) when integer(Port) -> + mod_security_server:list_blocked_users(Addr, Port). + +list_blocked_users(Addr, Port, Dir) -> + mod_security_server:list_blocked_users(Addr, Port, Dir). + + +%% block_user + +block_user(User, Port, Dir, Time) -> + block_user(User, undefined, Port, Dir, Time). +block_user(User, Addr, Port, Dir, Time) -> + mod_security_server:block_user(User, Addr, Port, Dir, Time). + + +%% unblock_user + +unblock_user(User, Port) -> + unblock_user(User, undefined, Port). + +unblock_user(User, Port, Dir) when integer(Port) -> + unblock_user(User, undefined, Port, Dir); +unblock_user(User, Addr, Port) when integer(Port) -> + mod_security_server:unblock_user(User, Addr, Port). + +unblock_user(User, Addr, Port, Dir) -> + mod_security_server:unblock_user(User, Addr, Port, Dir). + + +%% list_auth_users + +list_auth_users(Port) -> + list_auth_users(undefined,Port). + +list_auth_users(Port, Dir) when integer(Port) -> + list_auth_users(undefined, Port, Dir); +list_auth_users(Addr, Port) when integer(Port) -> + mod_security_server:list_auth_users(Addr, Port). + +list_auth_users(Addr, Port, Dir) -> + mod_security_server:list_auth_users(Addr, Port, Dir). + + +error_report(M) -> + error_logger:error_report(M). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_security_server.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_security_server.erl new file mode 100644 index 0000000000..81156c24e8 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_security_server.erl @@ -0,0 +1,727 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_security_server.erl,v 1.1 2008/12/17 09:53:36 mikpe Exp $ +%% +%% Security Audit Functionality + +%% +%% The gen_server code. +%% +%% A gen_server is needed in this module to take care of shared access to the +%% data file used to store failed and successful authentications aswell as +%% user blocks. +%% +%% The storage model is a write-through model with both an ets and a dets +%% table. Writes are done to both the ets and then the dets table, but reads +%% are only done from the ets table. +%% +%% This approach also enables parallelism when using dets by returning the +%% same dets table identifier when opening several files with the same +%% physical location. +%% +%% NOTE: This could be implemented using a single dets table, as it is +%% possible to open a dets file with the ram_file flag, but this +%% would require periodical sync's to disk, and it would be hard +%% to decide when such an operation should occur. +%% + + +-module(mod_security_server). + +-include("httpd.hrl"). +-include("httpd_verbosity.hrl"). + + +-behaviour(gen_server). + + +%% User API exports (called via mod_security) +-export([list_blocked_users/2, list_blocked_users/3, + block_user/5, + unblock_user/3, unblock_user/4, + list_auth_users/2, list_auth_users/3]). + +%% Internal exports (for mod_security only) +-export([start/2, stop/1, stop/2, + new_table/3, delete_tables/2, + store_failed_auth/5, store_successful_auth/4, + check_blocked_user/5]). + +%% gen_server exports +-export([start_link/3, + init/1, + handle_info/2, handle_call/3, handle_cast/2, + terminate/2, + code_change/3]). + +-export([verbosity/3]). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% External API %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% start_link/3 +%% +%% NOTE: This is called by httpd_misc_sup when the process is started +%% + +start_link(Addr, Port, Verbosity) -> + ?vtrace("start_link -> entry with" + "~n Addr: ~p" + "~n Port: ~p", [Addr, Port]), + Name = make_name(Addr, Port), + gen_server:start_link({local, Name}, ?MODULE, [Verbosity], + [{timeout, infinity}]). + + +%% start/2 +%% Called by the mod_security module. + +start(Addr, Port) -> + Name = make_name(Addr, Port), + case whereis(Name) of + undefined -> + Verbosity = get(security_verbosity), + case httpd_misc_sup:start_sec_server(Addr, Port, Verbosity) of + {ok, Pid} -> + put(security_server, Pid), + ok; + Error -> + exit({failed_start_security_server, Error}) + end; + _ -> %% Already started... + ok + end. + + +%% stop + +stop(Port) -> + stop(undefined, Port). +stop(Addr, Port) -> + Name = make_name(Addr, Port), + case whereis(Name) of + undefined -> + ok; + _ -> + httpd_misc_sup:stop_sec_server(Addr, Port) + end. + + +%% verbosity + +verbosity(Addr, Port, Verbosity) -> + Name = make_name(Addr, Port), + Req = {verbosity, Verbosity}, + call(Name, Req). + + +%% list_blocked_users + +list_blocked_users(Addr, Port) -> + Name = make_name(Addr,Port), + Req = {list_blocked_users, Addr, Port, '_'}, + call(Name, Req). + +list_blocked_users(Addr, Port, Dir) -> + Name = make_name(Addr, Port), + Req = {list_blocked_users, Addr, Port, Dir}, + call(Name, Req). + + +%% block_user + +block_user(User, Addr, Port, Dir, Time) -> + Name = make_name(Addr, Port), + Req = {block_user, User, Addr, Port, Dir, Time}, + call(Name, Req). + + +%% unblock_user + +unblock_user(User, Addr, Port) -> + Name = make_name(Addr, Port), + Req = {unblock_user, User, Addr, Port, '_'}, + call(Name, Req). + +unblock_user(User, Addr, Port, Dir) -> + Name = make_name(Addr, Port), + Req = {unblock_user, User, Addr, Port, Dir}, + call(Name, Req). + + +%% list_auth_users + +list_auth_users(Addr, Port) -> + Name = make_name(Addr, Port), + Req = {list_auth_users, Addr, Port, '_'}, + call(Name, Req). + +list_auth_users(Addr, Port, Dir) -> + Name = make_name(Addr,Port), + Req = {list_auth_users, Addr, Port, Dir}, + call(Name, Req). + + +%% new_table + +new_table(Addr, Port, TabName) -> + Name = make_name(Addr,Port), + Req = {new_table, Addr, Port, TabName}, + call(Name, Req). + + +%% delete_tables + +delete_tables(Addr, Port) -> + Name = make_name(Addr, Port), + case whereis(Name) of + undefined -> + ok; + _ -> + call(Name, delete_tables) + end. + + +%% store_failed_auth + +store_failed_auth(Info, Addr, Port, DecodedString, SDirData) -> + Name = make_name(Addr,Port), + Msg = {store_failed_auth,[Info,DecodedString,SDirData]}, + cast(Name, Msg). + + +%% store_successful_auth + +store_successful_auth(Addr, Port, User, SDirData) -> + Name = make_name(Addr,Port), + Msg = {store_successful_auth, [User,Addr,Port,SDirData]}, + cast(Name, Msg). + + +%% check_blocked_user + +check_blocked_user(Info, User, SDirData, Addr, Port) -> + Name = make_name(Addr, Port), + Req = {check_blocked_user, [Info, User, SDirData]}, + call(Name, Req). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% %% +%% Server call-back functions %% +%% %% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% init + +init([undefined]) -> + init([?default_verbosity]); +init([Verbosity]) -> + ?DEBUG("init -> entry with Verbosity: ~p",[Verbosity]), + process_flag(trap_exit, true), + put(sname, sec), + put(verbosity, Verbosity), + ?vlog("starting",[]), + {ok, []}. + + +%% handle_call + +handle_call(stop, _From, Tables) -> + ?vlog("stop",[]), + {stop, normal, ok, []}; + + +handle_call({verbosity,Verbosity}, _From, Tables) -> + ?vlog("set verbosity to ~p",[Verbosity]), + OldVerbosity = get(verbosity), + put(verbosity,Verbosity), + ?vdebug("old verbosity: ~p",[OldVerbosity]), + {reply,OldVerbosity,Tables}; + + +handle_call({block_user, User, Addr, Port, Dir, Time}, _From, Tables) -> + ?vlog("block user '~p' for ~p",[User,Dir]), + Ret = block_user_int({User, Addr, Port, Dir, Time}), + ?vdebug("block user result: ~p",[Ret]), + {reply, Ret, Tables}; + + +handle_call({list_blocked_users, Addr, Port, Dir}, _From, Tables) -> + ?vlog("list blocked users for ~p",[Dir]), + Blocked = list_blocked(Tables, Addr, Port, Dir, []), + ?vdebug("list blocked users: ~p",[Blocked]), + {reply, Blocked, Tables}; + + +handle_call({unblock_user, User, Addr, Port, Dir}, _From, Tables) -> + ?vlog("unblock user '~p' for ~p",[User,Dir]), + Ret = unblock_user_int({User, Addr, Port, Dir}), + ?vdebug("unblock user result: ~p",[Ret]), + {reply, Ret, Tables}; + + +handle_call({list_auth_users, Addr, Port, Dir}, _From, Tables) -> + ?vlog("list auth users for ~p",[Dir]), + Auth = list_auth(Tables, Addr, Port, Dir, []), + ?vdebug("list auth users result: ~p",[Auth]), + {reply, Auth, Tables}; + + +handle_call({new_table, Addr, Port, Name}, _From, Tables) -> + case lists:keysearch(Name, 1, Tables) of + {value, {Name, {Ets, Dets}}} -> + ?DEBUG("handle_call(new_table) -> we already have this table: ~p", + [Name]), + ?vdebug("new table; we already have this one: ~p",[Name]), + {reply, {ok, {Ets, Dets}}, Tables}; + false -> + ?LOG("handle_call(new_table) -> new_table: Name = ~p",[Name]), + ?vlog("new table: ~p",[Name]), + TName = make_name(Addr,Port,length(Tables)), + ?DEBUG("handle_call(new_table) -> TName: ~p",[TName]), + ?vdebug("new table: ~p",[TName]), + case dets:open_file(TName, [{type, bag}, {file, Name}, + {repair, true}, + {access, read_write}]) of + {ok, DFile} -> + ETS = ets:new(TName, [bag, private]), + sync_dets_to_ets(DFile, ETS), + NewTables = [{Name, {ETS, DFile}}|Tables], + ?DEBUG("handle_call(new_table) -> ~n" + " NewTables: ~p",[NewTables]), + ?vtrace("new tables: ~p",[NewTables]), + {reply, {ok, {ETS, DFile}}, NewTables}; + {error, Err} -> + ?LOG("handle_call -> Err: ~p",[Err]), + ?vinfo("failed open dets file: ~p",[Err]), + {reply, {error, {create_dets, Err}}, Tables} + end + end; + +handle_call(delete_tables, _From, Tables) -> + ?vlog("delete tables",[]), + lists:foreach(fun({Name, {ETS, DETS}}) -> + dets:close(DETS), + ets:delete(ETS) + end, Tables), + {reply, ok, []}; + +handle_call({check_blocked_user, [Info, User, SDirData]}, _From, Tables) -> + ?vlog("check blocked user '~p'",[User]), + {ETS, DETS} = httpd_util:key1search(SDirData, data_file), + Dir = httpd_util:key1search(SDirData, path), + Addr = httpd_util:key1search(SDirData, bind_address), + Port = httpd_util:key1search(SDirData, port), + CBModule = httpd_util:key1search(SDirData, callback_module, no_module_at_all), + ?vdebug("call back module: ~p",[CBModule]), + Ret = check_blocked_user(Info, User, Dir, Addr, Port, ETS, DETS, CBModule), + ?vdebug("check result: ~p",[Ret]), + {reply, Ret, Tables}; +handle_call(Request,From,Tables) -> + ?vinfo("~n unknown call '~p' from ~p",[Request,From]), + {reply,ok,Tables}. + + +%% handle_cast + +handle_cast({store_failed_auth, [Info, DecodedString, SDirData]}, Tables) -> + ?vlog("store failed auth",[]), + {ETS, DETS} = httpd_util:key1search(SDirData, data_file), + Dir = httpd_util:key1search(SDirData, path), + Addr = httpd_util:key1search(SDirData, bind_address), + Port = httpd_util:key1search(SDirData, port), + {ok, [User,Password]} = httpd_util:split(DecodedString,":",2), + ?vdebug("user '~p' and password '~p'",[User,Password]), + Seconds = universal_time(), + Key = {User, Dir, Addr, Port}, + + %% Event + CBModule = httpd_util:key1search(SDirData, callback_module, no_module_at_all), + ?vtrace("call back module: ~p",[CBModule]), + auth_fail_event(CBModule,Addr,Port,Dir,User,Password), + + %% Find out if any of this user's other failed logins are too old to keep.. + ?vtrace("remove old login failures",[]), + case ets:match_object(ETS, {failed, {Key, '_', '_'}}) of + [] -> + ?vtrace("no old login failures",[]), + no; + List when list(List) -> + ?vtrace("~p old login failures",[length(List)]), + ExpireTime = httpd_util:key1search(SDirData, fail_expire_time, 30)*60, + ?vtrace("expire time ~p",[ExpireTime]), + lists:map(fun({failed, {TheKey, LS, Gen}}) -> + Diff = Seconds-LS, + if + Diff > ExpireTime -> + ?vtrace("~n '~p' is to old to keep: ~p", + [TheKey,Gen]), + ets:match_delete(ETS, {failed, {TheKey, LS, Gen}}), + dets:match_delete(DETS, {failed, {TheKey, LS, Gen}}); + true -> + ?vtrace("~n '~p' is not old enough: ~p", + [TheKey,Gen]), + ok + end + end, + List); + O -> + ?vlog("~n unknown login failure search resuylt: ~p",[O]), + no + end, + + %% Insert the new failure.. + Generation = length(ets:match_object(ETS, {failed, {Key, '_', '_'}})), + ?vtrace("insert ('~p') new login failure: ~p",[Key,Generation]), + ets:insert(ETS, {failed, {Key, Seconds, Generation}}), + dets:insert(DETS, {failed, {Key, Seconds, Generation}}), + + %% See if we should block this user.. + MaxRetries = httpd_util:key1search(SDirData, max_retries, 3), + BlockTime = httpd_util:key1search(SDirData, block_time, 60), + ?vtrace("~n Max retries ~p, block time ~p",[MaxRetries,BlockTime]), + case ets:match_object(ETS, {failed, {Key, '_', '_'}}) of + List1 -> + ?vtrace("~n ~p tries so far",[length(List1)]), + if + length(List1) >= MaxRetries -> + %% Block this user until Future + ?vtrace("block user '~p'",[User]), + Future = Seconds+BlockTime*60, + ?vtrace("future: ~p",[Future]), + Reason = io_lib:format("Blocking user ~s from dir ~s " + "for ~p minutes", + [User, Dir, BlockTime]), + mod_log:security_log(Info, lists:flatten(Reason)), + + %% Event + user_block_event(CBModule,Addr,Port,Dir,User), + + ets:match_delete(ETS,{blocked_user, + {User, Addr, Port, Dir, '$1'}}), + dets:match_delete(DETS, {blocked_user, + {User, Addr, Port, Dir, '$1'}}), + BlockRecord = {blocked_user, + {User, Addr, Port, Dir, Future}}, + ets:insert(ETS, BlockRecord), + dets:insert(DETS, BlockRecord), + %% Remove previous failed requests. + ets:match_delete(ETS, {failed, {Key, '_', '_'}}), + dets:match_delete(DETS, {failed, {Key, '_', '_'}}); + true -> + ?vtrace("still some tries to go",[]), + no + end; + Other -> + no + end, + {noreply, Tables}; + +handle_cast({store_successful_auth, [User, Addr, Port, SDirData]}, Tables) -> + ?vlog("store successfull auth",[]), + {ETS, DETS} = httpd_util:key1search(SDirData, data_file), + AuthTimeOut = httpd_util:key1search(SDirData, auth_timeout, 30), + Dir = httpd_util:key1search(SDirData, path), + Key = {User, Dir, Addr, Port}, + + %% Remove failed entries for this Key + dets:match_delete(DETS, {failed, {Key, '_', '_'}}), + ets:match_delete(ETS, {failed, {Key, '_', '_'}}), + + %% Keep track of when the last successful login took place. + Seconds = universal_time()+AuthTimeOut, + ets:match_delete(ETS, {success, {Key, '_'}}), + dets:match_delete(DETS, {success, {Key, '_'}}), + ets:insert(ETS, {success, {Key, Seconds}}), + dets:insert(DETS, {success, {Key, Seconds}}), + {noreply, Tables}; + +handle_cast(Req, Tables) -> + ?vinfo("~n unknown cast '~p'",[Req]), + error_msg("security server got unknown cast: ~p",[Req]), + {noreply, Tables}. + + +%% handle_info + +handle_info(Info, State) -> + ?vinfo("~n unknown info '~p'",[Info]), + {noreply, State}. + + +%% terminate + +terminate(Reason, _Tables) -> + ?vlog("~n Terminating for reason: ~p",[Reason]), + ok. + + +%% code_change({down, ToVsn}, State, Extra) +%% +code_change({down, _}, State, _Extra) -> + ?vlog("downgrade", []), + {ok, State}; + + +%% code_change(FromVsn, State, Extra) +%% +code_change(_, State, Extra) -> + ?vlog("upgrade", []), + {ok, State}. + + + + +%% block_user_int/2 +block_user_int({User, Addr, Port, Dir, Time}) -> + Dirs = httpd_manager:config_match(Addr, Port, {security_directory, '_'}), + ?vtrace("block '~p' for ~p during ~p",[User,Dir,Time]), + case find_dirdata(Dirs, Dir) of + {ok, DirData, {ETS, DETS}} -> + Time1 = + case Time of + infinity -> + 99999999999999999999999999999; + _ -> + Time + end, + Future = universal_time()+Time1, + ets:match_delete(ETS, {blocked_user, {User,Addr,Port,Dir,'_'}}), + dets:match_delete(DETS, {blocked_user, {User,Addr,Port,Dir,'_'}}), + ets:insert(ETS, {blocked_user, {User,Addr,Port,Dir,Future}}), + dets:insert(DETS, {blocked_user, {User,Addr,Port,Dir,Future}}), + CBModule = httpd_util:key1search(DirData, callback_module, + no_module_at_all), + ?vtrace("call back module ~p",[CBModule]), + user_block_event(CBModule,Addr,Port,Dir,User), + true; + _ -> + {error, no_such_directory} + end. + + +find_dirdata([], _Dir) -> + false; +find_dirdata([{security_directory, DirData}|SDirs], Dir) -> + case lists:keysearch(path, 1, DirData) of + {value, {path, Dir}} -> + {value, {data_file, {ETS, DETS}}} = + lists:keysearch(data_file, 1, DirData), + {ok, DirData, {ETS, DETS}}; + _ -> + find_dirdata(SDirs, Dir) + end. + +%% unblock_user_int/2 + +unblock_user_int({User, Addr, Port, Dir}) -> + ?vtrace("unblock user '~p' for ~p",[User,Dir]), + Dirs = httpd_manager:config_match(Addr, Port, {security_directory, '_'}), + ?vtrace("~n dirs: ~p",[Dirs]), + case find_dirdata(Dirs, Dir) of + {ok, DirData, {ETS, DETS}} -> + case ets:match_object(ETS,{blocked_user,{User,Addr,Port,Dir,'_'}}) of + [] -> + ?vtrace("not blocked",[]), + {error, not_blocked}; + Objects -> + ets:match_delete(ETS, {blocked_user, + {User, Addr, Port, Dir, '_'}}), + dets:match_delete(DETS, {blocked_user, + {User, Addr, Port, Dir, '_'}}), + CBModule = httpd_util:key1search(DirData, callback_module, + no_module_at_all), + user_unblock_event(CBModule,Addr,Port,Dir,User), + true + end; + _ -> + ?vlog("~n cannot unblock: no such directory '~p'",[Dir]), + {error, no_such_directory} + end. + + + +%% list_auth/2 + +list_auth([], _Addr, _Port, Dir, Acc) -> + Acc; +list_auth([{Name, {ETS, DETS}}|Tables], Addr, Port, Dir, Acc) -> + case ets:match_object(ETS, {success, {{'_', Dir, Addr, Port}, '_'}}) of + [] -> + list_auth(Tables, Addr, Port, Dir, Acc); + List when list(List) -> + TN = universal_time(), + NewAcc = lists:foldr(fun({success,{{U,Ad,P,D},T}},Ac) -> + if + T-TN > 0 -> + [U|Ac]; + true -> + Rec = {success,{{U,Ad,P,D},T}}, + ets:match_delete(ETS,Rec), + dets:match_delete(DETS,Rec), + Ac + end + end, + Acc, List), + list_auth(Tables, Addr, Port, Dir, NewAcc); + _ -> + list_auth(Tables, Addr, Port, Dir, Acc) + end. + + +%% list_blocked/2 + +list_blocked([], Addr, Port, Dir, Acc) -> + TN = universal_time(), + lists:foldl(fun({U,Ad,P,D,T}, Ac) -> + if + T-TN > 0 -> + [{U,Ad,P,D,local_time(T)}|Ac]; + true -> + Ac + end + end, + [], Acc); +list_blocked([{Name, {ETS, DETS}}|Tables], Addr, Port, Dir, Acc) -> + NewBlocked = + case ets:match_object(ETS, {blocked_user, {'_',Addr,Port,Dir,'_'}}) of + List when list(List) -> + lists:foldl(fun({blocked_user, X}, A) -> [X|A] end, Acc, List); + _ -> + Acc + end, + list_blocked(Tables, Addr, Port, Dir, NewBlocked). + + +%% +%% sync_dets_to_ets/2 +%% +%% Reads dets-table DETS and syncronizes it with the ets-table ETS. +%% +sync_dets_to_ets(DETS, ETS) -> + dets:traverse(DETS, fun(X) -> + ets:insert(ETS, X), + continue + end). + +%% +%% check_blocked_user/7 -> true | false +%% +%% Check if a specific user is blocked from access. +%% +%% The sideeffect of this routine is that it unblocks also other users +%% whos blocking time has expired. This to keep the tables as small +%% as possible. +%% +check_blocked_user(Info, User, Dir, Addr, Port, ETS, DETS, CBModule) -> + TN = universal_time(), + case ets:match_object(ETS, {blocked_user, {User, '_', '_', '_', '_'}}) of + List when list(List) -> + Blocked = lists:foldl(fun({blocked_user, X}, A) -> + [X|A] end, [], List), + check_blocked_user(Info,User,Dir,Addr,Port,ETS,DETS,TN,Blocked,CBModule); + _ -> + false + end. +check_blocked_user(Info, User, Dir, Addr, Port, ETS, DETS, TN, [], CBModule) -> + false; +check_blocked_user(Info, User, Dir, Addr, Port, ETS, DETS, TN, + [{User,Addr,Port,Dir,T}|Ls], CBModule) -> + TD = T-TN, + if + TD =< 0 -> + %% Blocking has expired, remove and grant access. + unblock_user(Info, User, Dir, Addr, Port, ETS, DETS, CBModule), + false; + true -> + true + end; +check_blocked_user(Info, User, Dir, Addr, Port, ETS, DETS, TN, + [{OUser,ODir,OAddr,OPort,T}|Ls], CBModule) -> + TD = T-TN, + if + TD =< 0 -> + %% Blocking has expired, remove. + unblock_user(Info, OUser, ODir, OAddr, OPort, ETS, DETS, CBModule); + true -> + true + end, + check_blocked_user(Info, User, Dir, Addr, Port, ETS, DETS, TN, Ls, CBModule). + +unblock_user(Info, User, Dir, Addr, Port, ETS, DETS, CBModule) -> + Reason=io_lib:format("User ~s was removed from the block list for dir ~s", + [User, Dir]), + mod_log:security_log(Info, lists:flatten(Reason)), + user_unblock_event(CBModule,Addr,Port,Dir,User), + dets:match_delete(DETS, {blocked_user, {User, Addr, Port, Dir, '_'}}), + ets:match_delete(ETS, {blocked_user, {User, Addr, Port, Dir, '_'}}). + + +make_name(Addr,Port) -> + httpd_util:make_name("httpd_security",Addr,Port). + +make_name(Addr,Port,Num) -> + httpd_util:make_name("httpd_security",Addr,Port, + "__" ++ integer_to_list(Num)). + + +auth_fail_event(Mod,Addr,Port,Dir,User,Passwd) -> + event(auth_fail,Mod,Addr,Port,Dir,[{user,User},{password,Passwd}]). + +user_block_event(Mod,Addr,Port,Dir,User) -> + event(user_block,Mod,Addr,Port,Dir,[{user,User}]). + +user_unblock_event(Mod,Addr,Port,Dir,User) -> + event(user_unblock,Mod,Addr,Port,Dir,[{user,User}]). + +event(Event,Mod,undefined,Port,Dir,Info) -> + (catch Mod:event(Event,Port,Dir,Info)); +event(Event,Mod,Addr,Port,Dir,Info) -> + (catch Mod:event(Event,Addr,Port,Dir,Info)). + +universal_time() -> + calendar:datetime_to_gregorian_seconds(calendar:universal_time()). + +local_time(T) -> + calendar:universal_time_to_local_time( + calendar:gregorian_seconds_to_datetime(T)). + + +error_msg(F, A) -> + error_logger:error_msg(F, A). + + +call(Name, Req) -> + case (catch gen_server:call(Name, Req)) of + {'EXIT', Reason} -> + {error, Reason}; + Reply -> + Reply + end. + + +cast(Name, Msg) -> + case (catch gen_server:cast(Name, Msg)) of + {'EXIT', Reason} -> + {error, Reason}; + Result -> + Result + end. diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_trace.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_trace.erl new file mode 100644 index 0000000000..9f4d331d82 --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/mod_trace.erl @@ -0,0 +1,64 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Ericsson Utvecklings AB. +%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings +%% AB. All Rights Reserved.'' +%% +%% $Id: mod_trace.erl,v 1.1 2008/12/17 09:53:36 mikpe Exp $ +%% +-module(mod_trace). + +-export([do/1]). + +-include("httpd.hrl"). + + +do(Info) -> + %%?vtrace("do",[]), + case Info#mod.method of + "TRACE" -> + case httpd_util:response_generated(Info) of + false-> + generate_trace_response(Info); + true-> + {proceed,Info#mod.data} + end; + _ -> + {proceed,Info#mod.data} + end. + + +%%--------------------------------------------------------------------- +%%Generate the trace response the trace response consists of a +%%http-header and the body will be the request. +%5---------------------------------------------------------------------- + +generate_trace_response(Info)-> + RequestHead=Info#mod.parsed_header, + Body=generate_trace_response_body(RequestHead), + Len=length(Body), + Response=["HTTP/1.1 200 OK\r\n", + "Content-Type:message/http\r\n", + "Content-Length:",integer_to_list(Len),"\r\n\r\n", + Info#mod.request_line,Body], + httpd_socket:deliver(Info#mod.socket_type,Info#mod.socket,Response), + {proceed,[{response,{already_sent,200,Len}}|Info#mod.data]}. + +generate_trace_response_body(Parsed_header)-> + generate_trace_response_body(Parsed_header,[]). + +generate_trace_response_body([],Head)-> + lists:flatten(Head); +generate_trace_response_body([{[],[]}|Rest],Head) -> + generate_trace_response_body(Rest,Head); +generate_trace_response_body([{Field,Value}|Rest],Head) -> + generate_trace_response_body(Rest,[Field ++ ":" ++ Value ++ "\r\n"|Head]). diff --git a/lib/dialyzer/test/r9c_SUITE_data/src/inets/uri.erl b/lib/dialyzer/test/r9c_SUITE_data/src/inets/uri.erl new file mode 100644 index 0000000000..9a4f77f87b --- /dev/null +++ b/lib/dialyzer/test/r9c_SUITE_data/src/inets/uri.erl @@ -0,0 +1,349 @@ +%% ``The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved via the world wide web at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% The Initial Developer of the Original Code is Mobile Arts AB +%% Portions created by Mobile Arts are Copyright 2002, Mobile Arts AB +%% All Rights Reserved.'' +%% +%% +%% Author : Johan Blom <[email protected]> +%% Description : +%% Implements various scheme dependent subsets (e.g. HTTP, FTP etc) based on +%% RFC 2396, Uniform Resource Identifiers (URI): Generic Syntax +%% Created : 27 Jul 2001 by Johan Blom <[email protected]> +%% + +-module(uri). + +-author('[email protected]'). + +-export([parse/1,resolve/2]). + + +%%% Parse URI and return {Scheme,Path} +%%% Note that Scheme specific parsing/validation is not handled here! +resolve(Root,Rel) -> + ok. + +%%% See "http://www.isi.edu/in-notes/iana/assignments/url-schemes" for a list of +%%% defined URL schemes and references to its sources. + +parse(URI) -> + case parse_scheme(URI) of + {http,Cont} -> parse_http(Cont,http); + {https,Cont} -> parse_http(Cont,https); + {ftp,Cont} -> parse_ftp(Cont,ftp); + {sip,Cont} -> parse_sip(Cont,sip); + {sms,Cont} -> parse_sms(Cont,sip); + {error,Error} -> {error,Error}; + {Scheme,Cont} -> {Scheme,Cont} + end. + + +%%% Parse the scheme. +parse_scheme(URI) -> + parse_scheme(URI,[]). + +parse_scheme([H|URI],Acc) when $a=<H,H=<$z; $A=<H,H=<$Z -> + parse_scheme2(URI,[H|Acc]); +parse_scheme(_,_) -> + {error,no_scheme}. + +parse_scheme2([H|URI],Acc) + when $a=<H,H=<$z; $A=<H,H=<$Z; $0=<H,H=<$9; H==$-;H==$+;H==$. -> + parse_scheme2(URI,[H|Acc]); +parse_scheme2([$:|URI],Acc) -> + {list_to_atom(lists:reverse(Acc)),URI}; +parse_scheme2(_,_) -> + {error,no_scheme}. + + +%%% ............................................................................ +-define(HTTP_DEFAULT_PORT, 80). +-define(HTTPS_DEFAULT_PORT, 443). + +%%% HTTP (Source RFC 2396, RFC 2616) +%%% http_URL = "*" | absoluteURI | abs_path [ "?" query ] | authority + +%%% http_URL = "http:" "//" host [ ":" port ] [ abs_path [ "?" query ]] +%%% Returns a tuple {http,Host,Port,PathQuery} where +%%% Host = string() Host value +%%% Port = string() Port value +%%% PathQuery= string() Combined absolute path and query value +parse_http("//"++C0,Scheme) -> + case scan_hostport(C0,Scheme) of + {C1,Host,Port} -> + case scan_pathquery(C1) of + {error,Error} -> + {error,Error}; + PathQuery -> + {Scheme,Host,Port,PathQuery} + end; + {error,Error} -> + {error,Error} + end; +parse_http(_,_) -> + {error,invalid_url}. + +scan_pathquery(C0) -> + case scan_abspath(C0) of + {error,Error} -> + {error,Error}; + {[],[]} -> % Add implicit path + "/"; + {"?"++C1,Path} -> + case scan_query(C1,[]) of + {error,Error} -> + {error,Error}; + Query -> + Path++"?"++Query + end; + {[],Path} -> + Path + end. + + +%%% ............................................................................ +%%% FIXME!!! This is just a quick hack that doesn't work! +-define(FTP_DEFAULT_PORT, 80). + +%%% FTP (Source RFC 2396, RFC 1738, RFC 959) +%%% Note: This BNF has been modified to better fit with RFC 2396 +%%% ftp_URL = "ftp:" "//" [ ftp_userinfo ] host [ ":" port ] ftp_abs_path +%%% ftp_userinfo = ftp_user [ ":" ftp_password ] +%%% ftp_abs_path = "/" ftp_path_segments [ ";type=" ftp_type ] +%%% ftp_path_segments = ftp_segment *( "/" ftp_segment) +%%% ftp_segment = *[ ftp_uchar | "?" | ":" | "@" | "&" | "=" ] +%%% ftp_type = "A" | "I" | "D" | "a" | "i" | "d" +%%% ftp_user = *[ ftp_uchar | ";" | "?" | "&" | "=" ] +%%% ftp_password = *[ ftp_uchar | ";" | "?" | "&" | "=" ] +%%% ftp_uchar = ftp_unreserved | escaped +%%% ftp_unreserved = alphanum | mark | "$" | "+" | "," +parse_ftp("//"++C0,Scheme) -> + case ftp_userinfo(C0) of + {C1,Creds} -> + case scan_hostport(C1,Scheme) of + {C2,Host,Port} -> + case scan_abspath(C2) of + {error,Error} -> + {error,Error}; + {[],[]} -> % Add implicit path + {Scheme,Creds,Host,Port,"/"}; + {[],Path} -> + {Scheme,Creds,Host,Port,Path} + end; + {error,Error} -> + {error,Error} + end; + {error,Error} -> + {error,Error} + end. + +ftp_userinfo(C0) -> + User="", + Password="", + {C0,{User,Password}}. + + +%%% ............................................................................ +%%% SIP (Source RFC 2396, RFC 2543) +%%% sip_URL = "sip:" [ sip_userinfo "@" ] host [ ":" port ] +%%% sip_url-parameters [ sip_headers ] +%%% sip_userinfo = sip_user [ ":" sip_password ] +%%% sip_user = *( unreserved | escaped | "&" | "=" | "+" | "$" | "," ) +%%% sip_password = *( unreserved | escaped | "&" | "=" | "+" | "$" | "," ) +%%% sip_url-parameters = *( ";" sip_url-parameter ) +%%% sip_url-parameter = sip_transport-param | sip_user-param | +%%% sip_method-param | sip_ttl-param | +%%% sip_maddr-param | sip_other-param +%%% sip_transport-param = "transport=" ( "udp" | "tcp" ) +%%% sip_ttl-param = "ttl=" sip_ttl +%%% sip_ttl = 1*3DIGIT ; 0 to 255 +%%% sip_maddr-param = "maddr=" host +%%% sip_user-param = "user=" ( "phone" | "ip" ) +%%% sip_method-param = "method=" sip_Method +%%% sip_tag-param = "tag=" sip_UUID +%%% sip_UUID = 1*( hex | "-" ) +%%% sip_other-param = ( token | ( token "=" ( token | quoted-string ))) +%%% sip_Method = "INVITE" | "ACK" | "OPTIONS" | "BYE" | +%%% "CANCEL" | "REGISTER" +%%% sip_token = 1*< any CHAR except CTL's or separators> +%%% sip_quoted-string = ( <"> *(qdtext | quoted-pair ) <"> ) +%%% sip_qdtext = <any TEXT-UTF8 except <">> +%%% sip_quoted-pair = " \ " CHAR +parse_sip(Cont,Scheme) -> + {Scheme,Cont}. + + + + +%%% ............................................................................ +%%% SMS (Source draft-wilde-sms-uri-01, January 24 2002 and +%%% draft-allocchio-gstn-01, November 2001) +%%% The syntax definition for "gstn-phone" is taken from +%%% [draft-allocchio-gstn-01], allowing global as well as local telephone +%%% numbers. +%%% Note: This BNF has been modified to better fit with RFC 2396 +%%% sms_URI = sms ":" 1*( sms-recipient ) [ sms-body ] +%%% sms-recipient = gstn-phone sms-qualifier +%%% [ "," sms-recipient ] +%%% sms-qualifier = *( smsc-qualifier / pid-qualifier ) +%%% smsc-qualifier = ";smsc=" SMSC-sub-addr +%%% pid-qualifier = ";pid=" PID-sub-addr +%%% sms-body = ";body=" *urlc +%%% gstn-phone = ( global-phone / local-phone ) +%%% global-phone = "+" 1*( DIGIT / written-sep ) +%%% local-phone = [ exit-code ] dial-number / exit-code [ dial-number ] +%%% exit-code = phone-string +%%% dial-number = phone-string +%%% subaddr-string = phone-string +%%% post-dial = phone-string +%%% phone-string = 1*( DTMF / pause / tonewait / written-sep ) +%%% DTMF = ( DIGIT / "#" / "*" / "A" / "B" / "C" / "D" ) +%%% written-sep = ( "-" / "." ) +%%% pause = "p" +%%% tonewait = "w" +parse_sms(Cont,Scheme) -> + {Scheme,Cont}. + + +%%% ============================================================================ +%%% Generic URI parsing. BNF rules from RFC 2396 + +%%% hostport = host [ ":" port ] +scan_hostport(C0,Scheme) -> + case scan_host(C0) of + {error,Error} -> + {error,Error}; + {":"++C1,Host} -> + {C2,Port}=scan_port(C1,[]), + {C2,Host,list_to_integer(Port)}; + {C1,Host} when Scheme==http -> + {C1,Host,?HTTP_DEFAULT_PORT}; + {C1,Host} when Scheme==https -> + {C1,Host,?HTTPS_DEFAULT_PORT}; + {C1,Host} when Scheme==ftp -> + {C1,Host,?FTP_DEFAULT_PORT} + end. + + +%%% host = hostname | IPv4address +%%% hostname = *( domainlabel "." ) toplabel [ "." ] +%%% domainlabel = alphanum | alphanum *( alphanum | "-" ) alphanum +%%% toplabel = alpha | alpha *( alphanum | "-" ) alphanum +%%% IPv4address = 1*digit "." 1*digit "." 1*digit "." 1*digit + +-define(ALPHA, 1). +-define(DIGIT, 2). + +scan_host(C0) -> + case scan_host2(C0,[],0,[],[]) of + {C1,IPv4address,[?DIGIT,?DIGIT,?DIGIT,?DIGIT]} -> + {C1,lists:reverse(lists:append(IPv4address))}; + {C1,Hostname,[?ALPHA|HostF]} -> + {C1,lists:reverse(lists:append(Hostname))}; + _ -> + {error,no_host} + end. + +scan_host2([H|C0],Acc,CurF,Host,HostF) when $0=<H,H=<$9 -> + scan_host2(C0,[H|Acc],CurF bor ?DIGIT,Host,HostF); +scan_host2([H|C0],Acc,CurF,Host,HostF) when $a=<H,H=<$z; $A=<H,H=<$Z -> + scan_host2(C0,[H|Acc],CurF bor ?ALPHA,Host,HostF); +scan_host2([$-|C0],Acc,CurF,Host,HostF) when CurF=/=0 -> + scan_host2(C0,[$-|Acc],CurF,Host,HostF); +scan_host2([$.|C0],Acc,CurF,Host,HostF) when CurF=/=0 -> + scan_host2(C0,[],0,[".",Acc|Host],[CurF|HostF]); +scan_host2(C0,Acc,CurF,Host,HostF) -> + {C0,[Acc|Host],[CurF|HostF]}. + + +%%% port = *digit +scan_port([H|C0],Acc) when $0=<H,H=<$9 -> + scan_port(C0,[H|Acc]); +scan_port(C0,Acc) -> + {C0,lists:reverse(Acc)}. + +%%% abs_path = "/" path_segments +scan_abspath([]) -> + {[],[]}; +scan_abspath("/"++C0) -> + scan_pathsegments(C0,["/"]); +scan_abspath(_) -> + {error,no_abspath}. + +%%% path_segments = segment *( "/" segment ) +scan_pathsegments(C0,Acc) -> + case scan_segment(C0,[]) of + {"/"++C1,Segment} -> + scan_pathsegments(C1,["/",Segment|Acc]); + {C1,Segment} -> + {C1,lists:reverse(lists:append([Segment|Acc]))} + end. + + +%%% segment = *pchar *( ";" param ) +%%% param = *pchar +scan_segment(";"++C0,Acc) -> + {C1,ParamAcc}=scan_pchars(C0,";"++Acc), + scan_segment(C1,ParamAcc); +scan_segment(C0,Acc) -> + case scan_pchars(C0,Acc) of + {";"++C1,Segment} -> + {C2,ParamAcc}=scan_pchars(C1,";"++Segment), + scan_segment(C2,ParamAcc); + {C1,Segment} -> + {C1,Segment} + end. + +%%% query = *uric +%%% uric = reserved | unreserved | escaped +%%% reserved = ";" | "/" | "?" | ":" | "@" | "&" | "=" | "+" | +%%% "$" | "," +%%% unreserved = alphanum | mark +%%% mark = "-" | "_" | "." | "!" | "~" | "*" | "'" | +%%% "(" | ")" +%%% escaped = "%" hex hex +scan_query([],Acc) -> + lists:reverse(Acc); +scan_query([$%,H1,H2|C0],Acc) -> % escaped + scan_query(C0,[hex2dec(H1)*16+hex2dec(H2)|Acc]); +scan_query([H|C0],Acc) when $a=<H,H=<$z;$A=<H,H=<$Z;$0=<H,H=<$9 -> % alphanum + scan_query(C0,[H|Acc]); +scan_query([H|C0],Acc) when H==$;; H==$/; H==$?; H==$:; H==$@; + H==$&; H==$=; H==$+; H==$$; H==$, -> % reserved + scan_query(C0,[H|Acc]); +scan_query([H|C0],Acc) when H==$-; H==$_; H==$.; H==$!; H==$~; + H==$*; H==$'; H==$(; H==$) -> % mark + scan_query(C0,[H|Acc]); +scan_query([H|C0],Acc) -> + {error,no_query}. + + +%%% pchar = unreserved | escaped | +%%% ":" | "@" | "&" | "=" | "+" | "$" | "," +scan_pchars([],Acc) -> + {[],Acc}; +scan_pchars([$%,H1,H2|C0],Acc) -> % escaped + scan_pchars(C0,[hex2dec(H1)*16+hex2dec(H2)|Acc]); +scan_pchars([H|C0],Acc) when $a=<H,H=<$z;$A=<H,H=<$Z;$0=<H,H=<$9 -> % alphanum + scan_pchars(C0,[H|Acc]); +scan_pchars([H|C0],Acc) when H==$-; H==$_; H==$.; H==$!; H==$~; + H==$*; H==$'; H==$(; H==$) -> % mark + scan_pchars(C0,[H|Acc]); +scan_pchars([H|C0],Acc) when H==$:; H==$@; H==$&; H==$=; H==$+; H==$$; H==$, -> + scan_pchars(C0,[H|Acc]); +scan_pchars(C0,Acc) -> + {C0,Acc}. + +hex2dec(X) when X>=$0,X=<$9 -> X-$0; +hex2dec(X) when X>=$A,X=<$F -> X-$A+10; +hex2dec(X) when X>=$a,X=<$f -> X-$a+10. |